car/0000755000176000001440000000000014141412044011042 5ustar ripleyuserscar/NAMESPACE0000644000176000001440000002442614140314042012267 0ustar ripleyusers# last modified 2021-11-02 by A. Zeileis # additions for car >= 3.0-0, started 2016-12-27 export(Import, Export, Predict, bcnPowerAxis) export(Confint, S, carPalette, poTest, brief) export(strings2factors) S3method(Confint, lm) S3method(Confint, glm) S3method(Confint, multinom) S3method(Confint, polr) S3method(Confint, default) S3method(Confint, boot) S3method(Confint, lme) S3method(Confint, lmerMod) S3method(Confint, glmerMod) S3method(S, lm) S3method(S, glm) S3method(S, multinom) S3method(S, polr) S3method(S, lme) S3method(S, lmerMod) S3method(S, glmerMod) S3method(S, default) S3method(S, data.frame) S3method(print, S.lm) S3method(print, S.glm) S3method(print, S.multinom) S3method(print, S.polr) S3method(print, S.lme) S3method(print, S.lmerMod) S3method(print, S.glmerMod) S3method(print, poTest) S3method(brief, default) S3method(brief, lm) S3method(brief, glm) S3method(brief, multinom) S3method(brief, polr) S3method(qqPlot, formula) S3method(Predict, lm) S3method(poTest, polr) S3method(brief, data.frame) S3method(brief, matrix) S3method(brief, numeric) S3method(brief, character) S3method(brief, integer) S3method(brief, factor) S3method(brief, list) S3method(brief, "function") S3method(brief, default) S3method(brief, tbl) # S3method(influence, merMod) S3method(influence, lme) # S3method(cooks.distance, influence.merMod) S3method(cooks.distance, influence.lme) # S3method(dfbeta, influence.merMod) S3method(dfbeta, influence.lme) # S3method(dfbetas, influence.merMod) S3method(dfbetas, influence.lme) S3method(infIndexPlot, influence.merMod) S3method(infIndexPlot, influence.lme) S3method(whichNames, data.frame) S3method(whichNames, default) S3method(strings2factors, data.frame) import("carData") importFrom("abind", "abind") importFrom("stats", "naprint", "symnum", ".checkMFClasses", "delete.response", "napredict", "influence", "dfbetas", "AIC", "BIC", "expand.model.frame") importFrom("utils", "download.file", "capture.output", "askYesNo", "browseURL", "globalVariables", "getFromNamespace") # from earlier versions car package importFrom(graphics, abline, arrows, axis, box, boxplot, contour, hist, identify, layout, legend, lines, locator, mtext, pairs, par, plot, points, polygon, rug, segments, strheight, strwidth, text) importFrom(grDevices, boxplot.stats, col2rgb, gray, palette, rgb) importFrom(stats, D, IQR, alias, anova, as.formula, binomial, bw.nrd0, coef, coefficients, complete.cases, confint, contrasts, "contrasts<-", cooks.distance, cor, cov, cov.wt, cov2cor, density, deviance, df.residual, dfbeta, dnorm, drop1, family, fitted, fitted.values, fivenum, formula, gaussian, getCall, glm, glm.fit, hatvalues, is.empty.model, lm, lm.fit, loess, loess.control, logLik, lowess, lsfit, make.link, median, model.frame, model.matrix, model.matrix.default, model.response, model.weights, na.action, na.omit, na.pass, naresid, optim, optimize, p.adjust, pchisq, pf, pnorm, ppoints, predict, printCoefmat, pt, qchisq, qf, qnorm, qqline, qqnorm, qt, quantile, resid, residuals, rnorm, rstandard, rstudent, sd, setNames, spline, summary.lm, terms, update, var, vcov, weights, optimHess) importFrom(utils, browseURL, head, methods) # importFrom(VGAM, vcovvlm, coefvlm, formulavlm, model.matrixvlm) export( .carEnv, basicPowerAxis, bcPowerAxis, Boxplot, carHexsticker, carWeb, confidenceEllipse, contr.Helmert, contr.Sum, contr.Treatment, dataEllipse, densityPlot, ellipse, logit, panel.car, probabilityAxis, qqPlot, qqp, recode, Recode, regLine, scatter3d, scatterplot, scatterplotMatrix, sigmaHat, slp, some, sp, spm, spreadLevelPlot, symbox, which.names, whichNames, yjPowerAxis, Anova, basicPower, bcPower, yjPower, powerTransform, bcnPower, bcnPowerInverse, boxCox, boxCox2d, boxCoxVariable, boxTidwell, ceresPlot, ceresPlots, crPlot, crPlots, crp, dbiwt, deltaMethod, depan, dfbetaPlots, dfbetasPlots, dwt, durbinWatsonTest, testTransform, hccm, Identify3d, infIndexPlot, influenceIndexPlot, influencePlot, invResPlot, inverseResponsePlot, invTranPlot, invTranEstimate, leveneTest, leveragePlot, leveragePlots, lht, linearHypothesis, makeHypothesis, printHypothesis, Manova, mmp, mmps, marginalModelPlot, marginalModelPlots, ncvTest, outlierTest, vif, avPlot, avPlots, showLabels, residualPlot, residualPlots, bootCase, nextBoot, subsets, compareCoefs, matchCoefs, Boot, gamLine, loessLine, quantregLine, mcPlot, mcPlots, adaptiveKernel, Tapply, # method explicitly exported for import in other packages linearHypothesis.default, # deprecated functions av.plot, av.plots, box.cox, bc, box.cox.powers, box.cox.var, box.tidwell, cookd, confidence.ellipse, ceres.plot, ceres.plots, cr.plot, cr.plots, data.ellipse, durbin.watson, levene.test, leverage.plot, leverage.plots, linear.hypothesis, outlier.test, ncv.test, qq.plot, # scatterplot.matrix, skewPower, spread.level.plot, wcrossprod ) # methods S3method(confidenceEllipse, default) S3method(confidenceEllipse, glm) S3method(confidenceEllipse, lm) S3method(print, spreadLevelPlot) S3method(qqPlot, default) S3method(qqPlot, glm) S3method(qqPlot, lm) S3method(scatter3d, default) S3method(scatter3d, formula) S3method(scatterplot, default) S3method(scatterplot, formula) S3method(scatterplotMatrix, default) S3method(scatterplotMatrix, formula) S3method(sigmaHat, default) S3method(sigmaHat, lm) S3method(sigmaHat, glm) S3method(some, data.frame) S3method(some, default) S3method(some, matrix) S3method(spreadLevelPlot, default) S3method(spreadLevelPlot, formula) S3method(spreadLevelPlot, lm) S3method(subsets, regsubsets) S3method(boxCox, default) S3method(boxCox, lm) S3method(boxCox, formula) S3method(Anova, aov) S3method(Anova, coxph) S3method(Anova, coxme) S3method(Anova, default) S3method(Anova, glm) S3method(Anova, lm) S3method(Anova, lme) S3method(Anova, manova) S3method(Anova, mer) S3method(Anova, merMod) S3method(Anova, multinom) S3method(Anova, mlm) S3method(print, univaov) S3method(as.data.frame, univaov) S3method(Anova, polr) S3method(Anova, rlm) S3method(Anova, survreg) S3method(Anova, svyglm) S3method(avPlot, lm) S3method(avPlot, glm) S3method(avPlots, default) S3method(bootCase, lm) S3method(bootCase, glm) S3method(bootCase, nls) S3method(Boxplot, default) S3method(Boxplot, formula) S3method(Boxplot, list) S3method(Boxplot, data.frame) S3method(Boxplot, matrix) S3method(nextBoot, lm) S3method(nextBoot, nls) S3method(boxTidwell, default) S3method(boxTidwell, formula) S3method(ceresPlots, default) S3method(ceresPlot, glm) S3method(ceresPlot, lm) S3method(crPlot, lm) S3method(crPlots, default) S3method(deltaMethod, default) S3method(deltaMethod, lm) S3method(deltaMethod,multinom) S3method(deltaMethod,polr) S3method(deltaMethod, nls) S3method(deltaMethod, survreg) S3method(deltaMethod, coxph) S3method(deltaMethod, mer) S3method(deltaMethod, merMod) S3method(deltaMethod, lme) S3method(deltaMethod, lmList) S3method(densityPlot, default) S3method(densityPlot, formula) S3method(dfbetaPlots, lm) S3method(dfbetasPlots, lm) S3method(durbinWatsonTest, default) S3method(durbinWatsonTest, lm) S3method(powerTransform, default) S3method(powerTransform, lm) S3method(powerTransform, lmerMod) S3method(influencePlot, lm) S3method(influencePlot, lmerMod) S3method(inverseResponsePlot, lm) S3method(invTranPlot, formula) S3method(invTranPlot, default) S3method(infIndexPlot, lm) S3method(infIndexPlot, lmerMod) S3method(powerTransform, formula) S3method(hccm, default) S3method(hccm, lm) S3method(leveneTest, formula) S3method(leveneTest, lm) S3method(leveneTest, default) S3method(leveragePlot, glm) S3method(leveragePlot, lm) S3method(linearHypothesis, default) S3method(linearHypothesis, glm) S3method(linearHypothesis, lm) S3method(linearHypothesis, lme) S3method(linearHypothesis, mer) S3method(linearHypothesis, merMod) S3method(linearHypothesis, mlm) S3method(linearHypothesis, polr) S3method(linearHypothesis, rlm) S3method(linearHypothesis, svyglm) S3method(linearHypothesis, lmList) S3method(linearHypothesis, nlsList) S3method(linearHypothesis, survreg) S3method(Manova, mlm) S3method(matchCoefs, default) S3method(matchCoefs, lme) S3method(matchCoefs, mer) S3method(matchCoefs, merMod) S3method(matchCoefs, mlm) S3method(matchCoefs, lmList) S3method(mcPlots, default) S3method(mcPlot, lm) S3method(mcPlot, glm) S3method(mmp, default) S3method(mmp, lm) S3method(mmp, glm) S3method(na.action, merMod) S3method(ncvTest, glm) S3method(ncvTest, lm) S3method(outlierTest, lm) S3method(outlierTest, lmerMod) S3method(print, Anova.mlm) S3method(print, boxTidwell) S3method(print, linearHypothesis.mlm) S3method(print, chisqTest) S3method(print, durbinWatsonTest) S3method(print, outlierTest) S3method(print, powerTransform) S3method(print, bcnPowerTransform) S3method(print, summary.powerTransform) S3method(print, summary.bcnPowerTransform) S3method(summary, Anova.mlm) S3method(print, summary.Anova.mlm) S3method(print, powerTransform) S3method(summary, powerTransform) S3method(summary, bcnPowerTransform) S3method(summary, bcnPowerTransformlmer) S3method(coef, powerTransform) S3method(coef, bcnPowerTransform) S3method(vcov, powerTransform) S3method(vcov, bcnPowerTransform) S3method(testTransform, powerTransform) S3method(testTransform, bcnPowerTransform) S3method(testTransform, bcnPowerTransformlmer) S3method(testTransform, lmerModpowerTransform) S3method(residualPlots, lm) S3method(residualPlots, glm) S3method(residualPlot, default) S3method(residualPlot, lm) S3method(residualPlot, glm) S3method(summary, powerTransform) S3method(coef, powerTransform) S3method(vcov, powerTransform) S3method(vif, default) S3method(vif, merMod) S3method(vif, polr) S3method(vif, svyolr) S3method(symbox, formula) S3method(symbox, default) # added with bcnPower S3method(symbox, lm) # methods related to Boot S3method(Boot, default) S3method(Boot, lm) S3method(Boot, glm) S3method(Boot, nls) S3method(hist, boot) S3method(confint, boot) S3method(summary, boot) S3method(print, summary.boot) S3method(print, confint.boot) S3method(vcov, boot) S3method(print, deltaMethod) car/man/0000755000176000001440000000000014140261763011626 5ustar ripleyuserscar/man/TransformationAxes.Rd0000644000176000001440000001373114140261763015751 0ustar ripleyusers\name{TransformationAxes} \alias{basicPowerAxis} \alias{bcPowerAxis} \alias{bcnPowerAxis} \alias{yjPowerAxis} \alias{probabilityAxis} \title{Axes for Transformed Variables} \description{ These functions produce axes for the original scale of transformed variables. Typically these would appear as additional axes to the right or at the top of the plot, but if the plot is produced with \code{axes=FALSE}, then these functions could be used for axes below or to the left of the plot as well. } \usage{ basicPowerAxis(power, base=exp(1), side=c("right", "above", "left", "below"), at, start=0, lead.digits=1, n.ticks, grid=FALSE, grid.col=gray(0.50), grid.lty=2, axis.title="Untransformed Data", cex=1, las=par("las")) bcPowerAxis(power, side=c("right", "above", "left", "below"), at, start=0, lead.digits=1, n.ticks, grid=FALSE, grid.col=gray(0.50), grid.lty=2, axis.title="Untransformed Data", cex=1, las=par("las")) bcnPowerAxis(power, shift, side=c("right", "above", "left", "below"), at, start=0, lead.digits=1, n.ticks, grid=FALSE, grid.col=gray(0.50), grid.lty=2, axis.title="Untransformed Data", cex=1, las=par("las")) yjPowerAxis(power, side=c("right", "above", "left", "below"), at, lead.digits=1, n.ticks, grid=FALSE, grid.col=gray(0.50), grid.lty=2, axis.title="Untransformed Data", cex=1, las=par("las")) probabilityAxis(scale=c("logit", "probit"), side=c("right", "above", "left", "below"), at, lead.digits=1, grid=FALSE, grid.lty=2, grid.col=gray(0.50), axis.title = "Probability", interval = 0.1, cex = 1, las=par("las")) } \arguments{ \item{power}{power for Box-Cox, Box-Cox with negatives, Yeo-Johnson, or simple power transformation.} \item{shift}{the shift (gamma) parameter for the Box-Cox with negatives family.} \item{scale}{transformation used for probabilities, \code{"logit"} (the default) or \code{"probit"}.} \item{side}{side at which the axis is to be drawn; numeric codes are also permitted: \code{side = 1} for the bottom of the plot, \code{side=2} for the left side, \code{side = 3} for the top, \code{side = 4} for the right side.} \item{at}{numeric vector giving location of tick marks on original scale; if missing, the function will try to pick nice locations for the ticks.} \item{start}{if a \emph{start} was added to a variable (e.g., to make all data values positive), it can now be subtracted from the tick labels.} \item{lead.digits}{number of leading digits for determining `nice' numbers for tick labels (default is \code{1}.} \item{n.ticks}{number of tick marks; if missing, same as corresponding transformed axis.} \item{grid}{if \code{TRUE} grid lines for the axis will be drawn.} \item{grid.col}{color of grid lines.} \item{grid.lty}{line type for grid lines.} \item{axis.title}{title for axis.} \item{cex}{relative character expansion for axis label.} \item{las}{if \code{0}, ticks labels are drawn parallel to the axis; set to \code{1} for horizontal labels (see \code{\link{par}}).} \item{base}{base of log transformation for \code{power.axis} when \code{power = 0}.} \item{interval}{desired interval between tick marks on the probability scale.} } \details{ The transformations corresponding to the three functions are as follows: \describe{ \item{\code{basicPowerAxis}:}{Simple power transformation, \eqn{x^{\prime }=x^{p}}{x' = x^p} for \eqn{p\neq 0}{p != 0} and \eqn{x^{\prime }=\log x}{x' = log x} for \eqn{p=0}{p = 0}.} \item{\code{bcPowerAxis}:}{Box-Cox power transformation, \eqn{x^{\prime }=(x^{\lambda }-1)/\lambda}{x' = (x^p - 1)/p} for \eqn{\lambda \neq 0}{x != 0} and \eqn{x^{\prime }=\log x}{x' = log(x)} for \eqn{\lambda =0}{p = 0}.} \item{\code{bcnPowerAxis}:}{Box-Cox with negatives power transformation, the Box-Cox power transformation of \eqn{z = .5 * (y + (y^2 + \gamma^2)^{1/2})}, where \eqn{\gamma}{gamma} is strictly positive if \eqn{y}{y} includes negative values and non-negative otherwise. The value of \eqn{z}{z} is always positive.} \item{\code{yjPowerAxis}:}{Yeo-Johnson power transformation, for non-negative \eqn{x}{x}, the Box-Cox transformation of \eqn{x + 1}{x + 1}; for negative \eqn{x}{x}, the Box-Cox transformation of \eqn{|x| + 1}{|x| + 1} with power \eqn{2 - p}{2 - p}.} \item{\code{probabilityAxis}:}{logit or probit transformation, logit \eqn{=\log [p/(1-p)]}{= log[p/(1 - p)]}, or probit \eqn{=\Phi^{-1}(p)}{= Phi^-1(p)}, where \eqn{\Phi^{-1}}{Phi^-1} is the standard-normal quantile function.} } These functions will try to place tick marks at reasonable locations, but producing a good-looking graph sometimes requires some fiddling with the \code{at} argument. } \value{ These functions are used for their side effects: to draw axes. } \author{John Fox \email{jfox@mcmaster.ca}} \references{ Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. } \seealso{\code{\link{basicPower}}, \code{\link{bcPower}}, \code{\link{yjPower}}, \code{\link{logit}}.} \examples{ UN <- na.omit(UN) par(mar=c(5, 4, 4, 4) + 0.1) # leave space on right with(UN, plot(log(ppgdp, 10), log(infantMortality, 10))) basicPowerAxis(0, base=10, side="above", at=c(50, 200, 500, 2000, 5000, 20000), grid=TRUE, axis.title="GDP per capita") basicPowerAxis(0, base=10, side="right", at=c(5, 10, 20, 50, 100), grid=TRUE, axis.title="infant mortality rate per 1000") with(UN, plot(bcPower(ppgdp, 0), bcPower(infantMortality, 0))) bcPowerAxis(0, side="above", grid=TRUE, axis.title="GDP per capita") bcPowerAxis(0, side="right", grid=TRUE, axis.title="infant mortality rate per 1000") with(UN, qqPlot(logit(infantMortality/1000))) probabilityAxis() with(UN, qqPlot(qnorm(infantMortality/1000))) probabilityAxis(at=c(.005, .01, .02, .04, .08, .16), scale="probit") qqPlot(bcnPower(Ornstein$interlocks, lambda=1/3, gamma=0.1)) bcnPowerAxis(1/3, 0.1, at=c(o=0, 5, 10, 20, 40, 80)) } \keyword{aplot} car/man/leveragePlots.Rd0000644000176000001440000001017314140261763014733 0ustar ripleyusers\name{leveragePlots} \alias{leveragePlots} \alias{leveragePlot} \alias{leveragePlot.lm} \alias{leveragePlot.glm} \title{Regression Leverage Plots} \description{ These functions display a generalization, due to Sall (1990) and Cook and Weisberg (1991), of added-variable plots to multiple-df terms in a linear model. When a term has just 1 df, the leverage plot is a rescaled version of the usual added-variable (partial-regression) plot. } \usage{ leveragePlots(model, terms = ~., layout = NULL, ask, main, ...) leveragePlot(model, ...) \method{leveragePlot}{lm}(model, term.name, id=TRUE, col=carPalette()[1], col.lines=carPalette()[2], lwd=2, xlab, ylab, main="Leverage Plot", grid=TRUE, ...) \method{leveragePlot}{glm}(model, ...) } \arguments{ \item{model}{model object produced by \code{lm} } \item{terms}{ A one-sided formula that specifies a subset of the numeric regressors, factors and interactions. One added-variable plot is drawn for each term, either a main effect or an interactions. The default \code{~.} is to plot against all terms in the model. For example, the specification \code{terms = ~ . - X3} would plot against all predictors except for \code{X3}. If this argument is a quoted name of one of the predictors, the added-variable plot is drawn for that predictor only. The plots for main effects with interactions present violate the marginality principle and may not be easily interpreted. } \item{layout}{ If set to a value like \code{c(1, 1)} or \code{c(4, 3)}, the layout of the graph will have this many rows and columns. If not set, the program will select an appropriate layout. If the number of graphs exceed nine, you must select the layout yourself, or you will get a maximum of nine per page. If \code{layout=NA}, the function does not set the layout and the user can use the \code{par} function to control the layout, for example to have plots from two models in the same graphics window. } \item{ask}{if \code{TRUE}, a menu is provided in the R Console for the user to select the term(s) to plot. } \item{xlab, ylab}{axis labels; if missing, labels will be supplied. } \item{main}{title for plot; if missing, a title will be supplied. } \item{\dots}{arguments passed down to method functions.} \item{term.name}{Quoted name of term in the model to be plotted; this argument is omitted for \code{leveragePlots}.} \item{id}{controls point identification; if \code{FALSE}, no points are identified; can be a list of named arguments to the \code{\link{showLabels}} function; \code{TRUE}, the default, is equivalent to \code{list(method=list(abs(residuals(model, type="pearson")), "x"), n=2, cex=1, col=carPalette()[1], location="lr")}, which identifies the 2 points with the largest residuals and the 2 points with the greatest partial leverage.} \item{col}{color(s) of points} \item{col.lines}{color of the fitted line } \item{lwd}{line width; default is \code{2} (see \code{\link{par}}). } \item{grid}{If TRUE, the default, a light-gray background grid is put on the graph} } \details{ The function intended for direct use is \code{leveragePlots}. The model can contain factors and interactions. A leverage plot can be drawn for each term in the model, including the constant. \code{leveragePlot.glm} is a dummy function, which generates an error message. } \value{ \code{NULL}. These functions are used for their side effect: producing plots. } \references{ Cook, R. D. and Weisberg, S. (1991). Added Variable Plots in Linear Regression. In Stahel, W. and Weisberg, S. (eds.), \emph{Directions in Robust Statistics and Diagnostics}. Springer, 47-60. Fox, J. (2016) \emph{Applied Regression Analysis and Generalized Linear Models}, Third Edition. Sage. Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. Sall, J. (1990) Leverage plots for general linear hypotheses. \emph{American Statistician} \bold{44}, 308--315. } \author{John Fox \email{jfox@mcmaster.ca}} \seealso{\code{\link{avPlots}}} \examples{ leveragePlots(lm(prestige~(income+education)*type, data=Duncan)) } \keyword{hplot} \keyword{regression} car/man/logit.Rd0000644000176000001440000000302114140261763013227 0ustar ripleyusers\name{logit} \alias{logit} \title{Logit Transformation} \description{ Compute the logit transformation of proportions or percentages. } \usage{ logit(p, percents=range.p[2] > 1, adjust) } \arguments{ \item{p}{numeric vector or array of proportions or percentages.} \item{percents}{\code{TRUE} for percentages.} \item{adjust}{adjustment factor to avoid proportions of 0 or 1; defaults to \code{0} if there are no such proportions in the data, and to \code{.025} if there are.} } \details{ Computes the logit transformation logit \eqn{=\log [p/(1-p)]}{= log[p/(1 - p)]} for the proportion \eqn{p}. If \eqn{p=0}{p = 0} or \eqn{1}, then the logit is undefined. \code{logit} can remap the proportions to the interval \code{(adjust, 1 - adjust)} prior to the transformation. If it adjusts the data automatically, \code{logit} will print a warning message. } \value{ a numeric vector or array of the same shape and size as \code{p}. } \references{ Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. } \author{John Fox \email{jfox@mcmaster.ca}} \seealso{\code{\link{probabilityAxis}}} \examples{ options(digits=4) logit(.1*0:10) ## [1] -3.6636 -1.9924 -1.2950 -0.8001 -0.3847 0.0000 0.3847 ## [8] 0.8001 1.2950 1.9924 3.6636 ## Warning message: ## proportions remapped to (0.025, 0.975) in: logit(0.1 * 0:10) logit(.1*0:10, adjust=0) ## [1] -Inf -2.1972 -1.3863 -0.8473 -0.4055 0.0000 0.4055 ## [8] 0.8473 1.3863 2.1972 Inf } \keyword{manip} car/man/invResPlot.Rd0000644000176000001440000000601014140261763014217 0ustar ripleyusers\name{invResPlot} \alias{invResPlot} \alias{inverseResponsePlot} \alias{inverseResponsePlot.lm} \title{Inverse Response Plots to Transform the Response} \description{ For a \code{lm} model, draws an inverse.response plot with the response \eqn{Y}{Y} on the vertical axis and the fitted values \eqn{\hat{Y}}{Yhat} on the horizontal axis. Uses \code{nls} to estimate \eqn{\lambda}{lambda} in the function \eqn{\hat{Y}=b_0+b_1Y^{\lambda}}{Yhat = b0 + b1(Y)^(lambda)}. Adds the fitted curve to the plot. \code{invResPlot} is an alias for \code{inverseResponsePlot}. } \usage{ inverseResponsePlot(model, lambda=c(-1,0,1), robust=FALSE, xlab=NULL, ...) \S3method{inverseResponsePlot}{lm}(model, lambda=c(-1, 0, 1), robust=FALSE, xlab=NULL, id=FALSE, ...) invResPlot(model, ...) } \arguments{ \item{model}{A \code{"lm"} regression object.} \item{lambda}{A vector of values for lambda. A plot will be produced with curves corresponding to these lambdas and to the nonlinear least squares estimate of lambda.} \item{robust}{If \code{TRUE}, then estimation uses Huber M-estimates with the median absolute deviation to estimate scale and k= 1.345. The default is \code{FALSE}.} \item{xlab}{The horizontal axis label. If \code{NULL}, it is constructed by the function.} \item{id}{controls point identification; if \code{FALSE} (the default), no points are identified; can be a list of named arguments to the \code{\link{showLabels}} function; \code{TRUE} is equivalent to \code{list(method=list(method="x", n=2, cex=1, col=carPalette()[1], location="lr")}, which identifies the 2 points with the most extreme horizontal (X) values.} \item{\dots}{Other arguments passed to \code{invTranPlot} and then to \code{plot}.} } \value{ As a side effect, a plot is produced with the response on the horizontal axis and fitted values on the vertical axis. Several lines are added to be plot as the ols estimates of the regression of \eqn{\hat{Y}}{Yhat} on \eqn{Y^{\lambda}}{Y^(lambda)}, interpreting \eqn{\lambda}{lambda} = 0 to be natural logarithms. Numeric output is a list with elements \item{lambda}{Estimate of transformation parameter for the response} \item{RSS}{The residual sum of squares at the minimum if robust=FALSE. If robust = TRUE, the value of Huber objective function is returned.} } \seealso{\code{\link{invTranPlot}}, \code{\link{powerTransform}}, \code{\link{showLabels}}} \references{ Fox, J. and Weisberg, S. (2011) \emph{An R Companion to Applied Regression}, Second Edition, Sage. Prendergast, L. A., & Sheather, S. J. (2013) On sensitivity of inverse response plot estimation and the benefits of a robust estimation approach. \emph{Scandinavian Journal of Statistics}, 40(2), 219-237. Weisberg, S. (2014) \emph{Applied Linear Regression}, Fourth Edition, Wiley, Chapter 7. } \author{Sanford Weisberg, \code{sandy@umn.edu}} \examples{ m2 <- lm(rate ~ log(len) + log(adt) + slim + shld + log(sigs1), Highway1) invResPlot(m2) } \keyword{ hplot }% at least one, from doc/KEYWORDS \keyword{ regression} car/man/Contrasts.Rd0000644000176000001440000001141514140261763014077 0ustar ripleyusers\name{Contrasts} \alias{Contrasts} \alias{contr.Treatment} \alias{contr.Sum} \alias{contr.Helmert} \title{Functions to Construct Contrasts} \description{ These are substitutes for similarly named functions in the \pkg{stats} package (note the uppercase letter starting the second word in each function name). The only difference is that the contrast functions from the \pkg{car} package produce easier-to-read names for the contrasts when they are used in statistical models. The functions and this documentation are adapted from the \pkg{stats} package. } \usage{ contr.Treatment(n, base = 1, contrasts = TRUE) contr.Sum(n, contrasts = TRUE) contr.Helmert(n, contrasts = TRUE) } \arguments{ \item{n}{a vector of levels for a factor, or the number of levels.} \item{base}{an integer specifying which level is considered the baseline level. Ignored if \code{contrasts} is \code{FALSE}.} \item{contrasts}{a logical indicating whether contrasts should be computed.} } \details{ These functions are used for creating contrast matrices for use in fitting analysis of variance and regression models. The columns of the resulting matrices contain contrasts which can be used for coding a factor with \code{n} levels. The returned value contains the computed contrasts. If the argument \code{contrasts} is \code{FALSE} then a square matrix is returned. Several aspects of these contrast functions are controlled by options set via the \code{options} command: \describe{ \item{\code{decorate.contrasts}}{This option should be set to a 2-element character vector containing the prefix and suffix characters to surround contrast names. If the option is not set, then \code{c("[", "]")} is used. For example, setting \code{options(decorate.contrasts=c(".", ""))} produces contrast names that are separated from factor names by a period. Setting \code{options( decorate.contrasts=c("", ""))} reproduces the behaviour of the R base contrast functions.} \item{\code{decorate.contr.Treatment}}{A character string to be appended to contrast names to signify treatment contrasts; if the option is unset, then \code{"T."} is used.} \item{\code{decorate.contr.Sum}}{Similar to the above, with default \code{"S."}.} \item{\code{decorate.contr.Helmert}}{Similar to the above, with default \code{"H."}.} \item{\code{contr.Sum.show.levels}}{Logical value: if \code{TRUE} (the default if unset), then level names are used for contrasts; if \code{FALSE}, then numbers are used, as in \code{contr.sum} in the \code{base} package.} } Note that there is no replacement for \code{contr.poly} in the \code{base} package (which produces orthogonal-polynomial contrasts) since this function already constructs easy-to-read contrast names. } \value{ A matrix with \code{n} rows and \code{k} columns, with \code{k = n - 1} if \code{contrasts} is \code{TRUE} and \code{k = n} if \code{contrasts} is \code{FALSE}. } \references{ Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. } \author{John Fox \email{jfox@mcmaster.ca}} \seealso{\code{\link{contr.treatment}}, \code{\link{contr.sum}}, \code{\link{contr.helmert}}, \code{\link{contr.poly}} } \examples{ # contr.Treatment vs. contr.treatment in the base package: lm(prestige ~ (income + education)*type, data=Prestige, contrasts=list(type="contr.Treatment")) ## Call: ## lm(formula = prestige ~ (income + education) * type, data = Prestige, ## contrasts = list(type = "contr.Treatment")) ## ## Coefficients: ## (Intercept) income education ## 2.275753 0.003522 1.713275 ## type[T.prof] type[T.wc] income:type[T.prof] ## 15.351896 -33.536652 -0.002903 ## income:type[T.wc] education:type[T.prof] education:type[T.wc] ## -0.002072 1.387809 4.290875 lm(prestige ~ (income + education)*type, data=Prestige, contrasts=list(type="contr.treatment")) ## Call: ## lm(formula = prestige ~ (income + education) * type, data = Prestige, ## contrasts = list(type = "contr.treatment")) ## ## Coefficients: ## (Intercept) income education ## 2.275753 0.003522 1.713275 ## typeprof typewc income:typeprof ## 15.351896 -33.536652 -0.002903 ## income:typewc education:typeprof education:typewc ## -0.002072 1.387809 4.290875 } \keyword{models} \keyword{regression} car/man/hccm.Rd0000644000176000001440000001043214140261763013027 0ustar ripleyusers%------------------------------------------------------------------------------- % Revision history: % checked in 2008-12-29 by J. Fox (corresponds to version 1.2-10 of car) % 2009-09-16: added argument singular.ok to lm method. J. Fox % 2012-04-04: weighted lm now allowed. John % 2015-07-13: removed URL causing note in R CMD check. John % 2015-08-05: fixed typo. John %------------------------------------------------------------------------------- \name{hccm} \alias{hccm} \alias{hccm.lm} \alias{hccm.default} \title{Heteroscedasticity-Corrected Covariance Matrices} \description{ Calculates heteroscedasticity-corrected covariance matrices linear models fit by least squares or weighted least squares. These are also called \dQuote{White-corrected} or \dQuote{White-Huber} covariance matrices. } \usage{ hccm(model, ...) \method{hccm}{lm}(model, type=c("hc3", "hc0", "hc1", "hc2", "hc4"), singular.ok=TRUE, ...) \method{hccm}{default}(model, ...) } \arguments{ \item{model}{a unweighted or weighted linear model, produced by \code{lm}.} \item{type}{one of \code{"hc0"}, \code{"hc1"}, \code{"hc2"}, \code{"hc3"}, or \code{"hc4"}; the first of these gives the classic White correction. The \code{"hc1"}, \code{"hc2"}, and \code{"hc3"} corrections are described in Long and Ervin (2000); \code{"hc4"} is described in Cribari-Neto (2004).} \item{singular.ok}{if \code{FALSE} (the default is \code{TRUE}), a model with aliased coefficients produces an error; otherwise, the aliased coefficients are ignored in the coefficient covariance matrix that's returned.} \item{...}{arguments to pass to \code{hccm.lm}.} } \details{ The original White-corrected coefficient covariance matrix (\code{"hc0"}) for an unweighted model is \deqn{V(b)=(X^{\prime }X)^{-1}X^{\prime }diag(e_{i}^{2})X(X^{\prime }X)^{-1}}{V(b) = inv(X'X) X' diag(e^2) X inv(X'X)} where \eqn{e_{i}^{2}}{e^2} are the squared residuals, and \eqn{X} is the model matrix. The other methods represent adjustments to this formula. If there are weights, these are incorporated in the corrected covariance matrix. The function \code{hccm.default} simply catches non-\code{lm} objects. See Freedman (2006) and Fox and Weisberg(2019, Sec. 5.1.2) for discussion of the use of these methods in generalized linear models or models with nonconstant variance. } \value{ The heteroscedasticity-corrected covariance matrix for the model. } \references{ Cribari-Neto, F. (2004) Asymptotic inference under heteroskedasticity of unknown form. \emph{Computational Statistics and Data Analysis} \bold{45}, 215--233. Fox, J. (2016) \emph{Applied Regression Analysis and Generalized Linear Models}, Third Edition. Sage. Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. Freedman, D. (2006) On the so-called "Huber sandwich estimator" and "robust standard errors", \emph{American Statistician}, \bold{60}, 299--302. Long, J. S. and Ervin, L. H. (2000) Using heteroscedasity consistent standard errors in the linear regression model. \emph{The American Statistician} \bold{54}, 217--224. White, H. (1980) A heteroskedastic consistent covariance matrix estimator and a direct test of heteroskedasticity. \emph{Econometrica} \bold{48}, 817--838. } \author{John Fox \email{jfox@mcmaster.ca}} \examples{ options(digits=4) mod<-lm(interlocks~assets+nation, data=Ornstein) vcov(mod) ## (Intercept) assets nationOTH nationUK nationUS ## (Intercept) 1.079e+00 -1.588e-05 -1.037e+00 -1.057e+00 -1.032e+00 ## assets -1.588e-05 1.642e-09 1.155e-05 1.362e-05 1.109e-05 ## nationOTH -1.037e+00 1.155e-05 7.019e+00 1.021e+00 1.003e+00 ## nationUK -1.057e+00 1.362e-05 1.021e+00 7.405e+00 1.017e+00 ## nationUS -1.032e+00 1.109e-05 1.003e+00 1.017e+00 2.128e+00 hccm(mod) ## (Intercept) assets nationOTH nationUK nationUS ## (Intercept) 1.664e+00 -3.957e-05 -1.569e+00 -1.611e+00 -1.572e+00 ## assets -3.957e-05 6.752e-09 2.275e-05 3.051e-05 2.231e-05 ## nationOTH -1.569e+00 2.275e-05 8.209e+00 1.539e+00 1.520e+00 ## nationUK -1.611e+00 3.051e-05 1.539e+00 4.476e+00 1.543e+00 ## nationUS -1.572e+00 2.231e-05 1.520e+00 1.543e+00 1.946e+00 } \keyword{regression} car/man/some.Rd0000644000176000001440000000224514140261763013063 0ustar ripleyusers\name{some} \alias{some} \alias{some.data.frame} \alias{some.matrix} \alias{some.default} \title{Sample a Few Elements of an Object} \description{ Randomly select a few elements of an object, typically a data frame, matrix, vector, or list. If the object is a data frame or a matrix, then rows are sampled. } \usage{ some(x, ...) \method{some}{data.frame}(x, n=10, cols=NULL, ...) \method{some}{matrix}(x, n=10, cols=NULL, ...) \method{some}{default}(x, n=10, ...) } \arguments{ \item{x}{the object to be sampled.} \item{n}{number of elements to sample.} \item{cols}{if \code{NULL}, use all columns, if a vector of column names or numbers, use only the columns indicated} \item{\dots}{arguments passed down.} } \value{ Sampled elements or rows. } \author{John Fox \email{jfox@mcmaster.ca}} \references{ Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. } \note{These functions are adapted from \code{head} and \code{tail} in the \code{utils} package. } \seealso{\code{\link{head}}, \code{\link{tail}}, \code{\link{brief}}.} \examples{ some(Duncan) some(Duncan, cols=names(Duncan)[1:3]) } \keyword{utilities} car/man/car-internal.Rd0000644000176000001440000000047614140261763014503 0ustar ripleyusers\name{car-internal.Rd} \alias{car-internal.Rd} \alias{.carEnv} \title{ Internal Objects for the \pkg{car} package } \description{ These objects (currently only the \code{.carEnv} environment) are exported for technical reasons and are not for direct use. } \author{John Fox \email{jfox@mcmaster.ca}} \keyword{misc} car/man/brief.Rd0000644000176000001440000001352214140261763013207 0ustar ripleyusers\name{brief} \alias{brief} \alias{brief.data.frame} \alias{brief.tbl} \alias{brief.matrix} \alias{brief.numeric} \alias{brief.integer} \alias{brief.character} \alias{brief.factor} \alias{brief.function} \alias{brief.list} \alias{brief.lm} \alias{brief.glm} \alias{brief.multinom} \alias{brief.polr} \alias{brief.default} \title{ Print Abbreviated Ouput } \description{ Print data objects and statistical model summaries in abbreviated form. } \usage{ brief(object, ...) \method{brief}{data.frame}(object, rows = if (nr <= 10) c(nr, 0) else c(3, 2), cols, head=FALSE, tail=FALSE, elided = TRUE, classes = inherits(object, "data.frame"), ...) \method{brief}{tbl}(object, ...) \method{brief}{matrix}(object, rows = if (nr <= 10) c(nr, 0) else c(3, 2), ...) \method{brief}{numeric}(object, rows = c(2, 1), elided = TRUE, ...) \method{brief}{integer}(object, rows = c(2, 1), elided = TRUE, ...) \method{brief}{character}(object, rows = c(2, 1), elided = TRUE, ...) \method{brief}{factor}(object, rows=c(2, 1), elided=TRUE, ...) \method{brief}{list}(object, rows = c(2, 1), elided = TRUE, ...) \method{brief}{function}(object, rows = c(5, 3), elided = TRUE, ...) \method{brief}{lm}(object, terms = ~ ., intercept=missing(terms), pvalues=FALSE, digits=3, horizontal=TRUE, vcov., ...) \method{brief}{glm}(object, terms = ~ ., intercept=missing(terms), pvalues=FALSE, digits=3, horizontal=TRUE, vcov., dispersion, exponentiate, ...) \method{brief}{multinom}(object, terms = ~ ., intercept=missing(terms), pvalues=FALSE, digits=3, horizontal=TRUE, exponentiate=TRUE, ...) \method{brief}{polr}(object, terms = ~ ., intercept, pvalues=FALSE, digits=3, horizontal=TRUE, exponentiate=TRUE, ...) \method{brief}{default}(object, terms = ~ ., intercept=missing(terms), pvalues=FALSE, digits=3, horizontal=TRUE, ...) } \arguments{ \item{object}{a data or model object to abbreviate.} \item{rows}{for a matrix or data frame, a 2-element integer vector with the number of rows to print at the beginning and end of the display; for a vector or factor, the number of lines of output to show at the beginning and end; for a list, the number of elements to show at the beginning and end; for a function, the number of lines to show at the beginning and end.} \item{cols}{for a matrix or data frame, a 2-element integer vector with the number of columns to print at the beginning (i.e., left) and end (right) of the display.} \item{head, tail}{alternatives to the \code{rows} argument; if \code{TRUE}, print the first or last 6 rows; can also be the number of the first or last few rows to print; only one of \code{heads} and \code{tails} should be specified; ignored if \code{FALSE} (the default).} \item{elided}{controls whether to report the number of elided elements, rows, or columns; default is \code{TRUE}.} \item{classes}{show the class of each column of a data frame at the top of the column; the classes are shown in single-character abbreviated form---e.g., \code{[f]} for a factor, \code{[i]} for an integer variable, \code{[n]} for a numeric variable, \code{[c]} for a character variable.} \item{terms}{a one-sided formula giving the terms to summarize; the default is \code{~ .}---i.e., to summarize all terms in the model.} \item{intercept}{whether or not to include the intercept; the default is \code{TRUE} unless the \code{terms} argument is given, in which case the default is \code{FALSE}; ignored for \code{polr} models.} \item{pvalues}{include the p-value for each coefficient in the table; default is \code{FALSE}.} \item{exponentiate}{for a \code{"glm"} or \code{"glmerMod"} model using the \code{log} or \code{logit} link, or a \code{"polr"} or \code{"multinom"} model, show exponentiated coefficient estimates and confidence bounds.} \item{digits}{significant digits for printing.} \item{horizontal}{if \code{TRUE} (the default), orient the summary produced by \code{brief} horizontally, which typically saves space.} \item{dispersion}{use an estimated covariance matrix computed as the dispersion times the unscaled covariance matrix; see \code{\link{summary.glm}}} \item{vcov.}{either a matrix giving the estimated covariance matrix of the estimates, or a function that when called with \code{object} as an argument returns an estimated covariance matrix of the estimates. If not set, \code{vcov(object, complete=FALSE)} is called to use the usual estimated covariance matrix with aliased regressors removed. Other choices include the functions documented at \code{\link{hccm}}, and a bootstrap estimate \code{vcov.=vcov(Boot(object))}; see the documentation for \code{\link{Boot}}. NOTES: (1) The \code{dispersion} and \code{vcov.} arguments may not \emph{both} be specified. (2) Setting \code{vcov.=vcov} returns an error if the model includes aliased terms; use \code{vcov.=vcov(object, complete=FALSE)}. (3) The \code{hccm} method will generally return a matrix of full rank even if the model has aliased terms. Similarly \code{vcov.=vcov(Boot(object))} may return a full rank matrix. } \item{\dots}{arguments to pass down.} } \value{ Invisibly returns \code{object} for a data object, or summary for a model object. } \note{ The method \code{brief.matrix} calls \code{brief.data.frame}, and \code{brief.tbl} (for tibbles) calls \code{print}. } \references{ Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. } \author{ John Fox \email{jfox@mcmaster.ca} } \seealso{\code{\link{S}}} \examples{ brief(rnorm(100)) brief(Duncan) brief(OBrienKaiser, elided=TRUE) brief(matrix(1:500, 10, 50)) brief(lm) mod.prestige <- lm(prestige ~ education + income + type, Prestige) brief(mod.prestige, pvalues=TRUE) brief(mod.prestige, ~ type) mod.mroz <- glm(lfp ~ ., data=Mroz, family=binomial) brief(mod.mroz) } \keyword{manip} car/man/ncvTest.Rd0000644000176000001440000000410614140261763013544 0ustar ripleyusers\name{ncvTest} \alias{ncvTest} \alias{ncvTest.lm} \alias{ncvTest.glm} \title{Score Test for Non-Constant Error Variance} \description{ Computes a score test of the hypothesis of constant error variance against the alternative that the error variance changes with the level of the response (fitted values), or with a linear combination of predictors. } \usage{ ncvTest(model, ...) \method{ncvTest}{lm}(model, var.formula, ...) \method{ncvTest}{glm}(model, ...) # to report an error } \arguments{ \item{model}{a weighted or unweighted linear model, produced by \code{lm}.} \item{var.formula}{a one-sided formula for the error variance; if omitted, the error variance depends on the fitted values.} \item{\dots}{arguments passed down to methods functions; not currently used.} } \details{ This test is often called the Breusch-Pagan test; it was independently suggested with some extension by Cook and Weisberg (1983). \code{ncvTest.glm} is a dummy function to generate an error when a \code{glm} model is used. } \value{ The function returns a \code{chisqTest} object, which is usually just printed. } \references{ Breusch, T. S. and Pagan, A. R. (1979) A simple test for heteroscedasticity and random coefficient variation. \emph{Econometrica} \bold{47}, 1287--1294. Cook, R. D. and Weisberg, S. (1983) Diagnostics for heteroscedasticity in regression. \emph{Biometrika} \bold{70}, 1--10. Fox, J. (2016) \emph{Applied Regression Analysis and Generalized Linear Models}, Third Edition. Sage. Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. Weisberg, S. (2014) \emph{Applied Linear Regression}, Fourth Edition, Wiley. } \author{John Fox \email{jfox@mcmaster.ca}, Sandy Weisberg \email{sandy@umn.edu}} \seealso{\code{\link{hccm}}, \code{\link{spreadLevelPlot}} } \examples{ ncvTest(lm(interlocks ~ assets + sector + nation, data=Ornstein)) ncvTest(lm(interlocks ~ assets + sector + nation, data=Ornstein), ~ assets + sector + nation, data=Ornstein) } \keyword{htest} \keyword{regression} car/man/mcPlots.Rd0000644000176000001440000002025114140261763013536 0ustar ripleyusers\name{mcPlots} \alias{mcPlots} \alias{mcPlots.default} \alias{mcPlot} \alias{mcPlot.lm} \alias{mcPlot.glm} \title{Draw Linear Model Marginal and Conditional Plots in Parallel or Overlaid} \description{ the \code{mcPlot} function draws two graphs or overlays the two graphs. For a response Y and a regressor X, the first plot is the \emph{m}arginal plot of Y versus X with both variables centered, visualizing the conditional distribution of Y given X ignoring all other regressors. The second plot is an added-variable for X after all other regressors, visualizing the \emph{c}onditional distribution of Y given X after adjusting for all other predictors. The added variable plot by default is drawn using the same xlim and ylim as the centered marginal plot to emphasize that conditioning removes variation in both the regressor and the response.The plot is primarily intended as a pedagogical tool for understanding coefficients in first-order models. } \usage{ mcPlots(model, ...) \method{mcPlots}{default}(model, terms=~., layout=NULL, ask, overlaid=TRUE, ...) mcPlot(model, ...) \method{mcPlot}{lm}(model, variable, id=FALSE, col.marginal=carPalette()[2], col.conditional=carPalette()[3], col.arrows="gray", pch = c(16,1), cex=par("cex"), pt.wts=FALSE, lwd = 2, grid=TRUE, ellipse=FALSE, overlaid=TRUE, new=TRUE, title=TRUE, ...) \method{mcPlot}{glm}(model, ...) } \arguments{ \item{model}{model object produced by \code{lm}; the \code{"glm"} method just reports an error.} \item{terms}{ A one-sided formula that specifies a subset of the predictors. One added-variable plot is drawn for each regressor and for each basis vector used to define a factor. For example, the specification \code{terms = ~ . - X3} would plot against all terms except for \code{X3}. If this argument is a quoted name of one of the regressors or factors, the added-variable plot is drawn for that regressor or factor only. Unlike other car functions, the formula should include the names of regressors, not predictors. That is, if \code{log(X4)} is used to represent a predictor \code{X4}, the formula should specify \code{terms = ~ log(X4)}. } \item{variable}{A quoted string giving the name of a numeric predictor in the model matrix for the horizontal axis. To plot against a factor, you need to specify the full name of one of the indicator variables that define the factor. For example, for a factor called \code{type} with levels \code{A}, \code{B} and {C}, using the usual drop-first level parameterization of the factor, the regressors for \code{type} would be \code{typeB} or \code{typeC}. Similarly, to plot against the regressor \code{log(X4)}, you must specify \code{"log((X4)"}, not \code{"X4"}. } \item{layout}{ If set to a value like \code{c(1, 2)} or \code{c(6, 2)}, the layout of the graph will have this many rows and columns. If not set, behavior depends on the value of the \code{overlaid} argument; see the details } \item{ask}{If \code{TRUE}, ask the user before drawing the next plot; if \code{FALSE} don't ask. } \item{\dots}{\code{mcPlots} passes these arguments to \code{mcPlot}. \code{mcPlot} passes arguments to \code{plot}. } \item{id}{controls point identification; if \code{FALSE} (the default), no points are identified; can be a list of named arguments to the \code{\link{showLabels}} function; \code{TRUE} is equivalent to \code{list(method=list(abs(residuals(model, type="pearson")), "x"), n=2, cex=1, col=carPalette()[1], location="lr")}, which identifies the 2 points with the largest residuals and the 2 points with the most extreme horizontal (X) values.} \item{overlaid}{If TRUE, the default, overlay the marginal and conditional plots on the same graph; otherwise plot them side-by-side. See the details below} \item{col.marginal, col.conditional}{colors for points, lines, ellipses in the marginal and conditional plots, respectively. The defaults are determined by the \code{\link{carPalette}} function.} \item{col.arrows}{color for the arrows with \code{overlaid=TRUE}} \item{pch}{Plotting character for marginal and conditional plots, respectively.} \item{cex}{size of plotted points; default is taken from \code{par("cex")}.} \item{pt.wts}{if \code{TRUE} (the default is \code{FALSE}), the areas of plotted points for a weighted least squares fit are made proportional to the weights, with the average size taken from the \code{cex} argument.} \item{lwd}{line width; default is \code{2} (see \code{\link{par}}).} \item{grid}{If \code{TRUE}, the default, a light-gray background grid is put on the graph.} \item{ellipse}{Arguments to pass to the \code{\link{dataEllipse}} function, in the form of a list with named elements; e.g., \code{ellipse.args=list(robust=TRUE))} will cause the ellipse to be plotted using a robust covariance-matrix. if \code{FALSE}, the default, no ellipse is plotted. \code{TRUE} is equivalent to \code{ellipse=list(levels=0.5)}, which plots a bivariate-normal 50 percent concentration ellipse.} \item{new}{if \code{TRUE}, the default, the plot window is reset when \code{overlaid=FALSE} using \code{par{mfrow=c(1, 2)}}. If \code{FALSE}, the layout of the plot window is not reset. Users will ordinarily ignore this argument.} \item{title}{If TRUE, the default, the standard main argument in plot is used to add a standard title to each plot. If FALSE no title is used.} } \details{ With an \code{lm} object, suppose the response is Y, X is a numeric regressor of interest, and Z is all the remaining predictors, possibly including interactions and factors. This function produces two graphs. The first graph is the marginal plot of Y versus X, with each variable centered around its mean. The second conditional plot is the added-variable plot of e(Y|Z) versus e(X|Z) where e(a|b) means the Pearson residuals from the regression of a on b. If \code{overlaid=TRUE}, these two plots are overlaid in one graph, with the points in different colors. In addition, each point in the marginal plot is joined to its value in the conditional plot by an arrow. Least squares regression lines fit to the marginal and conditional graphs are also shown; data ellipsoids can also be added. If \code{overlaid=FALSE}, then the two graphs are shown in side-by-side plots as long as the second argument to \code{layout} is equal to \code{2}, or \code{layout} is set by the function. The arrows are omitted if the graphs are not overlaid. These graphs are primarily for teaching, as the marginal plot shows the relationship between Y and X ignoring Z, while the conditional is the relationship between Y and X given X. By keeping the scales the same in both graphs the effect of conditioning on both X and Y can be visualized. This function is intended for first-order models with numeric predictors only. For a factor, one (pair) of mcPlots will be produced for each of the dummy variables in the basis for the factor, and the resulting plots are not generally meaningful because they depend on parameterization. If the mean function includes interactions, then mcPlots for main effects may violate the hierarchy principle, and may also be of little interest. mcPlots for interactions of numerical predictors, however, can be useful. These graphs are closely related to the ARES plots proposed by Cook and Weisberg (1989). This plot would benefit from animation. } \value{ These functions are used for their side effect of producing plots. } \references{ Cook, R. D. and Weisberg, S. (1989) \emph{Regression diagnostics with dynamic graphics,} Technometrics, 31, 277. Fox, J. (2016) \emph{Applied Regression Analysis and Generalized Linear Models}, Third Edition. Sage. Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. Weisberg, S. (2014) \emph{Applied Linear Regression}, Fourth Edition, Wiley. } \author{John Fox \email{jfox@mcmaster.ca}, Sanford Weisberg \email{sandy@umn.edu}} \seealso{\code{\link{avPlots}}, \code{\link{residualPlots}}, \code{\link{crPlots}}, \code{\link{ceresPlots}}, \code{\link{dataEllipse}} } \examples{ m1 <- lm(partic ~ tfr + menwage + womwage + debt + parttime, data = Bfox) mcPlot(m1, "womwage") mcPlot(m1, "womwage", overlaid=FALSE, ellipse=TRUE) } \keyword{hplot} \keyword{regression} car/man/scatter3d.Rd0000644000176000001440000002611214140261763014013 0ustar ripleyusers\name{scatter3d} \alias{scatter3d} \alias{scatter3d.formula} \alias{scatter3d.default} \alias{Identify3d} \title{Three-Dimensional Scatterplots and Point Identification} \description{ The \code{scatter3d} function uses the \code{rgl} package to draw 3D scatterplots with various regression surfaces. The function \code{Identify3d} allows you to label points interactively with the mouse: Press the right mouse button (on a two-button mouse) or the centre button (on a three-button mouse), drag a rectangle around the points to be identified, and release the button. Repeat this procedure for each point or set of \dQuote{nearby} points to be identified. To exit from point-identification mode, click the right (or centre) button in an empty region of the plot. } \usage{ scatter3d(x, ...) \method{scatter3d}{formula}(formula, data, subset, radius, xlab, ylab, zlab, id=FALSE, ...) \method{scatter3d}{default}(x, y, z, xlab=deparse(substitute(x)), ylab=deparse(substitute(y)), zlab=deparse(substitute(z)), axis.scales=TRUE, axis.ticks=FALSE, revolutions=0, bg.col=c("white", "black"), axis.col=if (bg.col == "white") c("darkmagenta", "black", "darkcyan") else c("darkmagenta", "white", "darkcyan"), surface.col=carPalette()[-1], surface.alpha=0.5, neg.res.col="magenta", pos.res.col="cyan", square.col=if (bg.col == "white") "black" else "gray", point.col="yellow", text.col=axis.col, grid.col=if (bg.col == "white") "black" else "gray", fogtype=c("exp2", "linear", "exp", "none"), residuals=(length(fit) == 1), surface=TRUE, fill=TRUE, grid=TRUE, grid.lines=26, df.smooth=NULL, df.additive=NULL, sphere.size=1, radius=1, threshold=0.01, speed=1, fov=60, fit="linear", groups=NULL, parallel=TRUE, ellipsoid=FALSE, level=0.5, ellipsoid.alpha=0.1, id=FALSE, model.summary=FALSE, ...) Identify3d(x, y, z, axis.scales=TRUE, groups = NULL, labels = 1:length(x), col = c("blue", "green", "orange", "magenta", "cyan", "red", "yellow", "gray"), offset = ((100/length(x))^(1/3)) * 0.02) } \note{ You have to install the \code{rgl} package to produce 3D plots. On a Macintosh (but not on Windows or Linux), you may also need to install the X11 windowing system. Go to \url{https://www.xquartz.org/} and click on the link for XQuartz. Double-click on the downloaded disk-image file, and then double-click on \code{XQuartz.pkg} to start the installer. You may take all of the defaults in the installation. After XQuartz is installed, you should restart your Macintosh. } \arguments{ \item{formula}{``model'' formula, of the form \code{y ~ x + z} or to plot by groups \code{y ~ x + z | g}, where \code{g} evaluates to a factor or other variable dividing the data into groups.} \item{data}{data frame within which to evaluate the formula.} \item{subset}{expression defining a subset of observations.} \item{x}{variable for horizontal axis.} \item{y}{variable for vertical axis (response).} \item{z}{variable for out-of-screen axis.} \item{xlab, ylab, zlab}{axis labels.} \item{axis.scales}{if \code{TRUE}, label the values of the ends of the axes. \emph{Note:} For \code{Identify3d} to work properly, the value of this argument must be the same as in \code{scatter3d}.} \item{axis.ticks}{if \code{TRUE}, print interior axis-``tick'' labels; the default is \code{FALSE}. (The code for this option was provided by David Winsemius.)} \item{revolutions}{number of full revolutions of the display.} \item{bg.col}{background colour; one of \code{"white"}, \code{"black"}.} \item{axis.col}{colours for axes; if \code{axis.scales} is \code{FALSE}, then the second colour is used for all three axes.} \item{surface.col}{vector of colours for regression planes, used in the order specified by \code{fit}; for multi-group plots, the colours are used for the regression surfaces and points in the several groups.} \item{surface.alpha}{transparency of regression surfaces, from \code{0.0} (fully transparent) to \code{1.0} (opaque); default is \code{0.5}.} \item{neg.res.col, pos.res.col}{colours for lines representing negative and positive residuals.} \item{square.col}{colour to use to plot squared residuals.} \item{point.col}{colour of points.} \item{text.col}{colour of axis labels.} \item{grid.col}{colour of grid lines on the regression surface(s).} \item{fogtype}{type of fog effect; one of \code{"exp2"}, \code{"linear"}, \code{"exp"}, \code{"none".}} \item{residuals}{plot residuals if \code{TRUE}; if \code{residuals="squares"}, then the squared residuals are shown as squares (using code adapted from Richard Heiberger). Residuals are available only when there is one surface plotted.} \item{surface}{plot surface(s) (\code{TRUE} or \code{FALSE}).} \item{fill}{fill the plotted surface(s) with colour (\code{TRUE} or \code{FALSE}).} \item{grid}{plot grid lines on the regression surface(s) (\code{TRUE} or \code{FALSE}).} \item{grid.lines}{number of lines (default, 26) forming the grid, in each of the x and z directions.} \item{df.smooth}{degrees of freedom for the two-dimensional smooth regression surface; if \code{NULL} (the default), the \code{\link{gam}} function will select the degrees of freedom for a smoothing spline by generalized cross-validation; if a positive number, a fixed regression spline will be fit with the specified degrees of freedom.} \item{df.additive}{degrees of freedom for each explanatory variable in an additive regression; if \code{NULL} (the default), the \code{gam} function will select degrees of freedom for the smoothing splines by generalized cross-validation; if a positive number or a vector of two positive numbers, fixed regression splines will be fit with the specified degrees of freedom for each term.} \item{sphere.size}{general size of spheres representing points; the actual size is dependent on the number of observations.} \item{radius}{relative radii of the spheres representing the points. This is normally a vector of the same length as the variables giving the coordinates of the points, and for the \code{formula} method, that must be the case or the argument may be omitted, in which case spheres are the same size; for the \code{default} method, the default for the argument, \code{1}, produces spheres all of the same size. The radii are scaled so that their median is 1.} \item{threshold}{if the actual size of the spheres is less than the threshold, points are plotted instead.} \item{speed}{relative speed of revolution of the plot.} \item{fov}{field of view (in degrees); controls degree of perspective.} \item{fit}{one or more of \code{"linear"}, \code{"quadratic"}, \code{"smooth"}, \code{"additive"}; to display fitted surface(s); partial matching is supported -- e.g., \code{c("lin", "quad")}.} \item{groups}{if \code{NULL} (the default), no groups are defined; if a factor, a different surface or set of surfaces is plotted for each level of the factor; in this event, the colours in \code{surface.col} are used successively for the points, surfaces, and residuals corresponding to each level of the factor.} \item{parallel}{when plotting surfaces by \code{groups}, should the surfaces be constrained to be parallel? A logical value, with default \code{TRUE}.} \item{ellipsoid}{plot concentration ellipsoid(s) (\code{TRUE} or \code{FALSE}).} \item{level}{expected proportion of bivariate-normal observations included in the concentration ellipsoid(s); default is 0.5.} \item{ellipsoid.alpha}{transparency of ellipsoids, from \code{0.0} (fully transparent) to \code{1.0} (opaque); default is \code{0.1}.} \item{id}{\code{FALSE}, \code{TRUE}, or a list controlling point identification, similar to \code{\link{showLabels}} for 2D plots (see Details).} \item{model.summary}{print summary or summaries of the model(s) fit (\code{TRUE} or \code{FALSE}). \code{scatter3d} rescales the three variables internally to fit in the unit cube; this rescaling will affect regression coefficients.} \item{labels}{text labels for the points, one for each point; defaults to the observation indices.} \item{col}{colours for the point labels, given by group. There must be at least as many colours as groups; if there are no groups, the first colour is used. Normally, the colours would correspond to the \code{surface.col} argument to \code{scatter3d}.} \item{offset}{vertical displacement for point labels (to avoid overplotting the points).} \item{\dots}{arguments to be passed down.} } \value{ \code{scatter3d} does not return a useful value; it is used for its side-effect of creating a 3D scatterplot. \code{Identify3d} returns the labels of the identified points. } \details{ The \code{id} argument to \code{scatter3d} can be \code{FALSE}, \code{TRUE} (in which case 2 points will be identified according to their Mahalanobis distances from the center of the data), or a list containing any or all of the following elements: \describe{ \item{method}{if \code{"mahal"} (the default), relatively extreme points are identified automatically according to their Mahalanobis distances from the centroid (point of means); if \code{"identify"}, points are identified interactively by right-clicking and dragging a box around them; right-click in an empty area to exit from interactive-point-identification mode; if \code{"xz"}, identify extreme points in the predictor plane; if \code{"y"}, identify unusual values of the response; if \code{"xyz"} identify unusual values of an variable; if \code{"none"}, no point identification. See \code{\link{showLabels}} for more information.} \item{n}{Number of relatively extreme points to identify automatically (default, \code{2}, unless \code{method="identify"}, in which case identification continues until the user exits).} \item{labels}{text labels for the points, one for each point; in the \code{default} method defaults to the observation indices, in the \code{formula} method to the row names of the data.} \item{offset}{vertical displacement for point labels (to avoid overplotting the points).} } } \author{John Fox \email{jfox@mcmaster.ca}} \references{ Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. } \seealso{\code{\link[rgl]{rgl-package}}, \code{\link{gam}}} \examples{ if(interactive() && require(rgl) && require(mgcv)){ scatter3d(prestige ~ income + education, data=Duncan, id=list(n=3)) Sys.sleep(5) # wait 5 seconds scatter3d(prestige ~ income + education | type, data=Duncan) Sys.sleep(5) scatter3d(prestige ~ income + education | type, surface=FALSE, ellipsoid=TRUE, revolutions=3, data=Duncan) scatter3d(prestige ~ income + education, fit=c("linear", "additive"), data=Prestige) Sys.sleep(5) scatter3d(prestige ~ income + education | type, radius=(1 + women)^(1/3), data=Prestige) } \dontrun{ # drag right mouse button to identify points, click right button in open area to exit scatter3d(prestige ~ income + education, data=Duncan, id=list(method="identify")) scatter3d(prestige ~ income + education | type, data=Duncan, id=list(method="identify")) } } \keyword{hplot} car/man/durbinWatsonTest.Rd0000644000176000001440000000373614140261763015445 0ustar ripleyusers\name{durbinWatsonTest} \alias{durbinWatsonTest} \alias{dwt} \alias{durbinWatsonTest.lm} \alias{durbinWatsonTest.default} \alias{print.durbinWatsonTest} \title{Durbin-Watson Test for Autocorrelated Errors} \description{ Computes residual autocorrelations and generalized Durbin-Watson statistics and their bootstrapped p-values. \code{dwt} is an abbreviation for \code{durbinWatsonTest}. } \usage{ durbinWatsonTest(model, ...) dwt(...) \method{durbinWatsonTest}{lm}(model, max.lag=1, simulate=TRUE, reps=1000, method=c("resample","normal"), alternative=c("two.sided", "positive", "negative"), ...) \method{durbinWatsonTest}{default}(model, max.lag=1, ...) \method{print}{durbinWatsonTest}(x, ...) } \arguments{ \item{model}{a linear-model object, or a vector of residuals from a linear model.} \item{max.lag}{maximum lag to which to compute residual autocorrelations and Durbin-Watson statistics.} \item{simulate}{if \code{TRUE} p-values will be estimated by bootstrapping.} \item{reps}{number of bootstrap replications.} \item{method}{bootstrap method: \code{"resample"} to resample from the observed residuals; \code{"normal"} to sample normally distributed errors with 0 mean and standard deviation equal to the standard error of the regression.} \item{alternative}{sign of autocorrelation in alternative hypothesis; specify only if \code{max.lag = 1}; if \code{max.lag > 1}, then \code{alternative} is taken to be \code{"two.sided"}.} \item{\dots}{arguments to be passed down.} \item{x}{\code{durbinWatsonTest} object.} } \value{ Returns an object of type \code{"durbinWatsonTest"}. } \note{ p-values are available only from the \code{lm} method. } \references{ Fox, J. (2016) \emph{Applied Regression Analysis and Generalized Linear Models}, Third Edition. Sage. } \author{John Fox \email{jfox@mcmaster.ca}} \examples{ durbinWatsonTest(lm(fconvict ~ tfr + partic + degrees + mconvict, data=Hartnagel)) } \keyword{regression} \keyword{ts} car/man/scatterplotMatrix.Rd0000644000176000001440000002575614140261763015665 0ustar ripleyusers\name{scatterplotMatrix} \alias{scatterplotMatrix} \alias{scatterplotMatrix.formula} \alias{scatterplotMatrix.default} \alias{spm} \title{Scatterplot Matrices} \description{ This function provides a convenient interface to the \code{pairs} function to produce enhanced scatterplot matrices, including univariate displays on the diagonal and a variety of fitted lines, smoothers, variance functions, and concentration ellipsoids. \code{spm} is an abbreviation for \code{scatterplotMatrix}. } \usage{ scatterplotMatrix(x, ...) \method{scatterplotMatrix}{formula}(formula, data=NULL, subset, ...) \method{scatterplotMatrix}{default}(x, smooth = TRUE, id = FALSE, legend = TRUE, regLine = TRUE, ellipse = FALSE, var.labels = colnames(x), diagonal = TRUE, plot.points = TRUE, groups = NULL, by.groups = TRUE, use = c("complete.obs", "pairwise.complete.obs"), col = carPalette()[-1], pch = 1:n.groups, cex = par("cex"), cex.axis = par("cex.axis"), cex.labels = NULL, cex.main = par("cex.main"), row1attop = TRUE, ...) spm(x, ...) } \arguments{ \item{x}{a data matrix or a numeric data frame.} \item{formula}{a one-sided \dQuote{model} formula, of the form \code{ ~ x1 + x2 + ... + xk} or \code{ ~ x1 + x2 + ... + xk | z} where \code{z} evaluates to a factor or other variable to divide the data into groups.} \item{data}{for \code{scatterplotMatrix.formula}, a data frame within which to evaluate the formula.} \item{subset}{expression defining a subset of observations.} \item{smooth}{specifies a nonparametric estimate of the mean or median function of the vertical axis variable given the horizontal axis variable and optionally a nonparametric estimate of the spread or variance function. If \code{smooth=FALSE} neither function is drawn. If \code{smooth=TRUE}, then both the mean function and variance funtions are drawn for ungrouped data, and the mean function only is drawn for grouped data. The default smoother is \code{\link{loessLine}}, which uses the \code{\link{loess}} function from the \code{stats} package. This smoother is fast and reliable. See the details below for changing the smoother, line type, width and color, of the added lines, and adding arguments for the smoother.} \item{id}{controls point identification; if \code{FALSE} (the default), no points are identified; can be a list of named arguments to the \code{\link{showLabels}} function; \code{TRUE} is equivalent to \code{list(method="mahal", n=2, cex=1, location="lr")}, which identifies the 2 points (in each group, if \code{by.groups=TRUE}) with the largest Mahalanobis distances from the center of the data; \code{list(method="identify")} for interactive point identification is not allowed.} \item{legend}{controls placement of a legend if the plot is drawn by groups; if \code{FALSE}, the legend is suppressed. Can be a list with the named element\code{coords} specifying the position of the legend in any form acceptable to the \code{\link{legend}} function; \code{TRUE} (the default) is equivalent to \code{list(coords=NULL)}, for which placement will vary by the the value of the \code{diagonal} argument---e.g., \code{"topright"} for \code{diagonal=TRUE}.} \item{regLine}{controls adding a fitted regression line to each plot, or to each group of points if \code{by.groups=TRUE}. If \code{regLine=FALSE}, no line is drawn. This argument can also be a list with named list, with default \code{regLine=TRUE} equivalent to \code{regLine = list(method=lm, lty=1, lwd=2, col=col[1])} specifying the name of the function that computes the line, with line type 1 (solid) of relative line width 2 and the color equal to the first value in the argument \code{col}. Setting \code{method=MASS::rlm} would fit using a robust regression.} \item{ellipse}{controls plotting data-concentration ellipses. If \code{FALSE} (the default), no ellipses are plotted. Can be a list of named values giving \code{levels}, a vector of one or more bivariate-normal probability-contour levels at which to plot the ellipses; \code{robust}, a logical value determing whether to use the \code{\link{cov.trob}} function in the \pkg{MASS} package to calculate the center and covariance matrix for the data ellipses; and \code{fill} and \code{fill.alpha}, which control whether the ellipse is filled and the transparency of the fill. \code{TRUE} is equivalent to \code{list(levels=c(.5, .95), robust=TRUE, fill=TRUE, fill.alpha=0.2)}.} \item{var.labels}{variable labels (for the diagonal of the plot).} \item{diagonal}{contents of the diagonal panels of the plot. If \code{diagonal=TRUE} adaptive kernel density estimates are plotted, separately for each group if grouping is present. \code{diagonal=FALSE} suppresses the diagonal entries. See details below for other choices for the diagonal.} \item{plot.points}{if \code{TRUE} the points are plotted in each off-diagonal panel.} \item{groups}{a factor or other variable dividing the data into groups; groups are plotted with different colors and plotting characters.} \item{by.groups}{if \code{TRUE}, the default, regression lines and smooths are fit by groups.} \item{use}{if \code{"complete.obs"} (the default), cases with missing data are omitted; if \code{"pairwise.complete.obs"), all valid cases are used in each panel of the plot.}} \item{pch}{plotting characters for points; default is the plotting characters in order (see \code{\link{par}}).} \item{col}{colors for points; the default is \code{\link{carPalette}} starting at the second color. The color of the \code{regLine} and \code{smooth} are the same as for points but can be changed using the the \code{regLine} and \code{smooth} arguments.} \item{cex}{relative size of plotted points} \item{cex.axis}{relative size of axis labels} \item{cex.labels}{relative size of labels on the diagonal} \item{cex.main}{relative size of the main title, if any} \item{row1attop}{If \code{TRUE} (the default) the first row is at the top, as in a matrix, as opposed to at the bottom, as in graph (argument suggested by Richard Heiberger).} \item{...}{arguments to pass down.} } \details{ Many arguments to \code{scatterplotMatrix} were changed in version 3 of \pkg{car}, to simplify use of this function. The \code{smooth} argument is usually either set to \code{TRUE} or \code{FALSE} to draw, or omit, the smoother. Alternatively \code{smooth} can be set to a list of arguments. The default behavior of \code{smooth=TRUE} is equivalent to \code{smooth=list(smoother=loessLine, spread=TRUE, lty.smooth=1, lwd.smooth=1.5, lty.spread=3, lwd.spread=1)}, specifying the smoother to be used, including the spread or variance smooth, and the line widths and types for the curves. You can also specify the colors you want to use for the mean and variance smooths with the arguments \code{col.smooth} and \code{col.spread}. Alternative smoothers are \code{gamline} which uses the \code{\link{gam}} function from the \pkg{mgcv} package, and \code{quantregLine} which uses quantile regression to estimate the median and quartile functions using \code{\link{rqss}} from the \pkg{quantreg} package. All of these smoothers have one or more arguments described on their help pages, and these arguments can be added to the \code{smooth} argument; for example, \code{smooth = list(span=1/2)} would use the default \code{loessLine} smoother, include the variance smooth, and change the value of the smoothing parameter to 1/2. For \code{loessLine} and \code{gamLine} the variance smooth is estimated by separately smoothing the squared positive and negative residuals from the mean smooth, using the same type of smoother. The displayed curves are equal to the mean smooth plus the square root of the fit to the positive squared residuals, and the mean fit minus the square root of the smooth of the negative squared residuals. The lines therefore represent the comnditional variabiliity at each value on the horizontal axis. Because smoothing is done separately for positive and negative residuals, the variation shown will generally not be symmetric about the fitted mean function. For the \code{quantregLine} method, the center estimates the median for each value on the horizontal axis, and the spread estimates the lower and upper quartiles of the estimated conditional distribution for each value of the horizontal axis. The sub-arguments \code{spread}, \code{lty.spread} and \code{col.spread} of the \code{smooth} argument are equivalent to the newer \code{var}, \code{col.var} and \code{lty.var}, respectively, recognizing that the spread is a measuure of conditional variability. By default the diagonal argument is used to draw kernel density estimates of the variables by setting \code{diagonal=TRUE}, which is equivalent to setting \code{diagonal = list(method="adaptiveDensity", bw=bw.nrd0, adjust=1, kernel=dnorm, na.rm=TRUE)}. The additional arguments shown are descibed at \code{\link{adaptiveKernel}}. The other methods avaliable, with their default arguments, are \code{diagonal=list(method="density", bw="nrd0", adjust=1, kernel="gaussian", na.rm=TRUE)} which uses \code{\link{density}} for nonadaptive kernel density estimation; \code{diagonal=list(method ="histogram", breaks="FD")} which uses \code{\link{hist}} for drawing a histogram that ignores grouping, if present; \code{diagonal=list(method="boxplot")} with no additional arguments which draws (parallel) boxplots; \code{diagonal=list(method="qqplot")} with no additional arguments which draws a normal QQ plot; and \code{diagonal=list(method="oned")} with no additional arguments which draws a rug plot tilted to the diagonal, as suggested by Richard Heiberger. Earlier versions of \code{scatterplotMatrix} included arguments \code{transform} and \code{family} to estimate power transformations using the \code{\link{powerTransform}} function before drawing the plot. The same functionality can be achieved by calling \code{powerTransform} directly to estimate a transformation, saving the transformed variables, and then plotting. } \value{ \code{NULL}, returned invisibly. This function is used for its side effect: producing a plot. If point identification is used, a vector of identified points is returned. } \author{John Fox \email{jfox@mcmaster.ca}} \references{ Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. } \seealso{\code{\link{pairs}}, \code{\link{scatterplot}}, \code{\link{dataEllipse}}, \code{\link{powerTransform}}, \code{\link{bcPower}}, \code{\link{yjPower}}, \code{\link{cov.trob}}, \code{\link{showLabels}}, \code{\link{ScatterplotSmoothers}}.} \examples{ scatterplotMatrix(~ income + education + prestige | type, data=Duncan) scatterplotMatrix(~ income + education + prestige | type, data=Duncan, regLine=FALSE, smooth=list(span=1)) scatterplotMatrix(~ income + education + prestige, data=Duncan, id=TRUE, smooth=list(method=gamLine)) } \keyword{hplot} car/man/poTest.Rd0000644000176000001440000000227014140261763013374 0ustar ripleyusers\name{poTest} \alias{poTest} \alias{poTest.polr} \alias{print.poTest} \title{Test for Proportional Odds in the Proportional-Odds Logistic-Regression Model} \description{ The \code{poTest} function implements tests proposed by Brant (1990) for proportional odds for logistic models fit by the \code{\link{polr}} function in the MASS package. } \usage{ poTest(model, ...) \method{poTest}{polr}(model, ...) \method{print}{poTest}(x, digits=3, ...) } \arguments{ \item{model}{a proptional-odds logit model fit by \code{\link{polr}}.} \item{x}{an object produced by \code{poTest}.} \item{digits}{number of significant digits to print.} \item{\dots}{ignored.} } \value{ \code{poTest} returns an object meant to be printed showing the results of the tests. } \references{ R. Brant, "Assessing proportionality in the proportional odds model for ordinal logistic regression." Biometrics 46: 1171--1178, 1990. } \author{ John Fox \email{jfox@mcmaster.ca} } \examples{ if (require("MASS")){ .W <- Womenlf .W$partic <- factor(.W$partic, levels=c("not.work", "parttime", "fulltime")) poTest(polr(partic ~ hincome + children + region, data=.W)) } } \keyword{models} \keyword{htest} car/man/hist.boot.Rd0000644000176000001440000001711614140261763014034 0ustar ripleyusers\name{hist.boot} \alias{hist.boot} \alias{summary.boot} \alias{confint.boot} \alias{vcov.boot} \alias{Confint.boot} \title{ Methods Functions to Support \code{boot} Objects } \description{ The \code{Boot} function in the \pkg{car} package uses the \code{\link{boot}} function from the \pkg{boot} package to do a straightforward case or residual bootstrap for many regression objects. These are method functions for standard generics to summarize the results of the bootstrap. Other tools for this purpose are available in the \code{boot} package. } \usage{ \method{hist}{boot}(x, parm, layout = NULL, ask, main = "", freq = FALSE, estPoint = TRUE, point.col = carPalette()[1], point.lty = 2, point.lwd = 2, estDensity = !freq, den.col = carPalette()[2], den.lty = 1, den.lwd = 2, estNormal = !freq, nor.col = carPalette()[3], nor.lty = 2, nor.lwd = 2, ci = c("bca", "none", "perc", "norm"), level = 0.95, legend = c("top", "none", "separate"), box = TRUE, ...) \method{summary}{boot}(object, parm, high.moments = FALSE, extremes = FALSE, ...) \method{confint}{boot}(object, parm, level = 0.95, type = c("bca", "norm", "basic", "perc"), ...) \method{Confint}{boot}(object, parm, level = 0.95, type = c("bca", "norm", "basic", "perc"), ...) \method{vcov}{boot}(object, use="complete.obs", ...) } \arguments{ \item{x, object}{ An object created by a call to \code{boot} in the \code{boot} package, or to \code{Boot} in the \pkg{car} package of class \code{"boot"}. } \item{parm}{ A vector of numbers or coefficient names giving the coefficients for which a histogram or confidence interval is desired. If numbers are used, 1 corresponds to the intercept, if any. The default is all coefficients. } \item{layout}{ If set to a value like \code{c(1, 1)} or \code{c(4, 3)}, the layout of the graph will have this many rows and columns. If not set, the program will select an appropriate layout. If the number of graphs exceed nine, you must select the layout yourself, or you will get a maximum of nine per page. If \code{layout=NA}, the function does not set the layout and the user can use the \code{par} function to control the layout, for example to have plots from two models in the same graphics window. } \item{ask}{ If \code{TRUE}, ask the user before drawing the next plot; if \code{FALSE}, don't ask. } \item{main}{ Main title for the graphs. The default is \code{main=""} for no title. } \item{freq}{ The default for the generic \code{hist} function is \code{freq=TRUE} to give a frequency histogram. The default for \code{hist.boot} is \code{freq=FALSE} to give a density histogram. A density estimate and/or a fitted normal density can be added to the graph if \code{freq=FALSE} but not if \code{freq=TRUE}. } \item{estPoint, point.col, point.lty, point.lwd}{ If \code{estPoint=TRUE}, the default, a vertical line is drawn on the histgram at the value of the point estimate computed from the complete data. The remaining three optional arguments set the color, line type and line width of the line that is drawn. } \item{estDensity, den.col, den.lty, den.lwd}{ If \code{estDensity=TRUE} and\code{freq=FALSE}, the default, a kernel density estimate is drawn on the plot with a call to the \code{density} function with no additional arguments. The remaining three optional arguments set the color, line type and line width of the lines that are drawn. } \item{estNormal, nor.col, nor.lty, nor.lwd}{ If \code{estNormal=TRUE} and\code{freq=FALSE}, the default, a normal density with mean and sd computed from the data is drawn on the plot. The remaining three optional arguments set the color, line type and line width of the lines that are drawn. } \item{ci}{ A confidence interval based on the bootstrap will be added to the histogram using the BCa method if \code{ci="bca"} the percentile method if \code{ci="perc"}, or the normal method if \code{ci="norm"}. No interval is drawn if \code{ci="none"}. The default is \code{"bca"}. The interval is indicated by a thick horizontal line at \code{y=0}. For some bootstraps the BCa method is unavailable, in which case a warning is issued and \code{ci="perc"} is substituted. If you wish to see all the options at once, see \code{\link{boot.ci}}. The normal method is computed as the (estimate from the original data) minus the bootstrap bias plus or minus the standard deviation of the bootstrap replicates times the appropriate quantile of the standard normal distribution. } \item{legend}{ A legend can be added to the (array of) histograms. The value \dQuote{top} puts at the top-left of the plots. The value \dQuote{separate} puts the legend in its own graph following all the histograms. The value \dQuote{none} suppresses the legend. } \item{box}{ Add a box around each histogram. } \item{\dots}{ Additional arguments passed to \code{hist}; for other methods this is included for compatibility with the generic method. For example, the argument \code{border=par()$bg} in \code{hist} will draw the histogram transparently, leaving only the density estimates. With the \code{vcov} function, the additional arguments are passed to \code{\link{cov}}. See the Value section, below. } \item{high.moments}{ Should the skewness and kurtosis be included in the summary? Default is FALSE. } \item{extremes}{ Should the minimum, maximum and range be included in the summary? Default is FALSE. } \item{level}{ Confidence level, a number between 0 and 1. In \code{confint}, \code{level} can be a vector; for example \code{level=c(.50, .90, .95)} will return the following estimated quantiles: \code{c(.025, .05, .25, .75, .95, .975)}. } \item{type}{ Selects the confidence interval type. The types implemented are the \code{"percentile"} method, which uses the function \code{quantile} to return the appropriate quantiles for the confidence limit specified, the default \code{bca} which uses the bias-corrected and accelerated method presented by Efron and Tibshirani (1993, Chapter 14). For the other types, see the documentation for \code{\link{boot}}. } \item{use}{The default \code{use="complete.obs"} for \code{vcov} computes a bootstrap covariance matrix by deleting bootstraps that returned NAs. Setting \code{use} to anything else will result in a matrix of NAs.} } \value{ \code{hist} is used for the side-effect of drawing an array of historgams of each column of the first argument. \code{summary} returns a matrix of summary statistics for each of the columns in the bootstrap object. The \code{confint} method returns confidence intervals. \code{Confint} appends the estimates based on the original fitted model to the left of the confidence intervals. The function \code{vcov} returns the sample covariance of the bootstrap sample estimates, by default skipping any bootstrap samples that returned NA. } \references{ Efron, B. and Tibsharini, R. (1993) \emph{An Introduction to the Bootstrap}. New York: Chapman and Hall. Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition. Thousand Oaks: Sage. Fox, J. and Weisberg, S. (2018) \emph{Bootstrapping Regression Models in R}, \url{https://socialsciences.mcmaster.ca/jfox/Books/Companion/appendices/Appendix-Bootstrapping.pdf}. Weisberg, S. (2013) \emph{Applied Linear Regression}, Fourth Edition, Wiley } \author{Sanford Weisberg, \email{sandy@umn.edu}} \seealso{See Also \code{\link{Boot}}, \code{\link{hist}}, \code{\link{density}}, Fox and Weisberg (2017), cited above } \examples{ m1 <- lm(Fertility ~ ., swiss) betahat.boot <- Boot(m1, R=99) # 99 bootstrap samples--too small to be useful summary(betahat.boot) # default summary confint(betahat.boot) hist(betahat.boot) } \keyword{regression} car/man/bcPower.Rd0000644000176000001440000001137414140261763013524 0ustar ripleyusers\name{bcPower} \alias{bcPower} \alias{bcnPower} \alias{bcnPowerInverse} \alias{yjPower} \alias{basicPower} \title{Box-Cox, Box-Cox with Negatives Allowed, Yeo-Johnson and Basic Power Transformations} \description{ Transform the elements of a vector or columns of a matrix using, the Box-Cox, Box-Cox with negatives allowed, Yeo-Johnson, or simple power transformations. } \usage{ bcPower(U, lambda, jacobian.adjusted=FALSE, gamma=NULL) bcnPower(U, lambda, jacobian.adjusted = FALSE, gamma) bcnPowerInverse(z, lambda, gamma) yjPower(U, lambda, jacobian.adjusted = FALSE) basicPower(U,lambda, gamma=NULL) } \arguments{ \item{U}{A vector, matrix or data.frame of values to be transformed} \item{lambda}{Power transformation parameter with one element for each column of U, usuallly in the range from \eqn{-2} to \eqn{2}.} \item{jacobian.adjusted}{If \code{TRUE}, the transformation is normalized to have Jacobian equal to one. The default \code{FALSE} is almost always appropriate.} \item{gamma}{For bcPower or basicPower, the transformation is of U + gamma, where gamma is a positive number called a start that must be large enough so that U + gamma is strictly positive. For the bcnPower, Box-cox power with negatives allowed, see the details below.} \item{z}{a numeric vector the result of a call to \code{bcnPower} with \code{jacobian.adjusted=FALSE}}. } \details{ The Box-Cox family of \emph{scaled power transformations} equals \eqn{(x^{\lambda}-1)/\lambda}{(x^(lambda)-1)/lambda} for \eqn{\lambda \neq 0}{lambda not equal to 0}, and \eqn{\log(x)}{log(x)} if \eqn{\lambda =0}{lambda = 0}. The \code{bcPower} function computes the scaled power transformation of \eqn{x = U + \gamma}{x = U + gamma}, where \eqn{\gamma}{gamma} is set by the user so \eqn{U+\gamma}{U + gamma} is strictly positive for these transformations to make sense. The Box-Cox family with negatives allowed was proposed by Hawkins and Weisberg (2017). It is the Box-Cox power transformation of \deqn{z = .5 (U + \sqrt{U^2 + \gamma^2)})}{z = .5 (U + \sqrt[U^2 + gamma^2])} where for this family \eqn{\gamma}{gamma} is either user selected or is estimated. \code{gamma} must be positive if \eqn{U}{U} includes negative values and non-negative otherwise, ensuring that \eqn{z}{z} is always positive. The bcnPower transformations behave similarly to the bcPower transformations, and introduce less bias than is introduced by setting the parameter \eqn{\gamma}{gamma} to be non-zero in the Box-Cox family. The function \code{bcnPowerInverse} computes the inverse of the \code{bcnPower} function, so \code{U = bcnPowerInverse(bcnPower(U, lambda=lam, jacobian.adjusted=FALSE, gamma=gam), lambda=lam, gamma=gam)} is true for any permitted value of \code{gam} and \code{lam}. If \code{family="yeo.johnson"} then the Yeo-Johnson transformations are used. This is the Box-Cox transformation of \eqn{U+1} for nonnegative values, and of \eqn{|U|+1} with parameter \eqn{2-\lambda}{2-lambda} for \eqn{U} negative. The basic power transformation returns \eqn{U^{\lambda}}{U^{lambda}} if \eqn{\lambda}{lambda} is not 0, and \eqn{\log(\lambda)}{log(lambda)} otherwise for \eqn{U}{U} strictly positive. If \code{jacobian.adjusted} is \code{TRUE}, then the scaled transformations are divided by the Jacobian, which is a function of the geometric mean of \eqn{U} for \code{skewPower} and \code{yjPower} and of \eqn{U + gamma} for \code{bcPower}. With this adjustment, the Jacobian of the transformation is always equal to 1. Jacobian adjustment facilitates computing the Box-Cox estimates of the transformation parameters. Missing values are permitted, and return \code{NA} where ever \code{U} is equal to \code{NA}. } \value{ Returns a vector or matrix of transformed values. } \references{ Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. Hawkins, D. and Weisberg, S. (2017) Combining the Box-Cox Power and Generalized Log Transformations to Accomodate Nonpositive Responses In Linear and Mixed-Effects Linear Models \emph{South African Statistics Journal}, 51, 317-328. Weisberg, S. (2014) \emph{Applied Linear Regression}, Fourth Edition, Wiley Wiley, Chapter 7. Yeo, In-Kwon and Johnson, Richard (2000) A new family of power transformations to improve normality or symmetry. \emph{Biometrika}, 87, 954-959. } \author{ Sanford Weisberg, } \seealso{\code{\link{powerTransform}}, \code{\link{testTransform}}} \examples{ U <- c(NA, (-3:3)) \dontrun{bcPower(U, 0)} # produces an error as U has negative values bcPower(U, 0, gamma=4) bcPower(U, .5, jacobian.adjusted=TRUE, gamma=4) bcnPower(U, 0, gamma=2) basicPower(U, lambda = 0, gamma=4) yjPower(U, 0) V <- matrix(1:10, ncol=2) bcPower(V, c(0, 2)) basicPower(V, c(0,1)) } \keyword{regression} car/man/compareCoefs.Rd0000644000176000001440000000514214140261763014525 0ustar ripleyusers\name{compareCoefs} \alias{compareCoefs} \title{ Print estimated coefficients and their standard errors in a table for several regression models. } \description{ This function extracts estimates of regression parameters and their standard errors from one or more models and prints them in a table. } \usage{ compareCoefs(..., se = TRUE, zvals = FALSE, pvals = FALSE, vcov., print = TRUE, digits = 3) } \arguments{ \item{\dots}{ One or more regression-model objects. These may be of class \code{lm}, \code{glm}, \code{nlm}, or any other regression method for which the functions \code{coef} and \code{vcov} return appropriate values, or if the object inherits from the \code{mer} class created by the \code{lme4} package or \code{lme} in the \code{nlme} package. } \item{se}{ If \code{TRUE}, the default, show standard errors as well as estimates. } \item{zvals}{If \code{TRUE} (the default is \code{FALSE}), print Wald statistics, the ratio of each coefficient to its standard error.} \item{pvals}{If code{TRUE} (the default is \code{FALSE}), print two-sided p-values from the standard normal distribution corresponding to the Wald statistics.} \item{vcov.}{an optional argument, specifying a function to be applied to all of the models, returning a coefficient covariance matrix for each, or a list with one element for each model, with each element either containing a function to be applied to the corresponding model or a coefficient covariance matrix for that model. If omitted, \code{vcov} is applied to each model. This argument can also be a list of estimated covariance matrices of the coefficient estimates.} \item{print}{ If \code{TRUE}, the default, the results are printed in a nice format using \code{\link{printCoefmat}}. If \code{FALSE}, the results are returned as a matrix } \item{digits}{ Passed to the \code{\link{printCoefmat}} function for printing the result. } } \value{ This function is mainly used for its side-effect of printing the result. It also invisibly returns a matrix of estimates, standard errors, Wald statistics, and p-values. } \references{ Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. } \author{John Fox \email{jfox@mcmaster.ca}} \examples{ mod1 <- lm(prestige ~ income + education, data=Duncan) mod2 <- update(mod1, subset=-c(6,16)) mod3 <- update(mod1, . ~ . + type) mod4 <- update(mod1, . ~ . + I(income + education)) # aliased coef. compareCoefs(mod1) compareCoefs(mod1, mod2, mod4) compareCoefs(mod1, mod2, mod3, zvals=TRUE, pvals=TRUE) compareCoefs(mod1, mod2, se=FALSE) compareCoefs(mod1, mod1, vcov.=list(vcov, hccm)) } \keyword{print } car/man/boxTidwell.Rd0000644000176000001440000000531114140261763014232 0ustar ripleyusers\name{boxTidwell} \alias{boxTidwell} \alias{boxTidwell.formula} \alias{boxTidwell.default} \alias{print.boxTidwell} \title{Box-Tidwell Transformations} \description{ Computes the Box-Tidwell power transformations of the predictors in a linear model. } \usage{ boxTidwell(y, ...) \method{boxTidwell}{formula}(formula, other.x=NULL, data=NULL, subset, na.action=getOption("na.action"), verbose=FALSE, tol=0.001, max.iter=25, ...) \method{boxTidwell}{default}(y, x1, x2=NULL, max.iter=25, tol=0.001, verbose=FALSE, ...) \method{print}{boxTidwell}(x, digits=getOption("digits") - 2, ...) } \arguments{ \item{formula}{two-sided formula, the right-hand-side of which gives the predictors to be transformed.} \item{other.x}{one-sided formula giving the predictors that are \emph{not} candidates for transformation, including (e.g.) factors.} \item{data}{an optional data frame containing the variables in the model. By default the variables are taken from the environment from which \code{boxTidwell} is called.} \item{subset}{an optional vector specifying a subset of observations to be used.} \item{na.action}{a function that indicates what should happen when the data contain \code{NA}s. The default is set by the \code{na.action} setting of \code{options}.} \item{verbose}{if \code{TRUE} a record of iterations is printed; default is \code{FALSE}.} \item{tol}{if the maximum relative change in coefficients is less than \code{tol} then convergence is declared.} \item{max.iter}{maximum number of iterations.} \item{y}{response variable.} \item{x1}{matrix of predictors to transform.} \item{x2}{matrix of predictors that are \emph{not} candidates for transformation.} \item{\dots}{not for the user.} \item{x}{\code{boxTidwell} object.} \item{digits}{number of digits for rounding.} } \details{ The maximum-likelihood estimates of the transformation parameters are computed by Box and Tidwell's (1962) method, which is usually more efficient than using a general nonlinear least-squares routine for this problem. Score tests for the transformations are also reported. } \value{ an object of class \code{boxTidwell}, which is normally just printed. } \references{ Box, G. E. P. and Tidwell, P. W. (1962) Transformation of the independent variables. \emph{Technometrics} \bold{4}, 531-550. Fox, J. (2016) \emph{Applied Regression Analysis and Generalized Linear Models}, Third Edition. Sage. Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. } \author{John Fox \email{jfox@mcmaster.ca}} \examples{ boxTidwell(prestige ~ income + education, ~ type + poly(women, 2), data=Prestige) } \keyword{regression} car/man/avPlots.Rd0000644000176000001440000001575214140261763013557 0ustar ripleyusers\name{avPlots} \alias{avPlots} \alias{avPlots.default} \alias{avp} \alias{avPlot} \alias{avPlot.lm} \alias{avPlot.glm} \title{Added-Variable Plots} \description{ These functions construct added-variable, also called partial-regression, plots for linear and generalized linear models. } \usage{ avPlots(model, ...) \method{avPlots}{default}(model, terms=~., intercept=FALSE, layout=NULL, ask, main, ...) avp(...) avPlot(model, ...) \method{avPlot}{lm}(model, variable, id=TRUE, col = carPalette()[1], col.lines = carPalette()[2], xlab, ylab, pch = 1, lwd = 2, cex = par("cex"), pt.wts = FALSE, main=paste("Added-Variable Plot:", variable), grid=TRUE, ellipse=FALSE, marginal.scale=FALSE, ...) \method{avPlot}{glm}(model, variable, id=TRUE, col = carPalette()[1], col.lines = carPalette()[2], xlab, ylab, pch = 1, lwd = 2, cex = par("cex"), pt.wts = FALSE, type=c("Wang", "Weisberg"), main=paste("Added-Variable Plot:", variable), grid=TRUE, ellipse=FALSE, ...) } \arguments{ \item{model}{model object produced by \code{lm} or \code{glm}.} \item{terms}{ A one-sided formula that specifies a subset of the predictors. One added-variable plot is drawn for each term. For example, the specification \code{terms = ~.-X3} would plot against all terms except for \code{X3}. If this argument is a quoted name of one of the terms, the added-variable plot is drawn for that term only.} \item{intercept}{Include the intercept in the plots; default is \code{FALSE}.} \item{variable}{A quoted string giving the name of a regressor in the model matrix for the horizontal axis.} \item{layout}{If set to a value like \code{c(1, 1)} or \code{c(4, 3)}, the layout of the graph will have this many rows and columns. If not set, the program will select an appropriate layout. If the number of graphs exceed nine, you must select the layout yourself, or you will get a maximum of nine per page. If \code{layout=NA}, the function does not set the layout and the user can use the \code{par} function to control the layout, for example to have plots from two models in the same graphics window.} \item{main}{The title of the plot; if missing, one will be supplied.} \item{ask}{If \code{TRUE}, ask the user before drawing the next plot; if \code{FALSE} don't ask.} \item{\dots}{\code{avPlots} passes these arguments to \code{avPlot}. \code{avPlot} passes them to \code{plot}. } \item{id}{controls point identification; if \code{FALSE}, no points are identified; can be a list of named arguments to the \code{\link{showLabels}} function; \code{TRUE}, the default, is equivalent to \code{list(method=list(abs(residuals(model, type="pearson")), "x"), n=2, cex=1, col=carPalette()[1], location="lr")}, which identifies the 2 points with the largest residuals and the 2 points with the most extreme horizontal values (i.e., largest partial leverage).} \item{col}{color for points; the default is the \emph{second} entry in the current \pkg{car} palette (see \code{\link{carPalette}} and \code{\link{par}}).} \item{col.lines}{color for the fitted line.} \item{pch}{plotting character for points; default is \code{1} (a circle, see \code{\link{par}}).} \item{lwd}{line width; default is \code{2} (see \code{\link{par}}).} \item{cex}{size of plotted points; default is taken from \code{par("cex")}.} \item{pt.wts}{if \code{TRUE} (the default is \code{FALSE}), for a weighted least squares fit or a generalized linear model, the areas of plotted points are made proportional to the weights, with the average size taken from the \code{cex} argument.} \item{xlab}{x-axis label. If omitted a label will be constructed.} \item{ylab}{y-axis label. If omitted a label will be constructed.} \item{type}{if \code{"Wang"} use the method of Wang (1985); if \code{"Weisberg"} use the method in the Arc software associated with Cook and Weisberg (1999).} \item{grid}{If \code{TRUE}, the default, a light-gray background grid is put on the graph.} \item{ellipse}{controls plotting data-concentration ellipses. If \code{FALSE} (the default), no ellipses are plotted. Can be a list of named values giving \code{levels}, a vector of one or more bivariate-normal probability-contour levels at which to plot the ellipses; and \code{robust}, a logical value determing whether to use the \code{\link{cov.trob}} function in the \pkg{MASS} package to calculate the center and covariance matrix for the data ellipses. \code{TRUE} is equivalent to \code{list(levels=c(.5, .95), robust=TRUE)}.} \item{marginal.scale}{Consider an added-variable plot of Y versus X given Z. If this argument is \code{FALSE} then the limits on the horizontal axis are determined by the range of the residuals from the regression of X on Z and the limits on the vertical axis are determined by the range of the residuals from the regressnio of Y on Z. If the argument is \code{TRUE}, then the limits on the horizontal axis are determined by the range of X minus it mean, and on the vertical axis by the range of Y minus its means; adjustment is made if necessary to include outliers. This scaling allows visualization of the correlations between Y and Z and between X and Z. For example, if the X and Z are highly correlated, then the points will be concentrated on the middle of the plot.} } \details{ The function intended for direct use is \code{avPlots} (for which \code{avp} is an abbreviation). } \value{ These functions are used for their side effect id producing plots, but also invisibly return the coordinates of the plotted points. } \references{ Cook, R. D. and Weisberg, S. (1999) \emph{Applied Regression, Including Computing and Graphics.} Wiley. Fox, J. (2016) \emph{Applied Regression Analysis and Generalized Linear Models}, Third Edition. Sage. Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. Wang, P C. (1985) Adding a variable in generalized linear models. \emph{Technometrics} \bold{27}, 273--276. Weisberg, S. (2014) \emph{Applied Linear Regression}, Fourth Edition, Wiley. } \author{John Fox \email{jfox@mcmaster.ca}, Sanford Weisberg \email{sandy@umn.edu}} \seealso{\code{\link{residualPlots}}, \code{\link{crPlots}}, \code{\link{ceresPlots}}, \code{link{dataEllipse}}, \code{\link{showLabels}}, \code{\link{dataEllipse}}. } \examples{ avPlots(lm(prestige ~ income + education + type, data=Duncan)) avPlots(glm(partic != "not.work" ~ hincome + children, data=Womenlf, family=binomial), id=FALSE, pt.wts=TRUE) m1 <- lm(partic ~ tfr + menwage + womwage + debt + parttime, Bfox) par(mfrow=c(1,3)) # marginal plot, ignoring other predictors: with(Bfox, dataEllipse(womwage, partic, levels=0.5)) abline(lm(partic ~ womwage, Bfox), col="red", lwd=2) # AV plot, adjusting for others: avPlots(m1, ~ womwage, ellipse=list(levels=0.5)) # AV plot, adjusting and scaling as in marginal plot avPlots(m1, ~ womwage, marginal.scale=TRUE, ellipse=list(levels=0.5)) } \keyword{hplot} \keyword{regression} car/man/panel.car.Rd0000644000176000001440000000223714140261763013764 0ustar ripleyusers\name{panel.car} \alias{panel.car} \title{Panel Function for Coplots} \description{ a panel function for use with \code{coplot} that plots points, a lowess line, and a regression line. } \usage{ panel.car(x, y, col, pch, cex=1, span=0.5, lwd=2, reg.line=lm, lowess.line=TRUE, ...) } \arguments{ \item{x}{vector giving horizontal coordinates.} \item{y}{vector giving vertical coordinates.} \item{col}{point color.} \item{pch}{plotting character for points.} \item{cex}{character expansion factor for points.} \item{span}{span for lowess smoother.} \item{lwd}{line width, default is \code{2}.} \item{reg.line}{function to compute coefficients of regression line, or \code{FALSE} for no line.} \item{lowess.line}{if \code{TRUE} plot lowess smooth.} \item{\dots}{other arguments to pass to functions \code{lines} and \code{regLine}.} } \value{ \code{NULL}. This function is used for its side effect: producing a panel in a coplot. } \author{John Fox \email{jfox@mcmaster.ca}} \seealso{\code{\link{coplot}}, \code{\link{regLine}}} \examples{ coplot(prestige ~ income|education, panel=panel.car, col="red", data=Prestige) } \keyword{aplot} car/man/recode.Rd0000644000176000001440000000736114140261763013365 0ustar ripleyusers\name{recode} \alias{recode} \alias{Recode} \title{Recode a Variable} \description{ Recodes a numeric vector, character vector, or factor according to simple recode specifications. \code{Recode} is an alias for \code{recode} that avoids name clashes with packages, such as \pkg{Hmisc}, that have a \code{recode} function. } \usage{ recode(var, recodes, as.factor, as.numeric=TRUE, levels) Recode(...) } \arguments{ \item{var}{numeric vector, character vector, or factor.} \item{recodes}{character string of recode specifications: see below.} \item{as.factor}{return a factor; default is \code{TRUE} if \code{var} is a factor, \code{FALSE} otherwise.} \item{as.numeric}{if \code{TRUE} (the default), and \code{as.factor} is \code{FALSE}, then the result will be coerced to numeric if all values in the result are numerals---i.e., represent numbers.} \item{levels}{an optional argument specifying the order of the levels in the returned factor; the default is to use the sort order of the level names.} \item{...}{arguments to be passed to \code{recode}.} } \details{ Recode specifications appear in a character string, separated by semicolons (see the examples below), of the form \code{input=output}. If an input value satisfies more than one specification, then the first (from left to right) applies. If no specification is satisfied, then the input value is carried over to the result. \code{NA} is allowed on input and output. Several recode specifications are supported: \describe{ \item{single value}{For example, \code{0=NA}.} \item{vector of values}{For example, \code{c(7,8,9)='high'}.} \item{range of values}{For example, \code{7:9='C'}. The special values \code{lo} and \code{hi} may appear in a range. For example, \code{lo:10=1}. \emph{Note:} \code{:} is \emph{not} the R sequence operator. In addition, you may not use \code{:} with the \code{c} function within a recode specification, so for example \code{c(1, 3, 5:7)} will cause an error.} \item{\code{else}}{everything that does not fit a previous specification. For example, \code{else=NA}. Note that \code{else} matches \emph{all} otherwise unspecified values on input, including \code{NA}.} } Character data and factor levels on the left-hand side of a recode specification must be quoted. Thus, e.g., \code{c(a, b, c) = 'low'} is not allowed, and should be \code{c('a', 'b', 'c') = 'low'}. Similarly, the colon is reserved for numeric data, and, e.g., \code{c('a':'c') = 'low'} is not allowed. If the \code{var} argument is a character variable with (some) values that are composed of numerals, or a factor with (some) levels that are numerals (e.g., \code{'12'} or \code{'-2'}), then these too must be quoted and cannot be used with colons (e.g., \code{'15':'19' = '15 to 19'} is not allowed, and could be specified as \code{c('15', '16', '17', '18', '19') = '15 to 19'}, assuming that all values are the character representation of whole numbers). If all of the output values are numeric, and if \code{as.factor} is \code{FALSE}, then a numeric result is returned; if \code{var} is a factor, then by default so is the result. } \value{ a recoded vector of the same length as \code{var}. } \author{John Fox \email{jfox@mcmaster.ca}} \references{ Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. } \seealso{\code{\link{cut}}, \code{\link{factor}}} \examples{ x<-rep(1:3,3) x ## [1] 1 2 3 1 2 3 1 2 3 recode(x, "c(1,2)='A'; else='B'") ## [1] "A" "A" "B" "A" "A" "B" "A" "A" "B" Recode(x, "1:2='A'; 3='B'") ## [1] "A" "A" "B" "A" "A" "B" "A" "A" "B" } \keyword{manip} car/man/Export.Rd0000644000176000001440000000443514140314522013374 0ustar ripleyusers\name{Export} \alias{Export} \title{ Export a data frame to disk in one of many formats } \description{ Uses the \code{export} function in the \pkg{rio} package to export a file to disk. This function adds an argument for converting row.names to a column in the resulting file. } \usage{ Export(x, file, format, ..., keep.row.names) } \arguments{ \item{x}{ A data frame or matrix to be written to a file. } \item{file}{ A character string naming a file. If the file name has an extension, such as \code{.xlsx}, the extention is used to infer the type of file to be exported. See \code{\link[rio]{export}} for the file types supported. } \item{format}{see \code{\link[rio]{export}}. } \item{\dots}{ Additional arguments; see \code{\link[rio]{export}}. } \item{keep.row.names}{ If set to \code{TRUE}, then the data frame's row.names are appended to the left of the data frame with the name "id". If set to quoted character string, the row.names are added using the character string as its name. If set to \code{FALSE} row.names are lost. } } \details{ This is a convenience function in the \pkg{car} package for exporting (writing) a data frame to a file in a wide variety of formats including csv, Microsoft Excel. It optionally allows converting the row.names for the data frame to a column before writing. It then calls \code{\link[rio]{export}} in the \code{rio} package. That function in turn uses many other packages and functions for writing the function to a file. } \value{ The name of the output file as a character string (invisibly). } \author{Sanford Weisberg \email{sandy@umn.edu}} \references{ Chung-hong Chan, Geoffrey CH Chan, Thomas J. Leeper, and Jason Becker (2017). rio: A Swiss-army knife for data file I/O. R package version 0.5.0. } %% ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{ \code{\link[rio]{export}}, \code{\link{Import}} } \examples{ if(require("rio")) { Export(Duncan, "Duncan.csv", keep.row.names="occupation") Duncan2 <- Import("Duncan.csv") # Automatically restores row.names identical(Duncan, Duncan2) # cleanup unlink("Duncan.csv") } } % Add one or more standard keywords, see file "KEYWORDS" in the % R documentation directory. \keyword{ utilities }% use one of RShowDoc("KEYWORDS") \keyword{ connections }% __ONLY ONE__ keyword per line car/man/S.Rd0000644000176000001440000002544214140261763012326 0ustar ripleyusers\name{S} \alias{S} \alias{Confint} \alias{S.lm} \alias{S.glm} \alias{S.default} \alias{S.multinom} \alias{S.polr} \alias{S.lme} \alias{S.lmerMod} \alias{S.glmerMod} \alias{S.data.frame} \alias{print.S.lm} \alias{print.S.glm} \alias{print.S.multinom} \alias{print.S.polr} \alias{print.S.lme} \alias{print.S.lmerMod} \alias{print.S.glmerMod} \alias{Confint.lm} \alias{Confint.glm} \alias{Confint.multinom} \alias{Confint.polr} \alias{Confint.lme} \alias{Confint.lmerMod} \alias{Confint.glmerMod} \alias{Confint.default} \title{ Modified Functions for Summarizing Linear, Generalized Linear, and Some Other Models } \description{ \pkg{car} package replacements for the \code{\link{summary}} (\code{S}) and \code{\link{confint}} (\code{Confint}) functions for \code{\link{lm}}, \code{\link{glm}}, \code{\link{multinom}}, and \code{\link{polr}} objects, with additional arguments but the same defaults as the original functions. The \code{Confint} method for \code{"polr"} objects profiles the likelihood to get confidence intervals for the regression parameters but uses Wald intervals for the thresholds. Default methods that call the standard R \code{\link{summary}} and \code{\link{confint}} functions are provided for the \code{S} and \code{Confint} generics, so the \pkg{car} functions should be safe to use in general. The default method for \code{Confint} also assumes that there is an appropriate \code{\link{coef}} method. For briefer model summaries, see \code{\link{brief}}. } \usage{ S(object, brief, ...) \method{S}{lm}(object, brief=FALSE, correlation = FALSE, symbolic.cor = FALSE, vcov. = vcov(object, complete=FALSE), header = TRUE, resid.summary = FALSE, adj.r2 = FALSE, ...) \method{S}{glm}(object, brief=FALSE, exponentiate, dispersion, correlation = FALSE, symbolic.cor = FALSE, vcov. = vcov(object, complete=FALSE), header = TRUE, resid.summary = FALSE, ...) \method{S}{multinom}(object, brief=FALSE, exponentiate=FALSE, ...) \method{S}{polr}(object, brief=FALSE, exponentiate=FALSE, ...) \method{S}{lme}(object, brief=FALSE, correlation=FALSE, ...) \method{S}{lmerMod}(object, brief=FALSE, KR=FALSE, correlation=FALSE, ...) \method{S}{glmerMod}(object, brief=FALSE, correlation=FALSE, exponentiate, ...) \method{S}{data.frame}(object, brief=FALSE, ...) \method{S}{default}(object, brief, ...) \method{print}{S.lm}(x, digits = max(3, getOption("digits") - 3), symbolic.cor = x$symbolic.cor, signif.stars = getOption("show.signif.stars"), ...) \method{print}{S.glm}(x, digits = max(3L, getOption("digits") - 3L), symbolic.cor = x$symbolic.cor, signif.stars = getOption("show.signif.stars"), ...) \method{print}{S.multinom}(x, digits = max(3, getOption("digits") - 3), signif.stars = getOption("show.signif.stars"), ...) \method{print}{S.polr}(x, digits = max(3, getOption("digits") - 3), signif.stars = getOption("show.signif.stars"), ...) \method{print}{S.lme}(x, digits=max(3, getOption("digits") - 3), signif.stars = getOption("show.signif.stars"), ...) \method{print}{S.lmerMod}(x, digits=max(3, getOption("digits") - 3), signif.stars = getOption("show.signif.stars"), ...) \method{print}{S.glmerMod}(x, digits=max(3, getOption("digits") - 3), signif.stars = getOption("show.signif.stars"), ...) Confint(object, ...) \method{Confint}{lm}(object, estimate=TRUE, parm, level=0.95, vcov.=vcov(object, complete=FALSE), ...) \method{Confint}{glm}(object, estimate=TRUE, exponentiate=FALSE, vcov., dispersion, type=c("LR", "Wald"), ...) \method{Confint}{polr}(object, estimate=TRUE, exponentiate=FALSE, thresholds=!exponentiate, ...) \method{Confint}{multinom}(object, estimate=TRUE, exponentiate=FALSE, ...) \method{Confint}{lme}(object, estimate=TRUE, level=0.95, ...) \method{Confint}{lmerMod}(object, estimate=TRUE, level=0.95, ...) \method{Confint}{glmerMod}(object, estimate=TRUE, level=0.95, exponentiate=FALSE, ...) \method{Confint}{default}(object, estimate=TRUE, level=0.95, vcov., ...) } \arguments{ \item{object}{ a model or other object, e.g., of class \code{"lm"} as produced by a call to \code{\link{lm}}. } \item{exponentiate}{for a \code{"glm"} or \code{"glmerMod"} model using the \code{log} or \code{logit} link, or a \code{"polr"} or \code{"multinom"} model, show exponentiated coefficient estimates and confidence bounds.} \item{correlation, symbolic.cor}{see \code{\link{summary.lm}}} \item{x, digits, signif.stars}{see \code{\link{summary.lm}}} \item{dispersion}{see \code{\link{summary.glm}}} \item{vcov.}{either a matrix giving the estimated covariance matrix of the estimates, or a function that when called with \code{object} as an argument returns an estimated covariance matrix of the estimates. The default of \code{vcov. = vcov} uses the usual estimated covariance matrix. Other choices include the functions documented at \code{\link{hccm}}. See example below for using a bootstrap to estimate the covariance matrix. For the \code{glm} methods of \code{Confint} and \code{S}, if the \code{vcov.} or \code{dispersion} argument is specified, then Wald-based confidence limits are computed; otherwise the reported confidence limits are computed by profiling the likelihood. NOTE: The \code{dispersion} and \code{vcov.} arguments may not \emph{both} be specified. } \item{header}{ if \code{TRUE}, print the header for the summary output, default is \code{TRUE} } \item{resid.summary}{ if \code{TRUE}, print the five-number summary of the residuals in the summary, defaults to \code{FALSE} } \item{adj.r2}{ if \code{TRUE}, print the adjusted r-squared in the summary, default is \code{FALSE} } \item{brief}{ if \code{TRUE}, set \code{header}, \code{resid.summary} and \code{adj.r.squared} to \code{FALSE}, and suppress exponeniated coefficients for GLMs with log or logit link. For a data frame, equivalent to use of \code{\link{brief}}. } \item{KR}{if \code{TRUE} (default is \code{FALSE}), compute Kenward-Roger standard errors and Satterthwaite degrees of freedom for t-tests. \emph{Warning:} This computation can be very time-consuming.} \item{parm, level}{see \code{\link{confint}}} \item{estimate}{show the estimated coefficients in the confidence-interval table; default is \code{TRUE}.} \item{thresholds}{show confidence intervals for the estimated thresholds in the \code{"polr" model.}} \item{type}{if \code{"LR"} (the default) compute confidence intervals based on the LR statistics by profiling the likelihood; if \code{"Wald"} base confidence intervals on the Wald statistic using the coefficient standard error and the normal distribution.} \item{\dots}{ additional arguments to be passed down, for consistency with \code{summary} and \code{confint} methods } } \details{ All these functions mimic functions in the \pkg{stats} and other standard R packages for summarizing aspects of linear, generalized linear, and some other statistical models. The \code{S} function also provides an alterntive to \code{summary} for data frames, treating character variables as if they were factors. The \code{S} and \code{Confint} functions add support for the \code{vcov.} argument for linear models, which allows specifying a covariance matrix for the regression coefficients other than the usual covariance matrix returned by the function \code{\link{vcov}}. This argument may be either the name of a function, so that the call to \code{vcov.(object)} returns a covariance matrix, or else \code{vcov.} is set equal to a covariance matrix. For example, setting \code{vcov.=hccm} uses 'proposal 3' described by Long and Ervin (2000) for a sandwich coefficient-variance estimator that may be robust against nonconstant variance (see \code{\link{hccm}}). Setting \code{vcov. = hccm(object, type = "hc2")} would use the matrix returned by the \code{hccm} function using proposal 2. For use with a bootstrap, see the examples below. The overall F-test in the \code{S.lm} output uses the supplied covariance matrix in a call to the \code{\link{linearHypothesis}} function. The supplied \code{print} method for \code{S.lm} (and for other \code{S} methods) has additional arguments to customize the standard \code{summary.lm} output. Standard output is obtained by setting \code{resid.summary=TRUE, adj.r2=TRUE}. Using a heterscedasticy-corrected covariance matrix computed using \code{\link{hccm}} with GLMs other than Gaussian is not justified; see the article by Freedman (2006). The \code{Summary.glm} method for models fit with the log or logit link by default prints a table of exponentiated coefficients and their confidence limits; \code{Summary.multinom} and \code{Summary.polr} optionally print tables of exponentiated coefficients. } \value{ The \code{S.lm} and \code{S.glm} functions return a list with all the elements shown at \code{\link{summary.lm}} and \code{\link{summary.glm}}. The \code{S.multinom} and \code{S.polr} functions return a list with all the elements shown at \code{\link{summary.multinom}} and \code{summary.polr} plus potentially a table of exponentiated coefficients and confidence bounds. The \code{Confint.lm} function returns either the output from \code{\link{confint.lm}} if \code{vcov. = vcov} or Wald-type confidence intervals using the supplied covariance matrix for any other choice of \code{vcov.}. Finally, \code{Confint} applied to any object that does not inherit from \code{"lm"}, \code{"multinom"}, or \code{"polr"} simply calls \code{confint}, along with, by default, using \code{\link{coef}} to add a column of estimates to the confidence limits. } \references{ Freedman, David A. (2006). On the so-called Huber sandwich estimator and robust standard errors. \emph{The American Statistician}, \bold{60}, 299-302. Long, J. S. and Ervin, L. H. (2000) Using heteroscedasity consistent standard errors in the linear regression model. \emph{The American Statistician} \bold{54}, 217--224. White, H. (1980) A heteroskedastic consistent covariance matrix estimator and a direct test of heteroskedasticity. \emph{Econometrica} \bold{48}, 817--838. } \author{ Sanford Weisberg \email{sandy@umn.edu} } \seealso{\code{\link{brief}}, \code{\link{summary}}, \code{\link{confint}}, \code{\link{coef}}, \code{\link{summary.lm}}, \code{\link{confint}}, \code{\link{vcov.lm}}, \code{\link{hccm}}, \code{\link{Boot}}, \code{\link{linearHypothesis}}} \examples{ mod.prestige <- lm(prestige ~ education + income + type, Prestige) S(mod.prestige, vcov.=hccm) S(mod.prestige, brief=TRUE) Confint(mod.prestige, vcov.=hccm) # A logit model mod.mroz <- glm(lfp ~ ., data=Mroz, family=binomial) S(mod.mroz) # use for data frames vs. summary() Duncan.1 <-Duncan Duncan.1$type <- as.character(Duncan$type) summary(Duncan.1) S(Duncan.1) \dontrun{ # Using the bootstrap for standard errors b1 <- Boot(mod.prestige) S(mod.prestige, vcov.= vcov(b1)) Confint(b1) # run with the boot object to get corrected confidence intervals } } \keyword{models} \keyword{regression} car/man/Boxplot.Rd0000644000176000001440000000635114140261763013551 0ustar ripleyusers\name{Boxplot} \alias{Boxplot} \alias{Boxplot.default} \alias{Boxplot.formula} \alias{Boxplot.list} \alias{Boxplot.data.frame} \alias{Boxplot.matrix} \title{ Boxplots With Point Identification } \description{ \code{Boxplot} is a wrapper for the standard \R{} \code{\link{boxplot}} function, providing point identification, axis labels, and a formula interface for boxplots without a grouping variable. } \usage{ Boxplot(y, ...) \method{Boxplot}{default}(y, g, id=TRUE, xlab, ylab, ...) \method{Boxplot}{formula}(formula, data=NULL, subset, na.action=NULL, id=TRUE, xlab, ylab, ...) \method{Boxplot}{list}(y, xlab="", ylab="", ...) \method{Boxplot}{data.frame}(y, id=TRUE, ...) \method{Boxplot}{matrix}(y, ...) } \arguments{ \item{y}{a numeric variable for which the boxplot is to be constructed; a list of numeric variables, each element of which will be treated as a group; a numeric data frame or a numeric matrix, each of whose columns will be treated as a group.} \item{g}{a grouping variable, usually a factor, for constructing parallel boxplots.} \item{id}{a list of named elements giving one or more specifications for labels of individual points ("outliers"): \code{n}, the maximum number of points to label (default 10); \code{location}, \code{"lr"} (left or right) of points or \code{"avoid"} to try to avoid overplotting; \code{method}, one of \code{"y"} (automatic, the default), \code{"identify"} (interactive), or \code{"none"}; \code{col} for labels (default is the first color in \code{carPalette()} ); and \code{cex} size of labels (default is \code{1}). Can be \code{FALSE} to suppress point identification or \code{TRUE} (the default) to use all defaults. This is similar to how \code{\link{showLabels}} handles point labels for other functions in the \pkg{car} package, except that the usual default is \code{id=FALSE}.} \item{xlab, ylab}{text labels for the horizontal and vertical axes; if missing, \code{Boxplot} will use the variable names, or, in the case of a list, data frame, or matrix, empty labels.} \item{formula}{a `model' formula, of the form \code{~ y} to produce a boxplot for the variable \code{y}, or of the form \code{y ~ g}, \code{y ~ g1*g2*...}, or \code{y ~ g1 + g2 + ...} to produce parallel boxplots for \code{y} within levels of the grouping variable(s) \code{g}, etc., usually factors.} \item{data, subset, na.action}{as for statistical modeling functions (see, e.g., \code{\link{lm}}).} \item{\dots}{further arguments, such as \code{at}, to be passed to \code{\link{boxplot}}.} } \author{John Fox \email{jfox@mcmaster.ca}, with a contribution from Steve Ellison to handle \code{at} argument (see \code{\link{boxplot}}).} \references{ Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. } \seealso{ \code{\link{boxplot}} } \examples{ Boxplot(~income, data=Prestige, id=list(n=Inf)) # identify all outliers Boxplot(income ~ type, data=Prestige) Boxplot(income ~ type, data=Prestige, at=c(1, 3, 2)) Boxplot(k5 + k618 ~ lfp*wc, data=Mroz) with(Prestige, Boxplot(income, id=list(labels=rownames(Prestige)))) with(Prestige, Boxplot(income, type, id=list(labels=rownames(Prestige)))) Boxplot(scale(Prestige[, 1:4])) } \keyword{hplot} car/man/densityPlot.Rd0000644000176000001440000001726014140261763014441 0ustar ripleyusers\name{densityPlot} \alias{densityPlot} \alias{densityPlot.default} \alias{densityPlot.formula} \alias{adaptiveKernel} \alias{depan} \alias{dbiwt} \title{ Nonparametric Density Estimates } \description{ \code{densityPlot} contructs and graphs nonparametric density estimates, possibly conditioned on a factor, using the standard \R{} \code{\link{density}} function or by default \code{adaptiveKernel}, which computes an adaptive kernel density estimate. \code{depan} provides the Epanechnikov kernel and \code{dbiwt} provides the biweight kernel. } \usage{ densityPlot(x, ...) \method{densityPlot}{default}(x, g, method=c("adaptive", "kernel"), bw=if (method == "adaptive") bw.nrd0 else "SJ", adjust=1, kernel, xlim, ylim, normalize=FALSE, xlab=deparse(substitute(x)), ylab="Density", main="", col=carPalette(), lty=seq_along(col), lwd=2, grid=TRUE, legend=TRUE, show.bw=FALSE, rug=TRUE, ...) \method{densityPlot}{formula}(formula, data=NULL, subset, na.action=NULL, xlab, ylab, main="", legend=TRUE, ...) adaptiveKernel(x, kernel=dnorm, bw=bw.nrd0, adjust=1.0, n=500, from, to, cut=3, na.rm=TRUE) depan(x) dbiwt(x) } \arguments{ \item{x}{a numeric variable, the density of which is estimated; for \code{depan} and \code{dbiwt}, the argument of the kernel function.} \item{g}{an optional factor to divide the data.} \item{formula}{an \R{} model formula, of the form \code{~ variable} to estimate the unconditional density of \code{variable}, or \code{variable ~ factor} to estimate the density of \code{variable} within each level of \code{factor}.} \item{data}{an optional data frame containing the data.} \item{subset}{an optional vector defining a subset of the data.} \item{na.action}{a function to handle missing values; defaults to the value of the \R{} \code{na.action} option, initially set to \code{\link{na.omit}}.} \item{method}{either \code{"adaptive"} (the default) for an adaptive-kernel estimate or \code{"kernel"} for a fixed-bandwidth kernel estimate.} \item{bw}{the geometric mean bandwidth for the adaptive-kernel or bandwidth of the kernel density estimate(s). Must be a numerical value or a function to compute the bandwidth (default \code{\link{bw.nrd0}}) for the adaptive kernel estimate; for the kernel estimate, may either the quoted name of a rule to compute the bandwidth, or a numeric value. If plotting by groups, \code{bw} may be a vector of values, one for each group. See \code{\link{density}} and \code{\link{bw.SJ}} for details of the kernel estimator.} \item{adjust}{a multiplicative adjustment factor for the bandwidth; the default, \code{1}, indicates no adjustment; if plotting by groups, \code{adjust} may be a vector of adjustment factors, one for each group. The default bandwidth-selection rule tends to give a value that's too large if the distribution is asymmetric or has multiple modes; try setting \code{adjust} < 1, particularly for the adaptive-kernel estimator.} \item{kernel}{for \code{densityPlot} this is the name of the kernel function for the kernel estimator (the default is \code{"gaussian"}, see \code{\link{density}}); or a kernel function for the adaptive-kernel estimator (the default is \code{dnorm}, producing the Gaussian kernel). For \code{adaptivekernel} this is a kernel function, defaulting to \code{dnorm}, which is the Gaussian kernel (standard-normal density).} \item{xlim, ylim}{axis limits; if missing, determined from the range of x-values at which the densities are estimated and the estimated densities.} \item{normalize}{if \code{TRUE} (the default is \code{FALSE}), the estimated densities are rescaled to integrate approximately to 1; particularly useful if the density is estimated over a restricted domain, as when \code{from} or \code{to} are specified.} \item{xlab}{label for the horizontal-axis; defaults to the name of the variable \code{x}.} \item{ylab}{label for the vertical axis; defaults to \code{"Density"}.} \item{main}{plot title; default is empty.} \item{col}{vector of colors for the density estimate(s); defaults to the color \code{\link{carPalette}}.} \item{lty}{vector of line types for the density estimate(s); defaults to the successive integers, starting at 1.} \item{lwd}{line width for the density estimate(s); defaults to 2.} \item{grid}{if \code{TRUE} (the default), grid lines are drawn on the plot.} \item{legend}{a list of up to two named elements: \code{location}, for the legend when densities are plotted for several groups, defaults to \code{"upperright"} (see \code{\link{legend}}); and \code{title} of the legend, which defaults to the name of the grouping factor. If \code{TRUE}, the default, the default values are used; if \code{FALSE}, the legend is suppressed.} \item{n}{number of equally spaced points at which the adaptive-kernel estimator is evaluated; the default is \code{500}.} \item{from, to, cut}{the range over which the density estimate is computed; the default, if missing, is \code{min(x) - cut*bw, max(x) + cut*bw}.} \item{na.rm}{remove missing values from \code{x} in computing the adaptive-kernel estimate? The default is \code{TRUE}.} \item{show.bw}{if \code{TRUE}, show the bandwidth(s) in the horizontal-axis label or (for multiple groups) the legend; the default is \code{FALSE}.} \item{rug}{if \code{TRUE} (the default), draw a rug plot (one-dimentional scatterplot) at the bottom of the density estimate.} \item{\dots}{arguments to be passed down to graphics functions.} } \details{ If you use a different kernel function than the default \code{dnorm} that has a standard deviation different from 1 along with an automatic rule like the default function \code{bw.nrd0}, you can attach an attribute to the kernel function named \code{"scale"} that gives its standard deviation. This is true for the two supplied kernels, \code{depan} and \code{dbiwt} } \value{ \code{densityPlot} invisibly returns the \code{"density"} object computed (or list of \code{"density"} objects) and draws a graph. \code{adaptiveKernel} returns an object of class \code{"density"} (see \code{\link{density})}. } \references{ Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. W. N. Venables and B. D. Ripley (2002) \emph{Modern Applied Statistics with S}. New York: Springer. B.W. Silverman (1986) \emph{Density Estimation for Statistics and Data Analysis}. London: Chapman and Hall. } \author{ John Fox \email{jfox@mcmaster.ca} } \seealso{ \code{\link{density}}, \code{\link{bw.SJ}}, \code{\link{plot.density}} } \examples{ densityPlot(~ income, show.bw=TRUE, method="kernel", data=Prestige) densityPlot(~ income, show.bw=TRUE, data=Prestige) densityPlot(~ income, from=0, normalize=TRUE, show.bw=TRUE, data=Prestige) densityPlot(income ~ type, data=Prestige) densityPlot(~ income, show.bw=TRUE, method="kernel", data=Prestige) densityPlot(~ income, show.bw=TRUE, data=Prestige) densityPlot(~ income, from=0, normalize=TRUE, show.bw=TRUE, data=Prestige) densityPlot(income ~ type, kernel=depan, data=Prestige) densityPlot(income ~ type, kernel=depan, legend=list(location="top"), data=Prestige) plot(adaptiveKernel(UN$infantMortality, from=0, adjust=0.75), col="magenta") lines(density(na.omit(UN$infantMortality), from=0, adjust=0.75), col="blue") rug(UN$infantMortality, col="cyan") legend("topright", col=c("magenta", "blue"), lty=1, legend=c("adaptive kernel", "kernel"), inset=0.02) plot(adaptiveKernel(UN$infantMortality, from=0, adjust=0.75), col="magenta") lines(density(na.omit(UN$infantMortality), from=0, adjust=0.75), col="blue") rug(UN$infantMortality, col="cyan") legend("topright", col=c("magenta", "blue"), lty=1, legend=c("adaptive kernel", "kernel"), inset=0.02) } \keyword{hplot} car/man/boxCoxVariable.Rd0000644000176000001440000000354014140261763015027 0ustar ripleyusers\name{boxCoxVariable} \alias{boxCoxVariable} \title{Constructed Variable for Box-Cox Transformation} \description{ Computes a constructed variable for the Box-Cox transformation of the response variable in a linear model. } \usage{ boxCoxVariable(y) } \arguments{ \item{y}{response variable.} } \details{ The constructed variable is defined as \eqn{y[\log(y/\widetilde{y}) - 1]}{y[log(y/y') -1]}, where \eqn{\widetilde{y}}{y'} is the geometric mean of \code{y}. The constructed variable is meant to be added to the right-hand-side of the linear model. The t-test for the coefficient of the constructed variable is an approximate score test for whether a transformation is required. If \eqn{b} is the coefficient of the constructed variable, then an estimate of the normalizing power transformation based on the score statistic is \eqn{1 - b}{1 - b}. An added-variable plot for the constructed variable shows leverage and influence on the decision to transform \code{y}. } \value{ a numeric vector of the same length as \code{y}. } \references{ Atkinson, A. C. (1985) \emph{Plots, Transformations, and Regression}. Oxford. Box, G. E. P. and Cox, D. R. (1964) An analysis of transformations. \emph{JRSS B} \bold{26} 211--246. Fox, J. (2016) \emph{Applied Regression Analysis and Generalized Linear Models}, Third Edition. Sage. Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. } \author{John Fox \email{jfox@mcmaster.ca}} \seealso{\code{\link{boxcox}}, \code{\link{powerTransform}}, \code{\link{bcPower}}} % , \code{\link{avPlots}} \examples{ mod <- lm(interlocks + 1 ~ assets, data=Ornstein) mod.aux <- update(mod, . ~ . + boxCoxVariable(interlocks + 1)) summary(mod.aux) # avPlots(mod.aux, "boxCoxVariable(interlocks + 1)") } \keyword{manip} \keyword{regression} car/man/marginalModelPlot.Rd0000644000176000001440000002117414140261763015534 0ustar ripleyusers\name{mmps} \alias{mmps} \alias{mmp} \alias{mmp.lm} \alias{mmp.glm} \alias{mmp.default} \alias{marginalModelPlot} \alias{marginalModelPlots} \title{Marginal Model Plotting} \description{ For a regression object, draw a plot of the response on the vertical axis versus a linear combination \eqn{u} of regressors in the mean function on the horizontal axis. Added to the plot are a smooth for the graph, along with a smooth from the plot of the fitted values on \eqn{u}. \code{mmps} is an alias for \code{marginalModelPlots}, and \code{mmp} is an alias for \code{marginalModelPlot}. } \usage{ marginalModelPlots(...) mmps(model, terms= ~ ., fitted=TRUE, layout=NULL, ask, main, groups, key=TRUE, ...) marginalModelPlot(...) mmp(model, ...) \method{mmp}{lm}(model, variable, sd = FALSE, xlab = deparse(substitute(variable)), smooth=TRUE, key=TRUE, pch, groups=NULL, ...) \method{mmp}{default}(model, variable, sd = FALSE, xlab = deparse(substitute(variable)), ylab, smooth=TRUE, key=TRUE, pch, groups=NULL, col.line = carPalette()[c(2, 8)], col=carPalette()[1], id=FALSE, grid=TRUE, ...) \method{mmp}{glm}(model, variable, sd = FALSE, xlab = deparse(substitute(variable)), ylab, smooth=TRUE, key=TRUE, pch, groups=NULL, col.line = carPalette()[c(2, 8)], col=carPalette()[1], id=FALSE, grid=TRUE, ...) } \arguments{ \item{model}{A regression object, usually of class either \code{lm} or \code{glm}, for which there is a \code{predict} method defined. } \item{terms}{A one-sided formula. A marginal model plot will be drawn for each term on the right-side of this formula that is not a factor. The default is \code{~ .}, which specifies that all the terms in \code{formula(object)} will be used. If a conditioning argument is given, eg \code{terms = ~. | a}, then separate colors and smoothers are used for each unique non-missing value of \code{a}. See examples below.} \item{fitted}{If \code{TRUE}, the default, then a marginal model plot in the direction of the fitted values for a linear model or the linear predictor of a generalized linear model will be drawn.} \item{layout}{ If set to a value like \code{c(1, 1)} or \code{c(4, 3)}, the layout of the graph will have this many rows and columns. If not set, the program will select an appropriate layout. If the number of graphs exceed nine, you must select the layout yourself, or you will get a maximum of nine per page. If \code{layout=NA}, the function does not set the layout and the user can use the \code{par} function to control the layout, for example to have plots from two models in the same graphics window. } \item{ask}{If \code{TRUE}, ask before clearing the graph window to draw more plots.} \item{main}{ Main title for the array of plots. Use \code{main=""} to suppress the title; if missing, a title will be supplied. } \item{\dots}{ Additional arguments passed from \code{mmps} to \code{mmp} and then to \code{plot}. Users should generally use \code{mmps}, or equivalently \code{marginalModelPlots}. } \item{variable}{ The quantity to be plotted on the horizontal axis. If this argument is missing, the horizontal variable is the linear predictor, returned by \code{predict(object)} for models of class \code{lm}, with default label \code{"Fitted values"}, or returned by \code{predict(object, type="link")} for models of class \code{glm}, with default label \code{"Linear predictor"}. It can be any other vector of length equal to the number of observations in the object. Thus the \code{mmp} function can be used to get a marginal model plot versus any regressor or predictor while the \code{mmps} function can be used only to get marginal model plots for the first-order regressors in the formula. In particular, terms defined by a spline basis are skipped by \code{mmps}, but you can use \code{mmp} to get the plot for the variable used to define the splines.} \item{sd}{ If \code{TRUE}, display sd smooths. For a binomial regression with all sample sizes equal to one, this argument is ignored as the SD bounds don't make any sense. } \item{xlab}{ label for horizontal axis.} \item{ylab}{ label for vertical axis, defaults to name of response.} \item{smooth}{specifies the smoother to be used along with its arguments; if \code{FALSE}, no smoother is shown; can be a list giving the smoother function and its named arguments; \code{TRUE}, the default, is equivalent to \code{list(smoother=loessLine, span=2/3)} for linear models and \code{list(smoother=gamLine, k=3)} for generalized linear models. See \code{\link{ScatterplotSmoothers}} for the smoothers supplied by the \pkg{car} package and their arguments; the \code{spread} argument is not supported for marginal model plots.} \item{groups}{The name of a vector that specifies a grouping variable for separate colors/smoothers. This can also be specified as a conditioning argument on the \code{terms} argument.} \item{key}{If \code{TRUE}, include a key at the top of the plot, if \code{FALSE} omit the key. If grouping is present, the key is only printed for the upper-left plot.} \item{id}{controls point identification; if \code{FALSE} (the default), no points are identified; can be a list of named arguments to the \code{\link{showLabels}} function; \code{TRUE} is equivalent to \code{list(method="y", n=2, cex=1, col=carPalette()[1], location="lr")}, which identifies the 2 points with the most unusual response (Y) values.} \item{pch}{plotting character to use if no grouping is present.} \item{col.line}{ colors for data and model smooth, respectively. The default is to use \code{\link{carPalette}}, \code{carPalette()[c(2, 8)]}, blue and red. } \item{col}{color(s) for the plotted points.} \item{grid}{If TRUE, the default, a light-gray background grid is put on the graph} } \details{ \code{mmp} and \code{marginalModelPlot} draw one marginal model plot against whatever is specified as the horizontal axis. \code{mmps} and \code{marginalModelPlots} draws marginal model plots versus each of the terms in the \code{terms} argument and versus fitted values. \code{mmps} skips factors and interactions if they are specified in the \code{terms} argument. Terms based on polynomials or on splines (or potentially any term that is represented by a matrix of regressors) will be used to form a marginal model plot by returning a linear combination of the terms. For example, if you specify \code{terms = ~ X1 + poly(X2, 3)} and \code{poly(X2, 3)} was part of the original model formula, the horizontal axis of the marginal model plot for \code{X2} will be the value of \code{predict(model, type="terms")[, "poly(X2, 3)"])}. If the \code{predict} method for the model you are using doesn't support \code{type="terms"}, then the polynomial/spline term is skipped. Adding a conditioning variable, e.g., \code{terms = ~ a + b | c}, will produce marginal model plots for \code{a} and \code{b} with different colors and smoothers for each unique non-missing value of \code{c}. For linear models, the default smoother is loess. For generalized linear models, the default smoother uses \code{gamLine}, fitting a generalized additive model with the same family, link and weights as the fit of the model. SD smooths are not computed for for generalized linear models. For generalized linear models the default number of elements in the spline basis is \code{k=3}; this is done to allow fitting for predictors with just a few support points. If you have many support points you may wish to set \code{k} to a higher number, or \code{k=-1} for the default used by \code{\link{gam}}. } \value{ Used for its side effect of producing plots. } \seealso{\code{\link{ScatterplotSmoothers}}, \code{\link{plot}} } \references{ Cook, R. D., & Weisberg, S. (1997). Graphics for assessing the adequacy of regression models. \emph{Journal of the American Statistical Association}, 92(438), 490-499. Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition. Sage. Weisberg, S. (2005) \emph{Applied Linear Regression}, Third Edition, Wiley, Section 8.4. } \author{Sanford Weisberg, \email{sandy@umn.edu}} \examples{ c1 <- lm(infantMortality ~ ppgdp, UN) mmps(c1) c2 <- update(c1, ~ log(ppgdp)) mmps(c2) # include SD lines p1 <- lm(prestige ~ income + education, Prestige) mmps(p1, sd=TRUE) # condition on type: mmps(p1, ~. | type) # logisitic regression example # smoothers return warning messages. # fit a separate smoother and color for each type of occupation. m1 <- glm(lfp ~ ., family=binomial, data=Mroz) mmps(m1) } \keyword{hplot} \keyword{regression} car/man/carPalette.Rd0000644000176000001440000000341014140261763014177 0ustar ripleyusers\name{carPalette} \alias{carPalette} \title{ Set or Retrieve \pkg{car} Package Color Palette } \description{ This function is used to set or retrieve colors to be used in \pkg{car} package graphics functions. } \usage{ carPalette(palette) } \arguments{ \item{palette}{ if missing, returns the colors that will be used in \pkg{car} graphics; if present, the colors to be used in graphics will be set. The \code{palette} argument may also be one of \code{"car"} or \code{"default"} to use the default \pkg{car} palette (defined below), \code{"R"} to use the default R palette, or \code{"colorblind"} to use a colorblind-friendly palette (from \url{https://jfly.uni-koeln.de/color/}). } } \details{ This function sets or returns the value of \code{options(carPalette=pallete)} that will be use in \pkg{car} graphics functions to determine colors. The default is \code{c("black", "blue", "magenta", "cyan", "orange", "gray", "green3", "red"))}, which is nearly a permutation of the colors returned by the standard \code{palette} function that minimizes the use of red and green in the same graph, and that substitutes orange for the often hard to see yellow. } \value{ Invisibly returns the previous value of the \pkg{car} palette. } \references{ Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. } \author{Sanford Weisberg and John Fox} \seealso{ \code{\link{palette}}, \code{\link{colors}} } \examples{ # Standard color palette palette() # car standard color palette carPalette() # set colors to all black carPalette(rep("black", 8)) # Use a custom color palette with 12 distinct colors carPalette(sample(colors(distinct=TRUE), 12)) # restore default carPalette("default") } \keyword{ color } car/man/spreadLevelPlot.Rd0000644000176000001440000001315514140261763015227 0ustar ripleyusers\name{spreadLevelPlot} \alias{spreadLevelPlot} \alias{slp} \alias{spreadLevelPlot.formula} \alias{spreadLevelPlot.default} \alias{spreadLevelPlot.lm} \alias{print.spreadLevelPlot} \title{Spread-Level Plots} \description{ Creates plots for examining the possible dependence of spread on level, or an extension of these plots to the studentized residuals from linear models. } \usage{ spreadLevelPlot(x, ...) slp(...) \method{spreadLevelPlot}{formula}(x, data=NULL, subset, na.action, main=paste("Spread-Level Plot for", varnames[response], "by", varnames[-response]), ...) \method{spreadLevelPlot}{default}(x, by, robust.line=TRUE, start=0, xlab="Median", ylab="Hinge-Spread", point.labels=TRUE, las=par("las"), main=paste("Spread-Level Plot for", deparse(substitute(x)), "by", deparse(substitute(by))), col=carPalette()[1], col.lines=carPalette()[2], pch=1, lwd=2, grid=TRUE, ...) \method{spreadLevelPlot}{lm}(x, robust.line=TRUE, xlab="Fitted Values", ylab="Absolute Studentized Residuals", las=par("las"), main=paste("Spread-Level Plot for\n", deparse(substitute(x))), pch=1, col=carPalette()[1], col.lines=carPalette()[2:3], lwd=2, grid=TRUE, id=FALSE, smooth=TRUE, ...) \method{print}{spreadLevelPlot}(x, ...) } \arguments{ \item{x}{a formula of the form \code{y ~ x}, where \code{y} is a numeric vector and \code{x} is a factor, or an \code{lm} object to be plotted; alternatively a numeric vector.} \item{data}{an optional data frame containing the variables to be plotted. By default the variables are taken from the environment from which \code{spreadLevelPlot} is called.} \item{subset}{an optional vector specifying a subset of observations to be used.} \item{na.action}{a function that indicates what should happen when the data contain \code{NA}s. The default is set by the \code{na.action} setting of \code{options}.} \item{by}{a factor, numeric vector, or character vector defining groups.} \item{robust.line}{if \code{TRUE} a robust line is fit using the \code{rlm} function in the \code{MASS} package; if \code{FALSE} a line is fit using \code{lm}.} \item{start}{add the constant \code{start} to each data value.} \item{main}{title for the plot.} \item{xlab}{label for horizontal axis.} \item{ylab}{label for vertical axis.} \item{point.labels}{if \code{TRUE} label the points in the plot with group names.} \item{las}{if \code{0}, ticks labels are drawn parallel to the axis; set to \code{1} for horizontal labels (see \code{\link{par}}).} \item{col}{color for points; the default is the first entry in the current \pkg{car} palette (see \code{\link{carPalette}} and \code{\link{par}}).} \item{col.lines}{for the default method, the line color, defaulting to the second entry in the \pkg{car} color palette; for the \code{"lm"} method, a vector of two colors for, respectively, the fitted straight line and a nonparametric regression smooth line, default to the second and third entries in the \pkg{car} color palette.} \item{pch}{plotting character for points; default is \code{1} (a circle, see \code{\link{par}}).} \item{lwd}{line width; default is \code{2} (see \code{\link{par}}).} \item{grid}{If TRUE, the default, a light-gray background grid is put on the graph} \item{id}{controls point identification; if \code{FALSE} (the default), no points are identified; can be a list of named arguments to the \code{\link{showLabels}} function; \code{TRUE} is equivalent to \code{list(method=list("x", "y"), n=2, cex=1, col=carPalette()[1], location="lr")}, which identifies the 2 points the most extreme horizontal ("X", absolute studentized residual) values and the 2 points with the most extreme horizontal ("Y", fitted values) values.} \item{smooth}{specifies the smoother to be used along with its arguments; if \code{FALSE}, no smoother is shown; can be a list giving the smoother function and its named arguments; \code{TRUE}, the default, is equivalent to \code{list(smoother=loessLine)}. See \code{\link{ScatterplotSmoothers}} for the smoothers supplied by the \pkg{car} package and their arguments.} \item{\dots}{arguments passed to plotting functions.} } \details{ Except for linear models, computes the statistics for, and plots, a Tukey spread-level plot of log(hinge-spread) vs. log(median) for the groups; fits a line to the plot; and calculates a spread-stabilizing transformation from the slope of the line. For linear models, plots log(abs(studentized residuals) vs. log(fitted values). Point labeling was added in November, 2016. The function \code{slp} is an abbreviation for \code{spreadLevelPlot}. } \value{ An object of class \code{spreadLevelPlot} containing: \item{Statistics}{a matrix with the lower-hinge, median, upper-hinge, and hinge-spread for each group. (Not for an \code{lm} object.)} \item{PowerTransformation}{spread-stabilizing power transformation, calculated as \eqn{1 - slope} of the line fit to the plot.} } \references{ Fox, J. (2016) \emph{Applied Regression Analysis and Generalized Linear Models}, Third Edition. Sage. Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. Hoaglin, D. C., Mosteller, F. and Tukey, J. W. (Eds.) (1983) \emph{Understanding Robust and Exploratory Data Analysis.} Wiley. } \author{John Fox \email{jfox@mcmaster.ca}} \seealso{\code{\link{hccm}}, \code{\link{ncvTest}} } \examples{ spreadLevelPlot(interlocks + 1 ~ nation, data=Ornstein) slp(lm(interlocks + 1 ~ assets + sector + nation, data=Ornstein)) } \keyword{hplot} \keyword{regression} car/man/car-deprecated.Rd0000644000176000001440000000145414140261763014764 0ustar ripleyusers\name{car-deprecated} \alias{car-deprecated} \alias{bootCase} \alias{bootCase.lm} \alias{bootCase.glm} \alias{bootCase.nls} \alias{nextBoot} \alias{nextBoot.lm} \alias{nextBoot.nls} \title{Deprecated Functions in the car Package} \description{ These functions are provided for compatibility with older versions of the \pkg{car} package only, and may be removed eventually. Commands that worked in versions of the \pkg{car} package prior to version 3.0-0 will not necessarily work in version 3.0-0 and beyond, or may not work in the same manner. } \usage{ bootCase(...) nextBoot(...) } \arguments{ \item{...}{arguments to pass to methods.} } \details{ These functions are replaced by \code{\link{Boot}}. } \seealso{See Also \code{\link{Boot}}} \keyword{regression} car/man/invTranPlot.Rd0000644000176000001440000001117614140261763014403 0ustar ripleyusers\name{invTranPlot} \alias{invTranPlot} \alias{invTranPlot.default} \alias{invTranPlot.formula} \alias{invTranEstimate} \title{ Choose a Predictor Transformation Visually or Numerically } \description{ \code{invTranPlot} draws a two-dimensional scatterplot of \eqn{Y}{Y} versus \eqn{X}{X}, along with the OLS fit from the regression of \eqn{Y}{Y} on \eqn{(X^{\lambda}-1)/\lambda}{(X?^(lam)-1)/lam}. \code{invTranEstimate} finds the nonlinear least squares estimate of \eqn{\lambda}{lambda} and its standard error. } \usage{ invTranPlot(x, ...) \S3method{invTranPlot}{formula}(x, data, subset, na.action, id=FALSE, ...) \S3method{invTranPlot}{default}(x, y, lambda=c(-1, 0, 1), robust=FALSE, lty.lines=rep(c("solid", "dashed", "dotdash", "longdash", "twodash"), length=1 + length(lambda)), lwd.lines=2, col=carPalette()[1], col.lines=carPalette(), xlab=deparse(substitute(x)), ylab=deparse(substitute(y)), family="bcPower", optimal=TRUE, key="auto", id=FALSE, grid=TRUE, ...) invTranEstimate(x, y, family="bcPower", confidence=0.95, robust=FALSE) } \arguments{ \item{x}{The predictor variable, or a formula with a single response and a single predictor } \item{y}{The response variable } \item{data}{An optional data frame to get the data for the formula} \item{subset}{Optional, as in \code{\link{lm}}, select a subset of the cases} \item{na.action}{Optional, as in \code{\link{lm}}, the action for missing data} \item{lambda}{The powers used in the plot. The optimal power than minimizes the residual sum of squares is always added unless optimal is \code{FALSE}. } \item{robust}{If \code{TRUE}, then the estimated transformation is computed using Huber M-estimation with the MAD used to estimate scale and k=1.345. The default is \code{FALSE}.} \item{family}{The transformation family to use, \code{"bcPower"}, \code{"yjPower"}, or a user-defined family.} \item{confidence}{returns a profile likelihood confidence interval for the optimal transformation with this confidence level. If \code{FALSE}, or if \code{robust=TRUE}, no interval is returned.} \item{optimal}{Include the optimal value of lambda?} \item{lty.lines}{line types corresponding to the powers} \item{lwd.lines}{the width of the plotted lines, defaults to 2 times the standard} \item{col}{color(s) of the points in the plot. If you wish to distinguish points according to the levels of a factor, we recommend using symbols, specified with the \code{pch} argument, rather than colors.} \item{col.lines}{color of the fitted lines corresponding to the powers. The default is to use the colors returned by \code{\link{carPalette}}} \item{key}{The default is \code{"auto"}, in which case a legend is added to the plot, either above the top marign or in the bottom right or top right corner. Set to NULL to suppress the legend.} \item{xlab}{Label for the horizontal axis.} \item{ylab}{Label for the vertical axis.} \item{id}{controls point identification; if \code{FALSE} (the default), no points are identified; can be a list of named arguments to the \code{\link{showLabels}} function; \code{TRUE} is equivalent to \code{list(method=list(method="x", n=2, cex=1, col=carPalette()[1], location="lr")}, which identifies the 2 points with the most extreme horizontal values --- i.e., the response variable in the model.} \item{...}{Additional arguments passed to the plot method, such as \code{pch}.} \item{grid}{If TRUE, the default, a light-gray background grid is put on the graph} } \value{ \code{invTranPlot} plots a graph and returns a data frame with \eqn{\lambda}{lam} in the first column, and the residual sum of squares from the regression for that \eqn{\lambda}{lam} in the second column. \code{invTranEstimate} returns a list with elements \code{lambda} for the estimate, \code{se} for its standard error, and \code{RSS}, the minimum value of the residual sum of squares. } \seealso{ \code{\link{inverseResponsePlot}},\code{\link{optimize}}} \references{ Fox, J. and Weisberg, S. (2011) \emph{An R Companion to Applied Regression}, Second Edition, Sage. Prendergast, L. A., & Sheather, S. J. (2013) On sensitivity of inverse response plot estimation and the benefits of a robust estimation approach. \emph{Scandinavian Journal of Statistics}, 40(2), 219-237. Weisberg, S. (2014) \emph{Applied Linear Regression}, Fourth Edition, Wiley, Chapter 7. } \author{Sanford Weisberg, \email{sandy@umn.edu} } \examples{ with(UN, invTranPlot(ppgdp, infantMortality)) with(UN, invTranEstimate(ppgdp, infantMortality)) } \keyword{ hplot }% at least one, from doc/KEYWORDS \keyword{regression} car/man/outlierTest.Rd0000644000176000001440000000526214140261763014445 0ustar ripleyusers\name{outlierTest} \alias{outlierTest} \alias{outlierTest.lm} \alias{outlierTest.glm} \alias{outlierTest.lmerMod} \alias{print.outlierTest} \title{Bonferroni Outlier Test} \description{ Reports the Bonferroni p-values for testing each observation in turn to be a mean-shift outlier, based Studentized residuals in linear (t-tests), generalized linear models (normal tests), and linear mixed models. } \usage{ outlierTest(model, ...) \method{outlierTest}{lm}(model, cutoff=0.05, n.max=10, order=TRUE, labels=names(rstudent), ...) \method{outlierTest}{lmerMod}(model, ...) \method{print}{outlierTest}(x, digits=5, ...) } \arguments{ \item{model}{an \code{lm}, \code{glm}, or \code{lmerMod} model object; the \code{"lmerMod"} method calls the \code{"lm"} method and can take the same arguments.} \item{cutoff}{observations with Bonferroni p-values exceeding \code{cutoff} are not reported, unless no observations are nominated, in which case the one with the largest Studentized residual is reported.} \item{n.max}{maximum number of observations to report (default, \code{10}).} \item{order}{report Studenized residuals in descending order of magnitude? (default, \code{TRUE}).} \item{labels}{an optional vector of observation names.} \item{...}{arguments passed down to methods functions.} \item{x}{\code{outlierTest} object.} \item{digits}{number of digits for reported p-values.} } \details{ For a linear model, p-values reported use the t distribution with degrees of freedom one less than the residual df for the model. For a generalized linear model, p-values are based on the standard-normal distribution. The Bonferroni adjustment multiplies the usual two-sided p-value by the number of observations. The \code{lm} method works for \code{glm} objects. To show all of the observations set \code{cutoff=Inf} and \code{n.max=Inf}. } \value{ an object of class \code{outlierTest}, which is normally just printed. } \references{ Cook, R. D. and Weisberg, S. (1982) \emph{Residuals and Influence in Regression.} Chapman and Hall. Fox, J. (2016) \emph{Applied Regression Analysis and Generalized Linear Models}, Third Edition. Sage. Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. Weisberg, S. (2014) \emph{Applied Linear Regression}, Fourth Edition, Wiley. Williams, D. A. (1987) Generalized linear model diagnostics using the deviance and single case deletions. \emph{Applied Statistics} \bold{36}, 181--191. } \author{John Fox \email{jfox@mcmaster.ca} and Sanford Weisberg} \examples{ outlierTest(lm(prestige ~ income + education, data=Duncan)) } \keyword{regression} \keyword{htest} car/man/testTransform.Rd0000644000176000001440000000611714140261763014775 0ustar ripleyusers\name{testTransform} \alias{testTransform} \alias{testTransform.powerTransform} \alias{testTransform.lmerModpowerTransform} \alias{testTransform.bcnPowerTransformlmer} \title{Likelihood-Ratio Tests for Univariate or Multivariate Power Transformations to Normality} \description{ \code{testTransform} computes likelihood ratio tests for particular values of the power parameter based on \code{powerTransform} objects. } \usage{ testTransform(object, lambda) \S3method{testTransform}{powerTransform}(object, lambda=rep(1, dim(object$y)[2])) \S3method{testTransform}{lmerModpowerTransform}(object, lambda=1) \S3method{testTransform}{bcnPowerTransformlmer}(object, lambda=1) } \arguments{ \item{object}{An object created by a call to \code{powerTransform}.} \item{lambda}{A vector of powers of length equal to the number of variables transformed.} } \details{The function \code{\link{powerTransform}} is used to estimate a power transformation for a univariate or multivariate sample or multiple linear regression problem, using the method of Box and Cox (1964). It is usual to round the estimates to nearby convenient values, and this function is use to compulte a likelihood ratio test for values of the transformation parameter other than the ml-type estimate. For one-parameter families of transformations, namely the Box-Cox power family \code{\link{bcPower}} and the Yeo-Johnson power family \code{\link{yjPower}}, this function computes a test based on twice the difference in the log-likelihood between the maximum likelihood-like estimate and the log-likelihood evaluated at the value of \code{lambda} specified. For the \code{\link{bcnPower}} Box-Cox power with negatives allowed, the test is based on the profile loglikelihood maximizing over the location (or \code{gamma}) parameter(s). Thus, \code{gamma} is treated as a nusiance parameter.} \value{ A data frame with one row giving the value of the test statistic, its degrees of freedom, and a p-value. The test is the likelihood ratio test, comparing the value of the log-likelihood at the hypothesized value to the value of the log-likelihood at the maximum likelihood estimate. } \references{Box, G. E. P. and Cox, D. R. (1964) An analysis of transformations. \emph{Journal of the Royal Statisistical Society, Series B}. 26 211-46. Cook, R. D. and Weisberg, S. (1999) \emph{Applied Regression Including Computing and Graphics}. Wiley. Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. Weisberg, S. (2014) \emph{Applied Linear Regression}, Fourth Edition, Wiley. } \author{ Sanford Weisberg, } \seealso{\code{\link{powerTransform}} and \code{\link{bcnPower}} for examples of the use of this function and other tests that might be of interest in some circumstances. } \examples{ summary(a3 <- powerTransform(cbind(len, adt, trks, sigs1) ~ htype, Highway1)) # test lambda = (0 0 0 -1) testTransform(a3, c(0, 0, 0, -1)) summary(q1 <- powerTransform(lm(cbind(LoBD$I1L2, LoBD$I1L1) ~ pool, LoBD), family="bcnPower")) testTransform(q1, c(.3, .8)) } \keyword{ regression}% at least one, from doc/KEYWORDS car/man/ScatterplotSmoothers.Rd0000644000176000001440000001763714140261763016343 0ustar ripleyusers\name{ScatterplotSmoothers} \alias{ScatterplotSmoothers} \alias{gamLine} \alias{quantregLine} \alias{loessLine} \title{ Smoothers to Draw Lines on Scatterplots } \description{ These smoothers are used to draw nonparametric-regression lines on scatterplots produced by the \code{\link{scatterplot}}, \code{\link{scatterplotMatrix}}, and several other \pkg{car} functions. The functions are not meant to be called directly by the user, although the user can supply options via the \code{smoother.args} argument, the contents of which vary by the smoother (see \emph{Details} below). The \code{gamLine} smoother uses the \code{\link{gam}} function in the \pkg{mgcv} package, the \code{loessLine} smoother uses the \code{\link{loess}} function in the \pkg{stats} package, and the \code{quantregLine} smoother uses the \code{\link{rqss}} function in the \pkg{quantreg} package. } \usage{ gamLine(x, y, col=carPalette()[1], log.x=FALSE, log.y=FALSE, var=FALSE, spread=var, smoother.args=NULL, draw=TRUE, offset=0) loessLine(x, y, col=carPalette()[1], log.x=FALSE, log.y=FALSE, var=FALSE, spread=var, smoother.args=NULL, draw=TRUE, offset=0) quantregLine(x, y, col=carPalette()[1], log.x=FALSE, log.y=FALSE, var=FALSE, spread=var, smoother.args=NULL, draw=TRUE, offset=0) } \arguments{ \item{x}{horizontal coordinates of points.} \item{y}{vertical coordinates of points.} \item{col}{line color.} \item{log.x}{should be set to \code{TRUE} (default is \code{FALSE}) if the horizontal axis is logged.} \item{log.y}{should be set to \code{TRUE} (default is \code{FALSE}) if the vertical axis is logged.} \item{spread, var}{the default is to plot only an estimated mean or median function. If either of these arguments is TRUE, then a measure of variability is also plotted.} \item{smoother.args}{additional options accepted by the smoother, in the form of a list of named values (see \emph{Details} below).} \item{draw}{if TRUE, the default, draw the smoother on the currently active graph. If FALSE, return a list with coordinates \code{x} and \code{y} for the points that make up the smooth and if requested \code{x.pos, y.pos, x.neg, y.neg} for the spread smooths.} \item{offset}{For use when \code{spread=TRUE}, the vertical axis is \code{sqrt(offset^2 + variance smooth)}.} } \details{ The \code{loessLine} function is a re-implementation of the \code{loess} smoother that was used in \pkg{car} prior to September 2012. The main enhancement is the ability to set more options through the \code{smoother.args} argument. The \code{gamLine} function is more general than \code{loessLine} because it supports fitting a generalized spline regression model, with user-specified error distribution and link function. The \code{quantregLine} function fits a model using splines with estimation based on L1 regression for the median and quantile regression the (optional) spread. It is likely to be more robust than the other smoothers. The \code{smoother.args} argument is a list of named elements (or sub-arguments) used to pass additional arguments to the smoother. As of November, 2016, the smoother is evaluated by default at an equally spaced grid of 50 points in the range of the horizontal variable. With any of the smoothers, you can change to, say, 100 evaluation points via the argument \code{smoother.args=list(evaluation=100)}. As of version 3.0-1, the \code{smoother.args} elements \code{col.var}, \code{lty.var}, and \code{lwd.var} are equivalent to \code{col.spread}, \code{lty.spread}, and \code{lwd.spread}, respectively. The \code{style} sub-argument controls how spread/variance envelopes are displayed, with choices \code{"filled"} (the default), \code{"lines"}, and \code{"none"} (which is equivalent to \code{var=FALSE}). The \code{alpha} subargument controls the transparency/opacity of filled spread envelopes with allowable values between \code{0} and \code{1} (default \code{0.15}). The \code{border} subargument controls whether a border line is drawn around the filled region (the default is \code{TRUE}). The \code{vertical} subargument controls whether the left and right ends of the filled region are forced to be vertical (the default is \code{TRUE}). For \code{loessLine}, the default is \code{smoother.args=list(lty.smooth=1, lwd.smooth=2, lty.spread=4, lwd.spread=2, style="filled", alpha=0.15, span=2/3, degree=1, family="symmetric", iterations=4)}. (Prior to November 2016, the default span was 1/2.) The elements \code{lty.smooth}, \code{lwd.smooth}, and \code{col.spread} are the line type, line width, and line color, respectively of the mean or median smooth; \code{lty.spread}, \code{lwd.spread}, and \code{col.spread} are the line type, width, and color of the spread smooths, if requested. The elements \code{span}, \code{degree}, and \code{family} are passed as arguments to the \code{\link{loess}} function, along with \code{iterations} robustness iterations. For \code{gamLine}, the default is \code{smoother.args=list(lty.smooth=1, lwd.smooth=2, lty.spread=4, lwd.spread=2, style="filled", alpha=0.15, k=-1, bs="tp", family="gaussian", link=NULL, weights=NULL)}. The first six elements are as for \code{loessLine}. The next two elements are passed to the \code{\link{gam}} function to control smoothing: \code{k=-1} allows \code{gam} to choose the number of splines in the basis function; \code{bs="tp"} provides the type of spline basis to be used, with \code{"tp"} for the default thin-plate splines. The last three arguments specify a distributional family, link function, and weights as in generalized linear models. See the examples below. The \code{spread} element is ignored unless \code{family="gaussian"} and \code{link=NULL}. For \code{quantregLine}, the default is \code{smoother.args=list(lty.smooth=1, lwd.smooth=2, lty.spread=4, lwd.spread=2, style="filled", alpha=0.15, lambda=IQR(x))}. The first six elements are as for \code{loessLine}. The last element is passed to the \code{\link{qss}} function in \pkg{quantreg}. It is a smoothing parameter, by default a robust estimate of the scale of the horizontal axis variable. This is an arbitrary choice, and may not work well in all circumstances. } \author{John Fox \email{jfox@mcmaster.ca} and Sanford Weisberg \email{sandy@umn.edu}.} \seealso{\code{\link{scatterplot}}, \code{\link{scatterplotMatrix}}, \code{\link{gam}}, \code{\link{loess}}, and \code{\link{rqss}}.} \examples{ scatterplot(prestige ~ income, data=Prestige) scatterplot(prestige ~ income, data=Prestige, smooth=list(smoother=gamLine)) scatterplot(prestige ~ income, data=Prestige, smooth=list(smoother=quantregLine)) scatterplot(prestige ~ income | type, data=Prestige) scatterplot(prestige ~ income | type, data=Prestige, smooth=list(smoother=gamLine)) scatterplot(prestige ~ income | type, data=Prestige, smooth=list(smoother=quantregLine)) scatterplot(prestige ~ income | type, data=Prestige, smooth=FALSE) scatterplot(prestige ~ income | type, data=Prestige, smooth=list(spread=TRUE)) scatterplot(prestige ~ income | type, data=Prestige, smooth=list(smoother=gamLine, spread=TRUE)) scatterplot(prestige ~ income | type, data=Prestige, smooth=list(smoother=quantregLine, spread=TRUE)) scatterplot(weight ~ repwt | sex, data=Davis, smooth=list(smoother=loessLine, spread=TRUE, style="lines")) scatterplot(weight ~ repwt | sex, data=Davis, smooth=list(smoother=gamLine, spread=TRUE, style="lines")) # messes up scatterplot(weight ~ repwt | sex, data=Davis, smooth=list(smoother=quantregLine, spread=TRUE, style="lines")) # robust set.seed(12345) w <- 1 + rpois(100, 5) x <- rnorm(100) p <- 1/(1 + exp(-(x + 0.5*x^2))) y <- rbinom(100, w, p) scatterplot(y/w ~ x, smooth=list(smoother=gamLine, family="binomial", weights=w)) scatterplot(y/w ~ x, smooth=list(smoother=gamLine, family=binomial, link="probit", weights=w)) scatterplot(y/w ~ x, smooth=list(smoother=loessLine), reg=FALSE) y <- rbinom(100, 1, p) scatterplot(y ~ x, smooth=list(smoother=gamLine, family=binomial)) } \keyword{hplot} car/man/leveneTest.Rd0000644000176000001440000000416314140261763014237 0ustar ripleyusers\name{leveneTest} \alias{leveneTest} \alias{leveneTest.formula} \alias{leveneTest.lm} \alias{leveneTest.default} \title{Levene's Test} \description{ Computes Levene's test for homogeneity of variance across groups. } \usage{ leveneTest(y, ...) \method{leveneTest}{formula}(y, data, ...) \method{leveneTest}{lm}(y, ...) \method{leveneTest}{default}(y, group, center=median, ...) } \arguments{ \item{y}{response variable for the default method, or a \code{lm} or \code{formula} object. If \code{y} is a linear-model object or a formula, the variables on the right-hand-side of the model must all be factors and must be completely crossed.} \item{group}{factor defining groups.} \item{center}{The name of a function to compute the center of each group; \code{mean} gives the original Levene's test; the default, \code{median}, provides a more robust test.} \item{data}{a data frame for evaluating the \code{formula}.} \item{...}{arguments to be passed down, e.g., \code{data} for the \code{formula} and \code{lm} methods; can also be used to pass arguments to the function given by \code{center} (e.g., \code{center=mean} and \code{trim=0.1} specify the 10\% trimmed mean).} } \value{ returns an object meant to be printed showing the results of the test. } \references{ Fox, J. (2016) \emph{Applied Regression Analysis and Generalized Linear Models}, Third Edition. Sage. Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. } \author{John Fox \email{jfox@mcmaster.ca}; original generic version contributed by Derek Ogle} \note{adapted from a response posted by Brian Ripley to the r-help email list.} \examples{ with(Moore, leveneTest(conformity, fcategory)) with(Moore, leveneTest(conformity, interaction(fcategory, partner.status))) leveneTest(conformity ~ fcategory*partner.status, data=Moore) leveneTest(lm(conformity ~ fcategory*partner.status, data=Moore)) leveneTest(conformity ~ fcategory*partner.status, data=Moore, center=mean) leveneTest(conformity ~ fcategory*partner.status, data=Moore, center=mean, trim=0.1) } \keyword{htest} car/man/Ellipses.Rd0000644000176000001440000002305314140261763013700 0ustar ripleyusers\name{Ellipses} \alias{ellipse} \alias{dataEllipse} \alias{confidenceEllipse} \alias{confidenceEllipse.default} \alias{confidenceEllipse.lm} \alias{confidenceEllipse.glm} \title{Ellipses, Data Ellipses, and Confidence Ellipses} \description{ These functions draw ellipses, including data ellipses, and confidence ellipses for linear, generalized linear, and possibly other models. } \usage{ ellipse(center, shape, radius, log="", center.pch=19, center.cex=1.5, segments=51, draw=TRUE, add=draw, xlab="", ylab="", col=carPalette()[2], lwd=2, fill=FALSE, fill.alpha=0.3, grid=TRUE, ...) dataEllipse(x, y, groups, group.labels=group.levels, ellipse.label, weights, log="", levels=c(0.5, 0.95), center.pch=19, center.cex=1.5, draw=TRUE, plot.points=draw, add=!plot.points, segments=51, robust=FALSE, xlab=deparse(substitute(x)), ylab=deparse(substitute(y)), col=if (missing(groups)) carPalette()[1:2] else carPalette()[1:length(group.levels)], pch=if (missing(groups)) 1 else seq(group.levels), lwd=2, fill=FALSE, fill.alpha=0.3, grid=TRUE, id=FALSE, ...) confidenceEllipse(model, ...) \method{confidenceEllipse}{lm}(model, which.coef, vcov.=vcov, L, levels=0.95, Scheffe=FALSE, dfn, center.pch=19, center.cex=1.5, segments=51, xlab, ylab, col=carPalette()[2], lwd=2, fill=FALSE, fill.alpha=0.3, draw=TRUE, add=!draw, ...) \method{confidenceEllipse}{glm}(model, chisq, ...) \method{confidenceEllipse}{default}(model, which.coef, vcov.=vcov, L, levels=0.95, Scheffe=FALSE, dfn, center.pch=19, center.cex=1.5, segments=51, xlab, ylab, col=carPalette()[2], lwd=2, fill=FALSE, fill.alpha=0.3, draw=TRUE, add=!draw, ...) } \arguments{ \item{center}{2-element vector with coordinates of center of ellipse.} \item{shape}{\eqn{2\times 2}{2 * 2} shape (or covariance) matrix.} \item{radius}{radius of circle generating the ellipse.} \item{log}{when an ellipse is to be added to an existing plot, indicates whether computations were on logged values and to be plotted on logged axes; \code{"x"} if the x-axis is logged, \code{"y"} if the y-axis is logged, and \code{"xy"} or \code{"yx"} if both axes are logged. The default is \code{""}, indicating that neither axis is logged.} \item{center.pch}{character for plotting ellipse center; if \code{FALSE} or \code{NULL} the center point isn't plotted.} \item{center.cex}{relative size of character for plotting ellipse center.} \item{segments}{number of line-segments used to draw ellipse.} \item{draw}{if \code{TRUE} produce graphical output; if \code{FALSE}, only invisibly return coordinates of ellipse(s).} \item{add}{if \code{TRUE} add ellipse(s) to current plot.} \item{xlab}{label for horizontal axis.} \item{ylab}{label for vertical axis.} \item{x}{a numeric vector, or (if \code{y} is missing) a 2-column numeric matrix.} \item{y}{a numeric vector, of the same length as \code{x}.} \item{groups}{optional: a factor to divide the data into groups; a separate ellipse will be plotted for each group (level of the factor).} \item{group.labels}{labels to be plotted for the groups; by default, the levels of the \code{groups} factor.} \item{ellipse.label}{a label for the ellipse(s) or a vector of labels; if several ellipses are drawn and just one label is given, then that label will be repeated. The default is not to label the ellipses.} \item{weights}{a numeric vector of weights, of the same length as \code{x} and \code{y} to be used by \code{\link{cov.wt}} or \code{\link{cov.trob}} in computing a weighted covariance matrix; if absent, weights of \code{1} are used.} \item{plot.points}{if \code{FALSE} data ellipses are drawn, but points are not plotted.} \item{levels}{draw elliptical contours at these (normal) probability or confidence levels.} \item{robust}{if \code{TRUE} use the \code{cov.trob} function in the \pkg{MASS} package to calculate the center and covariance matrix for the data ellipse.} \item{model}{a model object produced by \code{lm} or \code{glm}.} \item{which.coef}{2-element vector giving indices of coefficients to plot; if missing, the first two coefficients (disregarding the regression constant) will be selected.} \item{vcov.}{a coefficient-covariance matrix or a function (such as \code{\link{hccm}}) to compute the coefficent-covariance matrix from \code{model}; the default is the \code{vcov} function.} \item{L}{As an alternative to selecting coefficients to plot, a transformation matrix can be specified to compute two linear combinations of the coefficients; if the \code{L} matrix is given, it takes precedence over the \code{which.coef} argument. \code{L} should have two rows and as many columns as there are coefficients. It can be given directly as a numeric matrix, or specified by a pair of character-valued expressions, in the same manner as for the \code{link{linearHypothesis}} function, but with no right-hand side.} \item{Scheffe}{if \code{TRUE} scale the ellipse so that its projections onto the axes give Scheffe confidence intervals for the coefficients.} \item{dfn}{``numerator'' degrees of freedom (or just degrees of freedom for a GLM) for drawing the confidence ellipse. Defaults to the number of coefficients in the model (disregarding the constant) if \code{Scheffe} is \code{TRUE}, or to \code{2} otherwise; selecting \code{dfn = 1} will draw the ``confidence-interval generating'' ellipse, with projections on the axes corresponding to individual confidence intervals with the stated level of coverage.} \item{chisq}{if \code{TRUE}, the confidence ellipse for the coefficients in a generalized linear model are based on the chisquare statistic, if \code{FALSE} on the $F$-statistic. This corresponds to using the default and linear-model methods respectively.} \item{col}{color for lines and ellipse center; the default is the \emph{second} entry in the current \pkg{car} palette (see \code{\link{carPalette}} and \code{\link{par}}). For \code{dataEllipse}, two colors can be given, in which case the first is for plotted points and the second for lines and the ellipse center; if ellipses are plotted for \code{groups}, then this is a vector of colors for the groups.} \item{pch}{for \code{dataEllipse} this is the plotting character (default, symbol \code{1}, a hollow circle) to use for the points; if ellipses are plotted by \code{groups}, then this a vector of plotting characters, with consecutive symbols starting with \code{1} as the default.} \item{lwd}{line width; default is \code{2} (see \code{\link{par}}).} \item{fill}{fill the ellipse with translucent color \code{col} (default, \code{FALSE})?} \item{fill.alpha}{transparency of fill (default = \code{0.3}).} \item{\dots}{other plotting parameters to be passed to \code{plot} and \code{line}.} \item{id}{controls point identification; if \code{FALSE} (the default), no points are identified; can be a list of named arguments to the \code{\link{showLabels}} function; \code{TRUE} is equivalent to \code{list(method="mahal", n=2, cex=1, col=carPalette()[1], location="lr")} (with the default \code{col} actually dependent on the number of groups), which identifies the 2 points with the largest Mahalanobis distances from the center of the data.} \item{grid}{If TRUE, the default, a light-gray background grid is put on the graph} } \details{ The ellipse is computed by suitably transforming a unit circle. \code{dataEllipse} superimposes the normal-probability contours over a scatterplot of the data. } \value{ These functions are mainly used for their side effect of producing plots. For greater flexibility (e.g., adding plot annotations), however, \code{ellipse} returns invisibly the (x, y) coordinates of the calculated ellipse. \code{dataEllipse} and \code{confidenceEllipse} return invisibly the coordinates of one or more ellipses, in the latter instance a list named by \code{levels}. } \references{ Fox, J. (2016) \emph{Applied Regression Analysis and Generalized Linear Models}, Third Edition. Sage. Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. Monette, G. (1990) Geometry of multiple regression and 3D graphics. In Fox, J. and Long, J. S. (Eds.) \emph{Modern Methods of Data Analysis.} Sage. } \author{Georges Monette, John Fox \email{jfox@mcmaster.ca}, and Michael Friendly.} \seealso{\code{\link{cov.trob}}, \code{\link{cov.wt}}, \code{\link{linearHypothesis}}.} \examples{ dataEllipse(Duncan$income, Duncan$education, levels=0.1*1:9, ellipse.label=0.1*1:9, lty=2, fill=TRUE, fill.alpha=0.1) confidenceEllipse(lm(prestige~income+education, data=Duncan), Scheffe=TRUE) confidenceEllipse(lm(prestige~income+education, data=Duncan), vcov.=hccm) confidenceEllipse(lm(prestige~income+education, data=Duncan), L=c("income + education", "income - education")) wts <- rep(1, nrow(Duncan)) wts[c(6, 16)] <- 0 # delete Minister, Conductor with(Duncan, { dataEllipse(income, prestige, levels=0.68) dataEllipse(income, prestige, levels=0.68, robust=TRUE, plot.points=FALSE, col="green3") dataEllipse(income, prestige, weights=wts, levels=0.68, plot.points=FALSE, col="brown") dataEllipse(income, prestige, weights=wts, robust=TRUE, levels=0.68, plot.points=FALSE, col="blue") }) with(Prestige, dataEllipse(income, education, type, id=list(n=2, labels=rownames(Prestige)), pch=15:17, xlim=c(0, 25000), center.pch="+", group.labels=c("Blue Collar", "Professional", "White Collar"), ylim=c(5, 20), level=.95, fill=TRUE, fill.alpha=0.1)) } \keyword{hplot} \keyword{aplot} car/man/ceresPlots.Rd0000644000176000001440000001160114140261763014237 0ustar ripleyusers\name{ceresPlots} \alias{ceresPlots} \alias{ceresPlots.default} \alias{ceresPlot} \alias{ceresPlot.lm} \alias{ceresPlot.glm} \title{Ceres Plots} \description{ These functions draw Ceres plots for linear and generalized linear models. } \usage{ ceresPlots(model, ...) \method{ceresPlots}{default}(model, terms = ~., layout = NULL, ask, main, ...) ceresPlot(model, ...) \method{ceresPlot}{lm}(model, variable, id=FALSE, line=TRUE, smooth=TRUE, col=carPalette()[1], col.lines=carPalette()[-1], xlab, ylab, pch=1, lwd=2, grid=TRUE, ...) \method{ceresPlot}{glm}(model, ...) } \arguments{ \item{model}{model object produced by \code{lm} or \code{glm}.} \item{terms}{ A one-sided formula that specifies a subset of the regressors. One component-plus-residual plot is drawn for each term. The default \code{~.} is to plot against all numeric predictors. For example, the specification \code{terms = ~ . - X3} would plot against all predictors except for \code{X3}. Factors and nonstandard predictors such as B-splines are skipped. If this argument is a quoted name of one of the regressors, the component-plus-residual plot is drawn for that predictor only. } \item{layout}{ If set to a value like \code{c(1, 1)} or \code{c(4, 3)}, the layout of the graph will have this many rows and columns. If not set, the program will select an appropriate layout. If the number of graphs exceed nine, you must select the layout yourself, or you will get a maximum of nine per page. If \code{layout=NA}, the function does not set the layout and the user can use the \code{par} function to control the layout, for example to have plots from two models in the same graphics window. } \item{ask}{If \code{TRUE}, ask the user before drawing the next plot; if \code{FALSE}, the default, don't ask. This is relevant only if not all the graphs can be drawn in one window.} \item{main}{Overall title for any array of cerers plots; if missing a default is provided.} \item{\dots}{\code{ceresPlots} passes these arguments to \code{ceresPlot}. \code{ceresPlot} passes them to \code{plot}. } \item{variable}{A quoted string giving the name of a variable for the horizontal axis} \item{id}{controls point identification; if \code{FALSE} (the default), no points are identified; can be a list of named arguments to the \code{\link{showLabels}} function; \code{TRUE} is equivalent to \code{list(method=list(abs(residuals(model, type="pearson")), "x"), n=2, cex=1, col=carPalette()[1], location="lr")}, which identifies the 2 points with the largest residuals and the 2 points with the most extreme horizontal (X) values.} \item{line}{\code{TRUE} to plot least-squares line. } \item{smooth}{specifies the smoother to be used along with its arguments; if \code{FALSE}, no smoother is shown; can be a list giving the smoother function and its named arguments; \code{TRUE}, the default, is equivalent to \code{list(smoother=loessLine)}. See \code{\link{ScatterplotSmoothers}} for the smoothers supplied by the \pkg{car} package and their arguments. Ceres plots do not support variance smooths.} \item{col}{color for points; the default is the first entry in the current \pkg{car} palette (see \code{\link{carPalette}} and \code{\link{par}}). } \item{col.lines}{a list of at least two colors. The first color is used for the ls line and the second color is used for the fitted lowess line. To use the same color for both, use, for example, \code{col.lines=c("red", "red")} } \item{xlab,ylab}{labels for the x and y axes, respectively. If not set appropriate labels are created by the function.} \item{pch}{plotting character for points; default is \code{1} (a circle, see \code{\link{par}}). } \item{lwd}{line width; default is \code{2} (see \code{\link{par}}). } \item{grid}{If TRUE, the default, a light-gray background grid is put on the graph } } \details{ Ceres plots are a generalization of component+residual (partial residual) plots that are less prone to leakage of nonlinearity among the predictors. The function intended for direct use is \code{ceresPlots}. The model cannot contain interactions, but can contain factors. Factors may be present in the model, but Ceres plots cannot be drawn for them. } \value{ \code{NULL}. These functions are used for their side effect: producing plots. } \references{ Cook, R. D. and Weisberg, S. (1999) \emph{Applied Regression, Including Computing and Graphics.} Wiley. Fox, J. (2016) \emph{Applied Regression Analysis and Generalized Linear Models}, Third Edition. Sage. Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. } \author{John Fox \email{jfox@mcmaster.ca}} \seealso{\code{\link{crPlots}}, \code{\link{avPlots}}, \code{\link{showLabels}}} \examples{ ceresPlots(lm(prestige~income+education+type, data=Prestige), terms= ~ . - type) } \keyword{hplot} \keyword{regression} car/man/Predict.Rd0000644000176000001440000000503514140261763013512 0ustar ripleyusers\name{Predict} \alias{Predict} \alias{Predict.lm} \title{ Model Predictions } \description{ \code{Predict} is a generic function with, at present, a single method for \code{"lm"} objects, \code{Predict.lm}, which is a modification of the standard \code{\link{predict.lm}} method in the \pkg{stats} package, but with an additional \code{vcov.} argument for a user-specified covariance matrix for intreval estimation. } \usage{ Predict(object, ...) \method{Predict}{lm}(object, newdata, se.fit = FALSE, scale = NULL, df = Inf, interval = c("none", "confidence", "prediction"), level = 0.95, type = c("response", "terms"), terms = NULL, na.action = na.pass, pred.var = res.var/weights, weights = 1, vcov., ...) } \arguments{ \item{object}{a model object for which predictions are desired.} \item{newdata, se.fit, scale, df, interval, level, type, terms, na.action, pred.var, weights}{see \code{\link{predict.lm}}.} \item{vcov.}{optional, either a function to compute the coefficient covariance matrix of \code{object} (e.g., \code{\link{hccm}}) or a coefficient covariance matrix (as returned, e.g., by \code{\link{hccm}}). To use a bootstrap to estimate the covariance matrix, set \code{vcov. = vcov(Boot(object))}.} \item{\dots}{arguments to pass down to \code{Predict} or \code{predict} methods.} } \details{ If there is no appropriate method for \code{Predict}, then a \code{\link{predict}} method is invoked. If there is a \emph{specific} \code{predict} method for the primary class of \code{object} but only an \emph{inherited} \code{Predict} method, then the \code{predict} method is invoked. Thus an object of class \code{c("glm", "lm")} will invoke method \code{predict.glm} rather than \code{Predict.lm}, but an object of class \code{c("aov", "lm")} will invoke \code{Predict.lm} rather than \code{predict.lm}. } \value{ See \code{\link{predict}} and \code{\link{predict.lm}}. } \references{ Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. } \author{ John Fox \email{jfox@mcmaster.ca} } \seealso{ \code{\link{predict}}, \code{\link{predict.lm}} } \examples{ mod <- lm(interlocks ~ log(assets), data=Ornstein) newd <- data.frame(assets=exp(4:12)) (p1 <- predict(mod, newd, interval="prediction")) p2 <- Predict(mod, newd, interval="prediction", vcov.=vcov) all.equal(p1, p2) # the same (predict(mod, newd, se=TRUE)) (p3 <- Predict(mod, newd, se=TRUE, vcov.=hccm)) # larger SEs p4 <- Predict(mod, newd, se=TRUE, vcov.=hccm(mod, type="hc3")) all.equal(p3, p4) # the same } \keyword{models} car/man/linearHypothesis.Rd0000644000176000001440000004635214140261763015461 0ustar ripleyusers%------------------------------------------------------------------------------- % Revision history: % checked in 2008-12-29 by J. Fox (corresponds to version 1.2-10 of car % with function renamed from linear.hypothesis) % 2009-01-16 updated doc to correspond to changes in linearHypothesis. J. Fox % 2009-12-22 updated to reflect changes in linearHypothesis.mlm(). J. Fox % 2010-07-09 added linearHypothesis.polr() and coef.multinom(). J. Fox % 2010-07-27 coef.multinom() no longer exported. J. Fox % 2011-01-21 added linearHypothesis.mer(), linearHypothesis.lme, % matchCoefs() and methods. J. Fox % 2011-06-09 added matchCoefs.mlm(). J. Fox % 2011-11-13 clarification of test argument in linearHypothesis.mlm(). J. Fox % 2012-02-28 added test argument to linearHypothesis.mer(). J. Fox % 2012-03-07 singular.ok argument added to linearHypothesis.mlm(). J. Fox % 2012-11-06 coef. argument added to linearHypothesis.default(), S. Weisberg % 2013-06-20 added .merMod methods to linearHypothesis() and matchCoefs(). J. Fox % 2014-04-23 added aliases for makeHypothesis and printHypothesis % 2014-08-23 added linearHypothesis.rlm. J. Fox % 2016-06-29 noted addition of "value" and "vcov" attributes, added example. J. Fox % 2018-04-11 rhs suppressed using pbkrtest for lmer model. J.Fox % 2020-05-27 added documentation for survreg method. J. Fox % 2020-12-21 added linearHypothesis.lmList(), and small edits. J. Fox %------------------------------------------------------------------------------------ \name{linearHypothesis} \alias{linearHypothesis} \alias{lht} \alias{linearHypothesis.lm} \alias{linearHypothesis.glm} \alias{linearHypothesis.mlm} \alias{linearHypothesis.polr} \alias{linearHypothesis.default} \alias{linearHypothesis.mer} \alias{linearHypothesis.merMod} \alias{linearHypothesis.lme} \alias{linearHypothesis.svyglm} \alias{linearHypothesis.rlm} \alias{linearHypothesis.survreg} \alias{linearHypothesis.lmList} \alias{linearHypothesis.nlsList} \alias{matchCoefs} \alias{matchCoefs.default} \alias{matchCoefs.mer} \alias{matchCoefs.merMod} \alias{matchCoefs.lme} \alias{matchCoefs.mlm} \alias{matchCoefs.lmList} \alias{makeHypothesis} \alias{printHypothesis} \alias{print.linearHypothesis.mlm} \title{Test Linear Hypothesis} \description{ Generic function for testing a linear hypothesis, and methods for linear models, generalized linear models, multivariate linear models, linear and generalized linear mixed-effects models, generalized linear models fit with \code{svyglm} in the \pkg{survey} package, robust linear models fit with \code{rlm} in the \pkg{MASS} package, and other models that have methods for \code{coef} and \code{vcov}. For mixed-effects models, the tests are Wald chi-square tests for the fixed effects. } \usage{ linearHypothesis(model, ...) lht(model, ...) \method{linearHypothesis}{default}(model, hypothesis.matrix, rhs=NULL, test=c("Chisq", "F"), vcov.=NULL, singular.ok=FALSE, verbose=FALSE, coef. = coef(model), suppress.vcov.msg=FALSE, ...) \method{linearHypothesis}{lm}(model, hypothesis.matrix, rhs=NULL, test=c("F", "Chisq"), vcov.=NULL, white.adjust=c(FALSE, TRUE, "hc3", "hc0", "hc1", "hc2", "hc4"), singular.ok=FALSE, ...) \method{linearHypothesis}{glm}(model, ...) \method{linearHypothesis}{lmList}(model, ..., vcov.=vcov, coef.=coef) \method{linearHypothesis}{nlsList}(model, ..., vcov.=vcov, coef.=coef) \method{linearHypothesis}{mlm}(model, hypothesis.matrix, rhs=NULL, SSPE, V, test, idata, icontrasts=c("contr.sum", "contr.poly"), idesign, iterms, check.imatrix=TRUE, P=NULL, title="", singular.ok=FALSE, verbose=FALSE, ...) \method{linearHypothesis}{polr}(model, hypothesis.matrix, rhs=NULL, vcov., verbose=FALSE, ...) \method{print}{linearHypothesis.mlm}(x, SSP=TRUE, SSPE=SSP, digits=getOption("digits"), ...) \method{linearHypothesis}{lme}(model, hypothesis.matrix, rhs=NULL, vcov.=NULL, singular.ok=FALSE, verbose=FALSE, ...) \method{linearHypothesis}{mer}(model, hypothesis.matrix, rhs=NULL, vcov.=NULL, test=c("Chisq", "F"), singular.ok=FALSE, verbose=FALSE, ...) \method{linearHypothesis}{merMod}(model, hypothesis.matrix, rhs=NULL, vcov.=NULL, test=c("Chisq", "F"), singular.ok=FALSE, verbose=FALSE, ...) \method{linearHypothesis}{svyglm}(model, ...) \method{linearHypothesis}{rlm}(model, ...) \method{linearHypothesis}{survreg}(model, hypothesis.matrix, rhs=NULL, test=c("Chisq", "F"), vcov., verbose=FALSE, ...) matchCoefs(model, pattern, ...) \method{matchCoefs}{default}(model, pattern, coef.=coef, ...) \method{matchCoefs}{lme}(model, pattern, ...) \method{matchCoefs}{mer}(model, pattern, ...) \method{matchCoefs}{merMod}(model, pattern, ...) \method{matchCoefs}{mlm}(model, pattern, ...) \method{matchCoefs}{lmList}(model, pattern, ...) } \arguments{ \item{model}{fitted model object. The default method of \code{linearHypothesis} works for models for which the estimated parameters can be retrieved by \code{coef} and the corresponding estimated covariance matrix by \code{vcov}. See the \emph{Details} for more information.} \item{hypothesis.matrix}{matrix (or vector) giving linear combinations of coefficients by rows, or a character vector giving the hypothesis in symbolic form (see \emph{Details}).} \item{rhs}{right-hand-side vector for hypothesis, with as many entries as rows in the hypothesis matrix; can be omitted, in which case it defaults to a vector of zeroes. For a multivariate linear model, \code{rhs} is a matrix, defaulting to 0. This argument isn't available for F-tests for linear mixed models.} \item{singular.ok}{if \code{FALSE} (the default), a model with aliased coefficients produces an error; if \code{TRUE}, the aliased coefficients are ignored, and the hypothesis matrix should not have columns for them. For a multivariate linear model: will return the hypothesis and error SSP matrices even if the latter is singular; useful for computing univariate repeated-measures ANOVAs where there are fewer subjects than df for within-subject effects.} \item{idata}{an optional data frame giving a factor or factors defining the intra-subject model for multivariate repeated-measures data. See \emph{Details} for an explanation of the intra-subject design and for further explanation of the other arguments relating to intra-subject factors.} \item{icontrasts}{names of contrast-generating functions to be applied by default to factors and ordered factors, respectively, in the within-subject ``data''; the contrasts must produce an intra-subject model matrix in which different terms are orthogonal.} \item{idesign}{a one-sided model formula using the ``data'' in \code{idata} and specifying the intra-subject design.} \item{iterms}{the quoted name of a term, or a vector of quoted names of terms, in the intra-subject design to be tested.} \item{check.imatrix}{check that columns of the intra-subject model matrix for different terms are mutually orthogonal (default, \code{TRUE}). Set to \code{FALSE} only if you have \emph{already} checked that the intra-subject model matrix is block-orthogonal.} \item{P}{transformation matrix to be applied to the repeated measures in multivariate repeated-measures data; if \code{NULL} \emph{and} no intra-subject model is specified, no response-transformation is applied; if an intra-subject model is specified via the \code{idata}, \code{idesign}, and (optionally) \code{icontrasts} arguments, then \code{P} is generated automatically from the \code{iterms} argument.} \item{SSPE}{in \code{linearHypothesis} method for \code{mlm} objects: optional error sum-of-squares-and-products matrix; if missing, it is computed from the model. In \code{print} method for \code{linearHypothesis.mlm} objects: if \code{TRUE}, print the sum-of-squares and cross-products matrix for error.} \item{test}{character string, \code{"F"} or \code{"Chisq"}, specifying whether to compute the finite-sample F statistic (with approximate F distribution) or the large-sample Chi-squared statistic (with asymptotic Chi-squared distribution). For a multivariate linear model, the multivariate test statistic to report --- one or more of \code{"Pillai"}, \code{"Wilks"}, \code{"Hotelling-Lawley"}, or \code{"Roy"}, with \code{"Pillai"} as the default.} \item{title}{an optional character string to label the output.} \item{V}{inverse of sum of squares and products of the model matrix; if missing it is computed from the model.} \item{vcov.}{a function for estimating the covariance matrix of the regression coefficients, e.g., \code{\link{hccm}}, or an estimated covariance matrix for \code{model}. See also \code{white.adjust}. For the \code{"lmList"} and \code{"nlsList"} methods, \code{vcov.} must be a function (defaulting to \code{vcov}) to be applied to each model in the list.} \item{coef.}{a vector of coefficient estimates. The default is to get the coefficient estimates from the \code{model} argument, but the user can input any vector of the correct length. For the \code{"lmList"} and \code{"nlsList"} methods, \code{coef.} must be a function (defaulting to \code{coef}) to be applied to each model in the list.} \item{white.adjust}{logical or character. Convenience interface to \code{hccm} (instead of using the argument \code{vcov.}). Can be set either to a character value specifying the \code{type} argument of \code{\link{hccm}} or \code{TRUE}, in which case \code{"hc3"} is used implicitly. The default is \code{FALSE}.} \item{verbose}{If \code{TRUE}, the hypothesis matrix, right-hand-side vector (or matrix), and estimated value of the hypothesis are printed to standard output; if \code{FALSE} (the default), the hypothesis is only printed in symbolic form and the value of the hypothesis is not printed.} \item{x}{an object produced by \code{linearHypothesis.mlm}.} \item{SSP}{if \code{TRUE} (the default), print the sum-of-squares and cross-products matrix for the hypothesis and the response-transformation matrix.} \item{digits}{minimum number of signficiant digits to print.} \item{pattern}{a \link[base:regex]{regular expression} to be matched against coefficient names.} \item{suppress.vcov.msg}{for internal use by methods that call the default method.} \item{...}{arguments to pass down.} } \details{ \code{linearHypothesis} computes either a finite-sample F statistic or asymptotic Chi-squared statistic for carrying out a Wald-test-based comparison between a model and a linearly restricted model. The default method will work with any model object for which the coefficient vector can be retrieved by \code{coef} and the coefficient-covariance matrix by \code{vcov} (otherwise the argument \code{vcov.} has to be set explicitly). For computing the F statistic (but not the Chi-squared statistic) a \code{df.residual} method needs to be available. If a \code{formula} method exists, it is used for pretty printing. The method for \code{"lm"} objects calls the default method, but it changes the default test to \code{"F"}, supports the convenience argument \code{white.adjust} (for backwards compatibility), and enhances the output by the residual sums of squares. For \code{"glm"} objects just the default method is called (bypassing the \code{"lm"} method). The \code{svyglm} method also calls the default method. The function \code{lht} also dispatches to \code{linearHypothesis}. The hypothesis matrix can be supplied as a numeric matrix (or vector), the rows of which specify linear combinations of the model coefficients, which are tested equal to the corresponding entries in the right-hand-side vector, which defaults to a vector of zeroes. Alternatively, the hypothesis can be specified symbolically as a character vector with one or more elements, each of which gives either a linear combination of coefficients, or a linear equation in the coefficients (i.e., with both a left and right side separated by an equals sign). Components of a linear expression or linear equation can consist of numeric constants, or numeric constants multiplying coefficient names (in which case the number precedes the coefficient, and may be separated from it by spaces or an asterisk); constants of 1 or -1 may be omitted. Spaces are always optional. Components are separated by plus or minus signs. Newlines or tabs in hypotheses will be treated as spaces. See the examples below. If the user sets the arguments \code{coef.} and \code{vcov.}, then the computations are done without reference to the \code{model} argument. This is like assuming that \code{coef.} is normally distibuted with estimated variance \code{vcov.} and the \code{linearHypothesis} will compute tests on the mean vector for \code{coef.}, without actually using the \code{model} argument. A linear hypothesis for a multivariate linear model (i.e., an object of class \code{"mlm"}) can optionally include an intra-subject transformation matrix for a repeated-measures design. If the intra-subject transformation is absent (the default), the multivariate test concerns all of the corresponding coefficients for the response variables. There are two ways to specify the transformation matrix for the repeated measures: \enumerate{ \item The transformation matrix can be specified directly via the \code{P} argument. \item A data frame can be provided defining the repeated-measures factor or factors via \code{idata}, with default contrasts given by the \code{icontrasts} argument. An intra-subject model-matrix is generated from the one-sided formula specified by the \code{idesign} argument; columns of the model matrix corresponding to different terms in the intra-subject model must be orthogonal (as is insured by the default contrasts). Note that the contrasts given in \code{icontrasts} can be overridden by assigning specific contrasts to the factors in \code{idata}. The repeated-measures transformation matrix consists of the columns of the intra-subject model matrix corresponding to the term or terms in \code{iterms}. In most instances, this will be the simpler approach, and indeed, most tests of interests can be generated automatically via the \code{\link{Anova}} function. } \code{matchCoefs} is a convenience function that can sometimes help in formulating hypotheses; for example \code{matchCoefs(mod, ":")} will return the names of all interaction coefficients in the model \code{mod}. } \value{ For a univariate model, an object of class \code{"anova"} which contains the residual degrees of freedom in the model, the difference in degrees of freedom, Wald statistic (either \code{"F"} or \code{"Chisq"}), and corresponding p value. The value of the linear hypothesis and its covariance matrix are returned respectively as \code{"value"} and \code{"vcov"} attributes of the object (but not printed). For a multivariate linear model, an object of class \code{"linearHypothesis.mlm"}, which contains sums-of-squares-and-product matrices for the hypothesis and for error, degrees of freedom for the hypothesis and error, and some other information. The returned object normally would be printed. } \references{ Fox, J. (2016) \emph{Applied Regression Analysis and Generalized Linear Models}, Third Edition. Sage. Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. Hand, D. J., and Taylor, C. C. (1987) \emph{Multivariate Analysis of Variance and Repeated Measures: A Practical Approach for Behavioural Scientists.} Chapman and Hall. O'Brien, R. G., and Kaiser, M. K. (1985) MANOVA method for analyzing repeated measures designs: An extensive primer. \emph{Psychological Bulletin} \bold{97}, 316--333. } \author{Achim Zeileis and John Fox \email{jfox@mcmaster.ca}} \seealso{\code{\link{anova}}, \code{\link{Anova}}, \code{\link[lmtest]{waldtest}}, \code{\link{hccm}}, \code{\link[sandwich]{vcovHC}}, \code{\link[sandwich]{vcovHAC}}, \code{\link{coef}}, \code{\link{vcov}} } \examples{ mod.davis <- lm(weight ~ repwt, data=Davis) ## the following are equivalent: linearHypothesis(mod.davis, diag(2), c(0,1)) linearHypothesis(mod.davis, c("(Intercept) = 0", "repwt = 1")) linearHypothesis(mod.davis, c("(Intercept)", "repwt"), c(0,1)) linearHypothesis(mod.davis, c("(Intercept)", "repwt = 1")) ## use asymptotic Chi-squared statistic linearHypothesis(mod.davis, c("(Intercept) = 0", "repwt = 1"), test = "Chisq") ## the following are equivalent: ## use HC3 standard errors via white.adjust option linearHypothesis(mod.davis, c("(Intercept) = 0", "repwt = 1"), white.adjust = TRUE) ## covariance matrix *function* linearHypothesis(mod.davis, c("(Intercept) = 0", "repwt = 1"), vcov = hccm) ## covariance matrix *estimate* linearHypothesis(mod.davis, c("(Intercept) = 0", "repwt = 1"), vcov = hccm(mod.davis, type = "hc3")) mod.duncan <- lm(prestige ~ income + education, data=Duncan) ## the following are all equivalent: linearHypothesis(mod.duncan, "1*income - 1*education = 0") linearHypothesis(mod.duncan, "income = education") linearHypothesis(mod.duncan, "income - education") linearHypothesis(mod.duncan, "1income - 1education = 0") linearHypothesis(mod.duncan, "0 = 1*income - 1*education") linearHypothesis(mod.duncan, "income-education=0") linearHypothesis(mod.duncan, "1*income - 1*education + 1 = 1") linearHypothesis(mod.duncan, "2income = 2*education") mod.duncan.2 <- lm(prestige ~ type*(income + education), data=Duncan) coefs <- names(coef(mod.duncan.2)) ## test against the null model (i.e., only the intercept is not set to 0) linearHypothesis(mod.duncan.2, coefs[-1]) ## test all interaction coefficients equal to 0 linearHypothesis(mod.duncan.2, coefs[grep(":", coefs)], verbose=TRUE) linearHypothesis(mod.duncan.2, matchCoefs(mod.duncan.2, ":"), verbose=TRUE) # equivalent lh <- linearHypothesis(mod.duncan.2, coefs[grep(":", coefs)]) attr(lh, "value") # value of linear function attr(lh, "vcov") # covariance matrix of linear function ## a multivariate linear model for repeated-measures data ## see ?OBrienKaiser for a description of the data set used in this example. mod.ok <- lm(cbind(pre.1, pre.2, pre.3, pre.4, pre.5, post.1, post.2, post.3, post.4, post.5, fup.1, fup.2, fup.3, fup.4, fup.5) ~ treatment*gender, data=OBrienKaiser) coef(mod.ok) ## specify the model for the repeated measures: phase <- factor(rep(c("pretest", "posttest", "followup"), c(5, 5, 5)), levels=c("pretest", "posttest", "followup")) hour <- ordered(rep(1:5, 3)) idata <- data.frame(phase, hour) idata ## test the four-way interaction among the between-subject factors ## treatment and gender, and the intra-subject factors ## phase and hour linearHypothesis(mod.ok, c("treatment1:gender1", "treatment2:gender1"), title="treatment:gender:phase:hour", idata=idata, idesign=~phase*hour, iterms="phase:hour") ## mixed-effects models examples: \dontrun{ library(nlme) example(lme) linearHypothesis(fm2, "age = 0") } \dontrun{ library(lme4) example(glmer) linearHypothesis(gm1, matchCoefs(gm1, "period")) } } \keyword{htest} \keyword{models} \keyword{regression} car/man/boxCox.Rd0000644000176000001440000001525714140261763013371 0ustar ripleyusers\name{boxCox} \alias{boxCox} \alias{boxCox2d} \alias{boxCox.lm} \alias{boxCox.default} \alias{boxCox.formula} \alias{boxCox.bcnPowerTransform} \title{ Graph the profile log-likelihood for Box-Cox transformations in 1D, or in 2D with the bcnPower family. } \description{ Computes and optionally plots profile log-likelihoods for the parameter of the Box-Cox power family, the Yeo-Johnson power family, or for either of the parameters in a bcnPower family. This is a slight generalization of the \code{boxcox} function in the \pkg{MASS} package that allows for families of transformations other than the Box-Cox power family. the \code{boxCox2d} function produces a contour plot of the two-dimensional likelihood profile for the bcnPower family. } \usage{ boxCox(object, ...) \method{boxCox}{default}(object, lambda = seq(-2, 2, 1/10), plotit = TRUE, interp = plotit, eps = 1/50, xlab=NULL, ylab=NULL, main= "Profile Log-likelihood", family="bcPower", param=c("lambda", "gamma"), gamma=NULL, grid=TRUE, ...) \method{boxCox}{formula}(object, lambda = seq(-2, 2, 1/10), plotit = TRUE, family = "bcPower", param = c("lambda", "gamma"), gamma = NULL, grid = TRUE, ...) \method{boxCox}{lm}(object, lambda = seq(-2, 2, 1/10), plotit = TRUE, ...) boxCox2d(x, ksds = 4, levels = c(0.5, 0.95, 0.99, 0.999), main = "bcnPower Log-likelihood", grid=TRUE, ...) } \arguments{ \item{object}{ a formula or fitted model object of class \code{lm} or \code{aov}. } \item{lambda}{ vector of values of \eqn{\lambda}{lambda}, with default (-2, 2) in steps of 0.1, where the profile log-likelihood will be evaluated. } \item{plotit}{ logical which controls whether the result should be plotted; default \code{TRUE}. } \item{interp}{ logical which controls whether spline interpolation is used. Default to \code{TRUE} if plotting with lambda of length less than 100. } \item{eps}{ Tolerance for lambda = 0; defaults to 0.02. } \item{xlab}{ defaults to \code{"lambda"} or \code{"gamma"}. } \item{ylab}{ defaults to \code{"log-Likelihood"} or for bcnPower family to the appropriate label. } \item{family}{ Defaults to \code{"bcPower"} for the Box-Cox power family of transformations. If set to \code{"yjPower"} the Yeo-Johnson family, which permits negative responses, is used. If set to \code{bcnPower} the function gives the profile log-likelihood for the parameter selected via \code{param}. } \item{param}{Relevant only to \code{family="bcnPower"}, produces a profile log-likelihood for the parameter selected, maximizing over the remaining parameter.} \item{gamma}{ For use when the \code{family="bcnPower", param="gamma"}. If this is a vector of positive values, then the profile log-likelihood for the location (or start) parameter in the \code{bcnPower} family is evaluated at these values of gamma. If gamma is \code{NULL}, then evaulation is done at 100 equally spaced points between \code{min(.01, gmax - 3*sd)} and \code{gmax + 3*sd}, where \code{gmax} is the maximimum likelihood estimate of gamma, and \code{sd} is the sd of the response. See \code{\link{bcnPower}} for the definition of \code{gamma}. } \item{grid}{If TRUE, the default, a light-gray background grid is put on the graph. } \item{\dots}{ additional arguments passed to \code{plot}, or to \code{contour} with \code{boxCox2d}. } \item{x}{ An object created by a call to \code{\link{powerTransform}} using \code{family="bcnPower"}. } \item{ksds}{ Contour plotting of the log-likelihood surface will cover plus of minus \code{ksds} standard deviations on each axis. } \item{levels}{ Contours will be drawn at the values of levels. For example, \code{levels=c(.5, .99)} would display two contours, at the 50\% level and at the 99\% level. } \item{main}{ Title for the contour plot or the profile log-likelihood plot } } \details{ The \code{boxCox} function is an elaboration of the \code{\link{boxcox}} function in the \pkg{MASS} package. The first 7 arguments are the same as in \code{boxcox}, and if the argument \code{family="bcPower"} is used, the result is essentially identical to the function in \pkg{MASS}. Two additional families are the \code{yjPower} and \code{bcnPower} families that allow a few values of the response to be non-positive. The bcnPower family has two parameters: a power \eqn{\lambda}{lambda} and a start or location parameter \eqn{\gamma}{gamma}, and the \code{boxCox} function can be used to obtain a profile log-likelihood for either parameter with \eqn{\lambda}{lambda} as the default. Alternatively, the \code{boxCox2d} function can be used to get a contour plot of the profile log-likelihood. } \value{ Both functions ae designed for their side effects of drawing a graph. The \code{boxCox} function returns a list of the lambda (or possibly, gamma) vector and the computed profile log-likelihood vector, invisibly if the result is plotted. If \code{plotit=TRUE} plots log-likelihood vs lambda and indicates a 95\% confidence interval about the maximum observed value of lambda. If \code{interp=TRUE}, spline interpolation is used to give a smoother plot. } \references{ Box, G. E. P. and Cox, D. R. (1964) An analysis of transformations. \emph{Journal of the Royal Statisistical Society, Series B}. 26 211-46. Cook, R. D. and Weisberg, S. (1999) \emph{Applied Regression Including Computing and Graphics}. Wiley. Fox, J. (2016) \emph{Applied Regression Analysis and Generalized Linear Models}, Third Edition. Sage. Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. Hawkins, D. and Weisberg, S. (2017) Combining the Box-Cox Power and Generalized Log Transformations to Accomodate Nonpositive Responses In Linear and Mixed-Effects Linear Models \emph{South African Statistics Journal}, 51, 317-328. Weisberg, S. (2014) \emph{Applied Linear Regression}, Fourth Edition, Wiley. Yeo, I. and Johnson, R. (2000) A new family of power transformations to improve normality or symmetry. \emph{Biometrika}, 87, 954-959. } \author{ Sanford Weisberg, } \seealso{ \code{\link{boxcox}}, \code{\link{yjPower}}, \code{\link{bcPower}}, \code{\link{bcnPower}}, \code{\link{powerTransform}}, \code{\link{contour}} } \examples{ with(trees, boxCox(Volume ~ log(Height) + log(Girth), data = trees, lambda = seq(-0.25, 0.25, length = 10))) data("quine", package = "MASS") with(quine, boxCox(Days ~ Eth*Sex*Age*Lrn, lambda = seq(-0.05, 0.45, len = 20), family="yjPower")) } \keyword{ regression} car/man/crPlots.Rd0000644000176000001440000001226614140261763013552 0ustar ripleyusers\name{crPlots} \alias{crPlots.default} \alias{crPlots} \alias{crp} \alias{crPlot} \alias{crPlot.lm} \title{Component+Residual (Partial Residual) Plots} \description{ These functions construct component+residual plots, also called partial-residual plots, for linear and generalized linear models. } \usage{ crPlots(model, ...) \method{crPlots}{default}(model, terms = ~., layout = NULL, ask, main, ...) crp(...) crPlot(model, ...) \method{crPlot}{lm}(model, variable, id=FALSE, order=1, line=TRUE, smooth=TRUE, col=carPalette()[1], col.lines=carPalette()[-1], xlab, ylab, pch=1, lwd=2, grid=TRUE, ...) } \arguments{ \item{model}{model object produced by \code{lm} or \code{glm}.} \item{terms}{ A one-sided formula that specifies a subset of the regressors. One component-plus-residual plot is drawn for each regressor. The default \code{~.} is to plot against all numeric regressors. For example, the specification \code{terms = ~ . - X3} would plot against all regressors except for \code{X3}, while \code{terms = ~ log(X4)} would give the plot for the predictor X4 that is represented in the model by log(X4). If this argument is a quoted name of one of the predictors, the component-plus-residual plot is drawn for that predictor only.} \item{layout}{ If set to a value like \code{c(1, 1)} or \code{c(4, 3)}, the layout of the graph will have this many rows and columns. If not set, the program will select an appropriate layout. If the number of graphs exceed nine, you must select the layout yourself, or you will get a maximum of nine per page. If \code{layout=NA}, the function does not set the layout and the user can use the \code{par} function to control the layout, for example to have plots from two models in the same graphics window.} \item{ask}{If \code{TRUE}, ask the user before drawing the next plot; if \code{FALSE}, the default, don't ask. This is relevant only if not all the graphs can be drawn in one window.} \item{main}{The title of the plot; if missing, one will be supplied.} \item{\dots}{\code{crPlots} passes these arguments to \code{crPlot}. \code{crPlot} passes them to \code{plot}. } \item{variable}{A quoted string giving the name of a variable for the horizontal axis.} \item{id}{controls point identification; if \code{FALSE} (the default), no points are identified; can be a list of named arguments to the \code{\link{showLabels}} function; \code{TRUE} is equivalent to \code{list(method=list(abs(residuals(model, type="pearson")), "x"), n=2, cex=1, col=carPalette()[1], location="lr")}, which identifies the 2 points with the largest residuals and the 2 points with the most extreme horizontal (X) values.} \item{order}{order of polynomial regression performed for predictor to be plotted; default \code{1}.} \item{line}{\code{TRUE} to plot least-squares line.} \item{smooth}{specifies the smoother to be used along with its arguments; if \code{FALSE}, no smoother is shown; can be a list giving the smoother function and its named arguments; \code{TRUE}, the default, is equivalent to \code{list(smoother=loessLine)}. See \code{\link{ScatterplotSmoothers}} for the smoothers supplied by the \pkg{car} package and their arguments.} \item{col}{color for points; the default is the first entry in the current \pkg{car} palette (see \code{\link{carPalette}} and \code{\link{par}}).} \item{col.lines}{a list of at least two colors. The first color is used for the ls line and the second color is used for the fitted lowess line. To use the same color for both, use, for example, \code{col.lines=c("red", "red")}} \item{xlab,ylab}{labels for the x and y axes, respectively. If not set appropriate labels are created by the function.} \item{pch}{plotting character for points; default is \code{1} (a circle, see \code{\link{par}}).} \item{lwd}{line width; default is \code{2} (see \code{\link{par}}).} \item{grid}{If TRUE, the default, a light-gray background grid is put on the graph.} } \details{ The function intended for direct use is \code{crPlots}, for which \code{crp} is an abbreviation. The model cannot contain interactions, but can contain factors. Parallel boxplots of the partial residuals are drawn for the levels of a factor. } \value{ \code{NULL}. These functions are used for their side effect of producing plots. } \references{ Cook, R. D. and Weisberg, S. (1999) \emph{Applied Regression, Including Computing and Graphics.} Wiley. Fox, J. (2016) \emph{Applied Regression Analysis and Generalized Linear Models}, Third Edition. Sage. Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. } \author{John Fox \email{jfox@mcmaster.ca}} \seealso{\code{\link{ceresPlots}}, \code{\link{avPlots}}} \examples{ crPlots(m<-lm(prestige ~ income + education, data=Prestige)) crPlots(m, terms=~ . - education) # get only one plot crPlots(lm(prestige ~ log2(income) + education + poly(women,2), data=Prestige)) crPlots(glm(partic != "not.work" ~ hincome + children, data=Womenlf, family=binomial), smooth=list(span=0.75)) } \keyword{hplot} \keyword{regression} car/man/powerTransform.Rd0000644000176000001440000002663514140261763015161 0ustar ripleyusers\name{powerTransform} \alias{powerTransform} \alias{powerTransform.default} \alias{powerTransform.lm} \alias{powerTransform.formula} \alias{powerTransform.lmerMod} \title{Finding Univariate or Multivariate Power Transformations} \description{ \code{powerTransform} uses the maximum likelihood-like approach of Box and Cox (1964) to select a transformatiion of a univariate or multivariate response for normality, linearity and/or constant variance. Available families of transformations are the default Box-Cox power family and two additioal families that are modifications of the Box-Cox family that allow for (a few) negative responses. The summary method automatically computes two or three likelihood ratio type tests concerning the transformation powers. } \usage{ powerTransform(object, ...) \S3method{powerTransform}{default}(object, family="bcPower", ...) \S3method{powerTransform}{lm}(object, family="bcPower", ...) \S3method{powerTransform}{formula}(object, data, subset, weights, na.action, family="bcPower", ...) \S3method{powerTransform}{lmerMod}(object, family="bcPower", ...) } \arguments{ \item{object}{This can either be an object of class \code{lm} or \code{lmerMod}, a formula, or a matrix or vector; see below. } \item{family}{The quoted name of a family of transformations. The available options are \code{"bcPower"} for the default for the Box-Cox power family; \code{"bcnPower"} for a two-parameter modification of the Box-Cox family that allows negative responses (Hawkins and Weisberg (2017)), and the \code{"yjPower"} family (Yeo and Johnson(2000)), another modifiation of the Box-Cox family that allows a few negative values. All three families are documented at \code{\link{bcPower}}. } \item{data}{A data frame or environment, as in \sQuote{\link{lm}}.} \item{subset}{Case indices to be used, as in \sQuote{\link{lm}}.} \item{weights}{Weights as in \sQuote{\link{lm}}.} \item{na.action}{Missing value action, as in \sQuote{lm}.} \item{...}{Additional arguments that used in the interative algorithm; defaults are generally adequate. For use with the \code{bcnPower} family, a convergence criterion can be set with \code{conv=.0001} the default, and a minimum positive value of the location parameter can be set, with default \code{gamma.min=.1}.} } \details{This function implements the Box and Cox (1964) method of selecting a power transformation of a variable toward normality, and its generalization by Velilla (1993) to a multivariate response. Cook and Weisberg (1999) and Weisberg (2014) suggest the usefulness of transforming a set of predictors \code{z1, z2, z3} for multivariate normality. It also includes two additional families that allow for negative values. If the \code{object} argument is of class \sQuote{lm} or \sQuote{lmerMod}, the Box-Cox procedure is applied to the conditional distribution of the response given the predictors. For \sQuote{lm} objects, the respose may be multivariate, and each column will have its own transformation. With \sQuote{lmerMod} the response must be univariate. The \code{object} argument may also be a formula. For example, \code{z ~ x1 + x2 + x3} will estimate a transformation for the response \code{z} from a family after fitting a linear model with the given formula. \code{cbind(y1, y2, y3) ~ 1} specifies transformations to multivariate normality with no predictors. A vector value for \code{object}, for example \code{powerTransform(ais$LBM)}, is equivalent to\code{powerTransform(LBM ~ 1, ais)}. Similarly, \code{powerTransform(cbind(ais$LBM, ais$SSF))}, where the first argument is a matrix rather than a formula is equivalent to specification of a mulitvariate linear model \code{powerTransform(cbind(LBM, SSF) ~ 1, ais)}. Three families of power transformations are available. The default Box-Cox power family (\code{family="bcPower"}) of power transformations effectively replaces a vector by that vector raised to a power, generally in the range from -3 to 3. For powers close to zero, the log-transformtion is suggested. In practical situations, after estimating a power using the \code{powerTransform} function, a variable would be replaced by a simple power transformation of it, for example, if \eqn{\lambda\approx 0.5}{lamba is about 0.5}, then the correspoding variable would be replaced by its square root; if \eqn{\lambda}{\lambda} is close enough to zero, the the variable would be replaced by its natural logarithm. The Box-Cox family requires the responses to be strictly positive. The \code{family="bcnPower"}, or Box-Cox with negatives, family proposed by Hawkins and Weisberg (2017) allows for (a few) non-positive values, while allowing for the transformed data to be interpreted similarly to the interpretation of Box-Cox transformed values. This family is the Box-Cox transformation of \eqn{z = .5 * (y + (y^2 + \gamma^2)^{1/2})} that depends on a location parameter \eqn{\gamma}. The quantity \eqn{z} is positive for all values of \eqn{y}. If \eqn{\gamma = 0} and \eqn{y} is strictly positive, then the Box-Cox and the bcnPower transformations are identical. When fitting the Box-Cox with negatives family, \code{lambda} is restricted to the range [-3, 3], and \code{gamma} is restricted to the range from \code{gamma.min=.1} to the largest positive value of the variable, since values outside these ranges are unreasonable in practice. The value of \code{gamma.min} can be changed with an argument to \code{powerTransform}. The final family \code{family="yjPower"} uses the Yeo-Johnson transformation, which is the Box-Cox transformation of \eqn{U+1} for nonnegative values, and of \eqn{|U|+1} with parameter \eqn{2-\lambda}{2-lambda} for \eqn{U} negative and thus it provides a family for fitting when (a few) observations are negative. Because of the unusual constraints on the powers for positive and negative data, this transformation is not used very often, as results are difficult to interpret. In practical problems, a variable would be replaced by its Yeo-Johnson transformation computed using the \code{\link{yjPower}} function. The function \code{\link{testTransform}} is used to obtain likelihood ratio tests for any specified value for the transformation parameter(s). Computations maximize the likelihood-like functions described by Box and Cox (1964) and by Velilla (1993). For univariate responses, the computations are very stable and problems are unlikely, although for \sQuote{lmer} models computations may be very slow because the model is refit many times. For multivariate responses with the \code{bcnPower} family, the computing algorithm may fail. In this case we recommend adding the argument \code{itmax = 1} to the call to \code{powerTransform}. This will return the starting value estimates of the transformation parameters, fitting a d-dimensional response as if all the d responses were independent. } \value{ An object of class \code{powerTransform} or class \code{bcnPowerTransform} if \code{family="bcnPower"} that inherits from \code{powerTransform} is returned, including the components listed below. A \code{summary} method presents estimated values for the transformation power \code{lambda} and for the \sQuote{bcnPower} family the location parameter \code{gamma} as well. Standard errors and Wald 95\% confidence intervals based on the standard errors are computed from the inverse of the sample Hessian matrix evaluted at the estimates. The interval estimates for the \code{gamma} parameters will generally be very wide, reflecting little information available about the location parameter. Likelihood ratio type tests are also provided. For the \sQuote{bcnPower} family these are based on the profile loglikelihood for \code{lambda} alone; that is, we treat \code{gamma} as a nusiance parameter and average over it. The components of the returned object includes \item{lambda}{Estimated transformation parameter} \item{roundlam}{Convenient rounded values for the estimates. These rounded values will usually be the desired transformations.} \item{gamma}{Estimated location parameters for \code{bcnPower}, \code{NULL} otherwise} \item{invHess}{Estimated covariance matrix of the estimated parameters} \item{llik}{Value of the log-likelihood at the estimates} The \code{summary} method for \code{powerTransform} returns an array with columns labeled "Est Power" for the value of \code{lambda} that maximizes the likelihood; "Rounded Pwr" for \code{roundlam}, and columns "Wald Lwr Bnd" and "Wald Ur Bnd" for a 95 percent Wald normal theory confidence interval for \code{lambda} computed as the estimate plus or minus 1.96 times the standard error. } \references{Box, G. E. P. and Cox, D. R. (1964) An analysis of transformations. \emph{Journal of the Royal Statisistical Society, Series B}. 26 211-46. Cook, R. D. and Weisberg, S. (1999) \emph{Applied Regression Including Computing and Graphics}. Wiley. Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. Hawkins, D. and Weisberg, S. (2017) Combining the Box-Cox Power and Generalized Log Transformations to Accomodate Nonpositive Responses In Linear and Mixed-Effects Linear Models \emph{South African Statistics Journal}, 51, 317-328. Velilla, S. (1993) A note on the multivariate Box-Cox transformation to normality. \emph{Statistics and Probability Letters}, 17, 259-263. Weisberg, S. (2014) \emph{Applied Linear Regression}, Fourth Edition, Wiley. Yeo, I. and Johnson, R. (2000) A new family of power transformations to improve normality or symmetry. \emph{Biometrika}, 87, 954-959. } \author{ Sanford Weisberg, } \seealso{\code{\link{testTransform}}, \code{\link{bcPower}}, \code{\link{bcnPower}}, \code{\link{transform}}, \code{\link{optim}}, \code{\link{boxCox}}. } \examples{ # Box Cox Method, univariate summary(p1 <- powerTransform(cycles ~ len + amp + load, Wool)) # fit linear model with transformed response: coef(p1, round=TRUE) summary(m1 <- lm(bcPower(cycles, p1$roundlam) ~ len + amp + load, Wool)) # Multivariate Box Cox uses Highway1 data summary(powerTransform(cbind(len, adt, trks, sigs1) ~ 1, Highway1)) # Multivariate transformation to normality within levels of 'htype' summary(a3 <- powerTransform(cbind(len, adt, trks, sigs1) ~ htype, Highway1)) # test lambda = (0 0 0 -1) testTransform(a3, c(0, 0, 0, -1)) # save the rounded transformed values, plot them with a separate # color for each highway type transformedY <- bcPower(with(Highway1, cbind(len, adt, trks, sigs1)), coef(a3, round=TRUE)) \dontrun{scatterplotMatrix( ~ transformedY|htype, Highway1) } # With negative responses, use the bcnPower family m2 <- lm(I1L1 ~ pool, LoBD) summary(p2 <- powerTransform(m2, family="bcnPower")) testTransform(p2, .5) summary(powerTransform(update(m2, cbind(LoBD$I1L2, LoBD$I1L1) ~ .), family="bcnPower")) \dontrun{ # takes a few seconds: # multivariate bcnPower, with 8 responses summary(powerTransform(update(m2, as.matrix(LoBD[, -1]) ~ .), family="bcnPower")) # multivariate bcnPower, fit with one iteration using starting values as estimates summary(powerTransform(update(m2, as.matrix(LoBD[, -1]) ~ .), family="bcnPower", itmax=1)) } # mixed effects model \dontrun{ # uses the lme4 package data <- reshape(LoBD[1:20, ], varying=names(LoBD)[-1], direction="long", v.names="y") names(data) <- c("pool", "assay", "y", "id") data$assay <- factor(data$assay) require(lme4) m2 <- lmer(y ~ pool + (1|assay), data) summary(l2 <- powerTransform(m2, family="bcnPower", verbose=TRUE)) } } \keyword{ regression}% at least one, from doc/KEYWORDS car/man/vif.Rd0000644000176000001440000000540214140261763012702 0ustar ripleyusers\name{vif} \alias{vif} \alias{vif.default} \alias{vif.merMod} \alias{vif.polr} \alias{vif.svyolr} \title{Variance Inflation Factors} \description{ Calculates variance-inflation and generalized variance-inflation factors (VIFs and GVIFs) for linear, generalized linear, and other regression models. } \usage{ vif(mod, ...) \method{vif}{default}(mod, ...) \method{vif}{merMod}(mod, ...) \method{vif}{polr}(mod, ...) \method{vif}{svyolr}(mod, ...) } \arguments{ \item{mod}{for the default method, an object that responds to \code{\link{coef}}, \code{\link{vcov}}, and \code{\link{model.matrix}}, such as an \code{lm} or \code{glm} object.} \item{\dots}{not used.} } \details{ If all terms in an unweighted linear model have 1 df, then the usual variance-inflation factors are calculated. If any terms in an unweighted linear model have more than 1 df, then generalized variance-inflation factors (Fox and Monette, 1992) are calculated. These are interpretable as the inflation in size of the confidence ellipse or ellipsoid for the coefficients of the term in comparison with what would be obtained for orthogonal data. The generalized vifs are invariant with respect to the coding of the terms in the model (as long as the subspace of the columns of the model matrix pertaining to each term is invariant). To adjust for the dimension of the confidence ellipsoid, the function also prints \eqn{GVIF^{1/(2\times df)}}{GVIF^[1/(2*df)]} where \eqn{df} is the degrees of freedom associated with the term. Through a further generalization, the implementation here is applicable as well to other sorts of models, in particular weighted linear models, generalized linear models, and mixed-effects models. Specific methods are provided for ordinal regression model objects produced by \code{\link[MASS:polr]{polr}} in the \pkg{MASS} package and \code{\link[survey:svyolr]{svyolr}} in the \pkg{survey} package, which are "intercept-less"; VIFs or GVIFs for linear and similar regression models without intercepts are generally not sensible. } \value{ A vector of vifs, or a matrix containing one row for each term in the model, and columns for the GVIF, df, and \eqn{GVIF^{1/(2\times df)}}{GVIF^[1/(2*df)]}. } \references{ Fox, J. and Monette, G. (1992) Generalized collinearity diagnostics. \emph{JASA}, \bold{87}, 178--183. Fox, J. (2016) \emph{Applied Regression Analysis and Generalized Linear Models}, Third Edition. Sage. Fox, J. and Weisberg, S. (2018) \emph{An R Companion to Applied Regression}, Third Edition, Sage. } \author{Henric Nilsson and John Fox \email{jfox@mcmaster.ca}} \examples{ vif(lm(prestige ~ income + education, data=Duncan)) vif(lm(prestige ~ income + education + type, data=Duncan)) } \keyword{regression} car/man/Boot.Rd0000644000176000001440000001653714140261763013034 0ustar ripleyusers\name{Boot} \alias{Boot} \alias{Boot.default} \alias{Boot.lm} \alias{Boot.glm} \alias{Boot.nls} \title{Bootstrapping for regression models } \description{ This function provides a simple front-end to the \code{boot} function in the \pkg{boot} package that is tailored to bootstrapping based on regression models. Whereas \code{boot} is very general and therefore has many arguments, the \code{Boot} function has very few arguments. } \usage{ Boot(object, f=coef, labels=names(f(object)), R=999, method=c("case", "residual"), ncores=1, \dots) \S3method{Boot}{default}(object, f=coef, labels=names(f(object)), R=999, method=c("case", "residual"), ncores=1, start = FALSE, \dots) \S3method{Boot}{lm}(object, f=coef, labels=names(f(object)), R=999, method=c("case", "residual"), ncores=1, \dots) \S3method{Boot}{glm}(object, f=coef, labels=names(f(object)), R=999, method=c("case", "residual"), ncores=1, \dots) \S3method{Boot}{nls}(object, f=coef, labels=names(f(object)), R=999, method=c("case", "residual"), ncores=1, \dots) } \arguments{ \item{object}{A regression object of class \code{"lm"}, \code{"glm"} or \code{"nls"}. The function may work with other regression objects that support the \code{update} method and have a \code{subset} argument. See discussion of the default method in the details below.} \item{f}{A function whose one argument is the name of a regression object that will be applied to the updated regression object to compute the statistics of interest. The default is \code{coef}, to return regression coefficient estimates. For example, \code{f = function(obj) coef(obj)[1]/coef(obj)[2]} will bootstrap the ratio of the first and second coefficient estimates.} \item{labels}{Provides labels for the statistics computed by \code{f}. Default labels are obtained from a call to \code{f}, or generic labels if \code{f} does not return names.} \item{R}{Number of bootstrap samples. The number of bootstrap samples actually computed may be smaller than this value if either the fitting method is iterative and fails to converge for some boothstrap samples, or if the rank of a fitted model is different in a bootstrap replication than in the original data.} \item{method}{The bootstrap method, either \dQuote{case} for resampling cases or \dQuote{residuals} for a residual bootstrap. See the details below. The residual bootstrap is available only for \code{lm} and \code{nls} objects and will return an error for \code{glm} objects.} \item{\dots}{Arguments passed to the \code{boot} function, see \code{\link{boot}}.} \item{start}{Should the estimates returned by \code{f} be passed as starting values for each bootstrap iteration? Alternatively, \code{start} can be a numeric vector of starting values. The default is to use the estimates from the last bootstrap iteration as starting values for the next iteration.} \item{ncores}{A numeric argument that specifies the number of cores for parallel processing for unix systems. If less than or equal to 1, no parallel processing wiill be used. Note in a Windows platform will produce a warning and set this argument to 1.} } \details{ \code{Boot} uses a regression object and the choice of \code{method}, and creates a function that is passed as the \code{statistic} argument to the \code{boot} function in the \pkg{boot} package. The argument \code{R} is also passed to \code{boot}. If \code{ncores} is greater than 1, then the \code{parallel} and \code{ncpus} arguments to \code{boot} are set appropriately to use multiple codes, if available, on your computer. All other arguments to \code{boot} are kept at their default values unless you pass values for them. The methods available for \code{lm} and \code{nls} objects are \dQuote{case} and \dQuote{residual}. The case bootstrap resamples from the joint distribution of the terms in the model and the response. The residual bootstrap fixes the fitted values from the original data, and creates bootstraps by adding a bootstrap sample of the residuals to the fitted values to get a bootstrap response. It is an implementation of Algorithm 6.3, page 271, of Davison and Hinkley (1997). For \code{nls} objects ordinary residuals are used in the resampling rather than the standardized residuals used in the \code{lm} method. The residual bootstrap for generalized linear models has several competing approaches, but none are without problems. If you want to do a residual bootstrap for a glm, you will need to write your own call to \code{boot}. For the default object to work with other types of regression models, the model must have methods for the the following generic functions: \code{residuals(object, type="pearson")} must return Pearson residuals; \code{fitted(object)} must return fitted values; \code{hatvalues(object)} should return the leverages, or perhaps the value 1 which will effectively ignore setting the hatvalues. In addition, the \code{data} argument should contain no missing values among the columns actually used in fitting the model, as the resampling may incorrectly attempt to include cases with missing values. For \code{lm}, \code{glm} and \code{nls}, missing values cause the return of an error message. An attempt to fit using a bootstrap sample may fail. In a \code{lm} or \code{glm} fit, the bootstrap sample could have a different rank from the original fit. In an \code{nls} fit, convergence may not be obtained for some bootstraps. In either case, \code{NA} are returned for the value of the function \code{f}. The summary methods handle the \code{NA}s appropriately. Fox and Weisberg (2017) cited below discusses this function and provides more examples. } \value{ See \code{\link{boot}} for the returned value of the structure returned by this function. } \section{Warning}{ C=A call like \code{car::Boot(object, method="residual")} will fail for the residual method if not preceded by \code{library(car)}. If \code{method="case"} the \code{library(car)} command is not required. } \references{ Davison, A, and Hinkley, D. (1997) \emph{Bootstrap Methods and their Applications}. Oxford: Oxford University Press. Fox, J. and Weisberg, S. (2019) \emph{Companion to Applied Regression}, Third Edition. Thousand Oaks: Sage. Fox, J. and Weisberg, S. (2019) \emph{Bootstrapping Regression Models in R}, \url{https://socialsciences.mcmaster.ca/jfox/Books/Companion/appendices/Appendix-Bootstrapping.pdf}. Weisberg, S. (2014) \emph{Applied Linear Regression}, Fourth Edition, Wiley Wiley, Chapters 4 and 11.} \author{ Sanford Weisberg, \email{sandy@umn.edu}. Achim Zeileis added multicore support, and also fixed the default method to work for many more regression models.} \seealso{Functions that work with \code{boot} objects from the \pkg{boot} package are \code{\link{boot.array}}, \code{\link{boot.ci}}, \code{\link{plot.boot}} and \code{\link{empinf}}. Additional functions in the \pkg{car} package are \code{\link{summary.boot}}, \code{\link{confint.boot}}, and \code{\link{hist.boot}}. } \examples{ m1 <- lm(Fertility ~ ., swiss) betahat.boot <- Boot(m1, R=199) # 199 bootstrap samples--too small to be useful summary(betahat.boot) # default summary confint(betahat.boot) hist(betahat.boot) # Bootstrap for the estimated residual standard deviation: sigmahat.boot <- Boot(m1, R=199, f=sigmaHat, labels="sigmaHat") summary(sigmahat.boot) confint(sigmahat.boot) } \keyword{regression}% at least one, from doc/KEYWORDS car/man/dfbetaPlots.Rd0000644000176000001440000000745414140261763014376 0ustar ripleyusers\name{dfbetaPlots} \alias{dfbetaPlots} \alias{dfbetasPlots} \alias{dfbetaPlots.lm} \alias{dfbetasPlots.lm} \title{dfbeta and dfbetas Index Plots} \description{ These functions display index plots of dfbeta (effect on coefficients of deleting each observation in turn) and dfbetas (effect on coefficients of deleting each observation in turn, standardized by a deleted estimate of the coefficient standard error). In the plot of dfbeta, horizontal lines are drawn at 0 and +/- one standard error; in the plot of dfbetas, horizontal lines are drawn and 0 and +/- 1. } \usage{ dfbetaPlots(model, ...) dfbetasPlots(model, ...) \method{dfbetaPlots}{lm}(model, terms= ~ ., intercept=FALSE, layout=NULL, ask, main, xlab, ylab, labels=rownames(dfbeta), id.method="y", id.n=if(id.method[1]=="identify") Inf else 0, id.cex=1, id.col=carPalette()[1], id.location="lr", col=carPalette()[1], grid=TRUE, ...) \method{dfbetasPlots}{lm}(model, terms=~., intercept=FALSE, layout=NULL, ask, main, xlab, ylab, labels=rownames(dfbetas), id.method="y", id.n=if(id.method[1]=="identify") Inf else 0, id.cex=1, id.col=carPalette()[1], id.location="lr", col=carPalette()[1], grid=TRUE, ...) } \arguments{ \item{model}{model object produced by \code{lm} or \code{glm}. } \item{terms}{ A one-sided formula that specifies a subset of the terms in the model. One dfbeta or dfbetas plot is drawn for each regressor. The default \code{~.} is to plot against all terms in the model with the exception of an intercept. For example, the specification \code{terms = ~.-X3} would plot against all terms except for \code{X3}. If this argument is a quoted name of one of the terms, the index plot is drawn for that term only. } \item{intercept}{Include the intercept in the plots; default is \code{FALSE}.} \item{layout}{ If set to a value like \code{c(1, 1)} or \code{c(4, 3)}, the layout of the graph will have this many rows and columns. If not set, the program will select an appropriate layout. If the number of graphs exceed nine, you must select the layout yourself, or you will get a maximum of nine per page. If \code{layout=NA}, the function does not set the layout and the user can use the \code{par} function to control the layout, for example to have plots from two models in the same graphics window. } \item{main}{The title of the graph; if missing, one will be supplied. } \item{xlab}{Horizontal axis label; defaults to \code{"Index"}.} \item{ylab}{Vertical axis label; defaults to coefficient name.} \item{ask}{If \code{TRUE}, ask the user before drawing the next plot; if \code{FALSE}, the default, don't ask. } \item{\dots}{optional additional arguments to be passed to \code{\link{plot}}, \code{\link{points}}, and \code{\link{showLabels}}}. \item{id.method, labels, id.n, id.cex, id.col, id.location}{Arguments for the labelling of points. The default is \code{id.n=0} for labeling no points. See \code{\link{showLabels}} for details of these arguments. } \item{col}{color for points; defaults to the first entry in the color \code{\link{carPalette}}.} \item{grid}{If \code{TRUE}, the default, a light-gray background grid is put on the graph} } \value{ \code{NULL}. These functions are used for their side effect: producing plots. } \references{ Fox, J. (2016) \emph{Applied Regression Analysis and Generalized Linear Models}, Third Edition. Sage. Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. } \author{John Fox \email{jfox@mcmaster.ca}} \seealso{\code{\link{dfbeta}} ,\code{\link{dfbetas}}} \examples{ dfbetaPlots(lm(prestige ~ income + education + type, data=Duncan)) dfbetasPlots(glm(partic != "not.work" ~ hincome + children, data=Womenlf, family=binomial)) } \keyword{hplot} \keyword{regression} car/man/Import.Rd0000644000176000001440000000511714140314472013367 0ustar ripleyusers\name{Import} \alias{Import} \title{ Import data from many file formats } \description{ Uses the \code{import} function from the \pkg{rio} package to read a data.frame from a variety of file types. The \code{Import} function includes 2 additional arguments adding row names and for converting character and logical variables to factors for some file types.} \usage{ Import(file, format, ..., row.names=TRUE, stringsAsFactors = FALSE) } \arguments{ \item{file}{ A character string naming a file, URL, or .zip or .tar archive. See the details below. If the file name has an extension like \code{.xlsx} or \code{.csv} then the type of file is inferred from the extension. } \item{format}{ If an extension is not present in the file name or it is wrong, the file format can be set with this argument; see \code{\link[rio]{import}}. } \item{\dots}{ Additional arguments passed to \code{\link[rio]{import}}. } \item{row.names}{ If \code{TRUE}, the default, the left-most character variable that has all unique elements is removed from the data frame and set to be \code{row.names}. To match \code{import}, set \code{row.names=FALSE}. } \item{stringsAsFactors}{ If \code{TRUE}, then character variables that do not have all unique elements are converted to factors. The default is \code{FALSE}. Prior to May 2020 the default was determined by \code{getOption("stringsAsFactors")}, which then defaulted to \code{TRUE}. This option is \code{FALSE} in R 4.0.0 and has been deprecated.} } \details{ This function calls the \code{\link[rio]{import}} function to read a data frame from a file. Many file types are supported. For files of type \code{"txt", "csv", "xlsx", "xls"} or \code{ "ods"} the arguments \code{row.names} and \code{stringsAsFactors} can be used to add row names and convert character variables to factors, respectively. Many more details are given on the man page for \code{import}. } \value{ A data frame. See \code{\link[rio]{import}} for more details } \author{Sanford Weisberg \email{sandy@umn.edu}} \seealso{ \code{\link[rio]{import}}, \code{\link{Export}}, \code{\link{strings2factors}} } \examples{ if(require("rio")) { head(Duncan, 3) # first three rows Export(Duncan, "Duncan.csv", keep.row.names="occupation") Duncan2 <- Import("Duncan.csv") # Automatically restores row.names and factors brief(Duncan2) identical(Duncan, Duncan2) # FALSE because type is of a different class Duncan3 <- Import("Duncan.csv", stringsAsFactors=TRUE) brief(Duncan3) identical(Duncan, Duncan3) # TRUE type is of same class # cleanup unlink("Duncan.csv") } } \keyword{ utilities } \keyword{ connections } car/man/deltaMethod.Rd0000644000176000001440000002435414140261763014357 0ustar ripleyusers\name{deltaMethod} \alias{deltaMethod} \alias{deltaMethod.default} \alias{deltaMethod.lm} \alias{deltaMethod.nls} \alias{deltaMethod.multinom} \alias{deltaMethod.polr} \alias{deltaMethod.survreg} \alias{deltaMethod.coxph} \alias{deltaMethod.mer} \alias{deltaMethod.merMod} \alias{deltaMethod.lme} \alias{deltaMethod.lmList} \title{Estimate and Standard Error of a Nonlinear Function of Estimated Regression Coefficients} \description{ \code{deltaMethod} is a generic function that uses the delta method to get a first-order approximate standard error for a nonlinear function of a vector of random variables with known or estimated covariance matrix. } \usage{ deltaMethod(object, ...) \method{deltaMethod}{default}(object, g., vcov., func=g., constants, level=0.95, rhs, ..., envir=parent.frame()) \method{deltaMethod}{lm} (object, g., vcov.=vcov(object, complete=FALSE), parameterNames=names(coef(object)), ..., envir=parent.frame()) \method{deltaMethod}{nls}(object, g., vcov.=vcov(object, complete=FALSE), ..., envir=parent.frame()) \method{deltaMethod}{multinom} (object, g., vcov. = vcov(object, complete=FALSE), parameterNames = if (is.matrix(coef(object))) colnames(coef(object)) else names(coef(object)), ..., envir=parent.frame()) \method{deltaMethod}{polr} (object, g., vcov.=vcov(object, complete=FALSE), ..., envir=parent.frame()) \method{deltaMethod}{survreg} (object, g., vcov. = vcov(object, complete=FALSE), parameterNames = names(coef(object)), ..., envir=parent.frame()) \method{deltaMethod}{coxph} (object, g., vcov. = vcov(object, complete=FALSE), parameterNames = names(coef(object)), ..., envir=parent.frame()) \method{deltaMethod}{mer} (object, g., vcov. = vcov(object, complete=FALSE), parameterNames = names(fixef(object)), ..., envir=parent.frame()) \method{deltaMethod}{merMod} (object, g., vcov. = vcov(object, complete=FALSE), parameterNames = names(fixef(object)), ..., envir=parent.frame()) \method{deltaMethod}{lme} (object, g., vcov. = vcov(object, complete=FALSE), parameterNames = names(fixef(object)), ..., envir=parent.frame()) \method{deltaMethod}{lmList} (object, g., ..., envir=parent.frame()) } \arguments{ \item{object}{For the default method, \code{object} is either (1) a vector of \code{p} named elements, so \code{names(object)} returns a list of \code{p} character strings that are the names of the elements of \code{object}; or (2) a model object for which there are \code{\link{coef}} and \code{\link{vcov}} methods, and for which the named coefficient vector returned by \code{coef} is asymptotically normally distributed with asymptotic covariance matrix returned by \code{vcov}. For the other methods, \code{object} is a regression object for which \code{coef(object)} or \code{fixef(object)} returns a vector of parameter estimates.} \item{g.}{A quoted string that is the function of the parameter estimates to be evaluated; see the details below. } \item{vcov.}{The (estimated) covariance matrix of the coefficient estimates. For the default method, this argument is required. For all other methods, this argument must either provide the estimated covariance matrix or a function that when applied to \code{object} returns a covariance matrix. The default is to use the function \code{vcov}.} \item{func}{A quoted string used to annotate output. The default of \code{func = g.} is usually appropriate.} \item{parameterNames}{A character vector of length \code{p} that gives the names of the parameters in the same order as they appear in the vector of estimates. This argument will be useful if some of the names in the vector of estimates include special characters, like \code{I(x2^2)}, or \code{x1:x2} that will confuse the numerical differentiation function. See details below.} \item{constants}{This argument is a named vector whose elements are constants that are used in the \code{f} argument. It isn't generally necessary to specify this argument but it may be convenient to do so.} \item{level}{level for confidence interval, default \code{0.95}.} \item{rhs}{hypothesized value for the specified function of parameters; if absent no hypothesis test is performed.} \item{...}{Used to pass arguments to the generic method.} \item{envir}{Environment in which \code{g.} is evaluated; not normally specified by the user.} } \details{ Suppose \eqn{x} is a random vector of length \eqn{p} that is at least approximately normally distributed with mean \eqn{\beta} and estimated covariance matrix \eqn{C}. Then any function \eqn{g(\beta)} of \eqn{\beta}, is estimated by \eqn{g(x)}, which is in large samples normally distributed with mean \eqn{g(\beta)} and estimated variance \eqn{h'Ch}, where \eqn{h} is the first derivative of \eqn{g(\beta)} with respect to \eqn{\beta} evaluated at \eqn{x}. This function returns both \eqn{g(x)} and its standard error, the square root of the estimated variance. The default method requires that you provide \eqn{x} in the argument \code{object}, \eqn{C} in the argument \code{vcov.}, and a text expression in argument \code{g.} that when evaluated gives the function \eqn{g}. The call \code{names(object)} must return the names of the elements of \code{x} that are used in the expression \code{g.}. Since the delta method is often applied to functions of regression parameter estimates, the argument \code{object} may be the name of a regression object from which the estimates and their estimated variance matrix can be extracted. In most regression models, estimates are returned by the \code{coef(object)} and the variance matrix from \code{vcov(object)}. You can provide an alternative function for computing the sample variance matrix, for example to use a sandwich estimator. For mixed models using \code{lme4} or \code{nlme}, the coefficient estimates are returned by the \code{fixef} function, while for \code{multinom}, \code{lmList} and \code{nlsList} coefficient estimates are returned by \code{coef} as a matrix. Methods for these models are provided to get the correct estimates and variance matrix. The argument \code{g.} must be a quoted character string that gives the function of interest. For example, if you set \code{m2 <- lm(Y ~ X1 + X2 + X1:X2)}, then \code{deltaMethod(m2,"X1/X2")} applies the delta method to the ratio of the coefficient estimates for \code{X1} and \code{X2}. The argument \code{g.} can consist of constants and names associated with the elements of the vector of coefficient estimates. In some cases the names may include characters such as the colon \code{:} used in interactions, or mathematical symbols like \code{+} or \code{-} signs that would confuse the function that computes numerical derivatives, and for this case you can replace the names of the estimates with the \code{parameterNames} argument. For example, the ratio of the \code{X2} main effect to the interaction term could be computed using \code{deltaMethod(m2, "b1/b3", parameterNames=c("b0", "b1", "b2", "b3"))}. The name \dQuote{\code{(Intercept)}} used for the intercept in linear and generalized linear models is an exception, and it will be correctly interpreted by \code{deltaMethod}. Another option is to use back-ticks to quote nonstandard R names, as in \code{deltaMethod(m2,"X1/`X1:X2`")}. For \code{multinom} objects, the \code{coef} function returns a matrix of coefficients, with each row giving the estimates for comparisons of one category to the baseline. The \code{deltaMethod} function applies the delta method to each row of this matrix. Similarly, for \code{lmList} and \code{nlsList} objects, the delta method is computed for each element of the list of models fit. For nonlinear regression objects produced by the \code{nls} function, the call \code{coef(object)} returns the estimated coefficient vectors with names corresponding to parameter names. For example, \code{m2 <- nls(y ~ theta/(1 + gamma * x), start = list(theta=2, gamma=3))} will have parameters named \code{c("theta", "gamma")}. In many other familiar regression models, such as those produced by \code{lm} and \code{glm}, the names of the coefficient estimates are the corresponding regressor names, not parameter names. For mixed-effects models fit with \code{lmer} and \code{glmer} from the \pkg{lme4} package or \code{lme} and \code{nlme} from the \pkg{nlme} package, only fixed-effect coefficients are considered. For regression models for which methods are not provided, you can extract the named vector of coefficient estimates and and estimate of its covariance matrix and then apply the default \code{deltaMethod} function. \emph{Note:} Earlier versions of \code{deltaMethod} included an argument \code{parameterPrefix} that implemented the same functionality as the \code{parameterNames} argument, but which caused several problems that were not easily fixed without the change in syntax. } \value{ An object of class \code{"deltaMethod"}, inheriting from \code{"data.frame"}, for which a \code{print} method is provided. The object contains columns named \code{Estimate} for the estimate, \code{SE} for its standard error, and columns for confidence limits and possibly a hypothesis test. The value of \code{g.} is given as a row label. } \seealso{First derivatives of \code{g.} are computed using symbolic differentiation by the function \code{\link{D}}.} \references{ Fox, J. (2016) \emph{Applied Regression Analysis and Generalized Linear Models}, Third Edition. Sage. Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. Weisberg, S. (2014) \emph{Applied Linear Regression}, Fourth Edition, Wiley, Section 6.1.2. } \author{Sanford Weisberg, \email{sandy@umn.edu}, John Fox \email{jfox@mcmaster.ca}, and Pavel Krivitsky.} \examples{ m1 <- lm(time ~ t1 + t2, data = Transact) deltaMethod(m1, "b1/b2", parameterNames= paste("b", 0:2, sep="")) deltaMethod(m1, "t1/t2", rhs=1) # use names of preds. rather than coefs. deltaMethod(m1, "t1/t2", vcov=hccm) # use hccm function to est. vars. deltaMethod(m1, "1/(Intercept)") # The next example invokes the default method by extracting the # vector of estimates and covariance matrix explicitly deltaMethod(coef(m1), "t1/t2", vcov.=vcov(m1)) } \keyword{ models } \keyword{ regression } car/man/influence-mixed-models.Rd0000644000176000001440000001056414140261763016460 0ustar ripleyusers\name{influence.mixed.models} \alias{influence.mixed.models} \alias{influence.lme} \alias{cooks.distance.influence.lme} \alias{dfbeta.influence.lme} \alias{dfbetas.influence.lme} \title{ Influence Diagnostics for Mixed-Effects Models } \description{ These functions compute deletion influence diagnostics for linear mixed-effects models fit by \code{\link{lme}} in the \pkg{nlme} package. The main function is a method for the \code{\link{influence}} generic function. Other functions are provided for computing \code{\link{dfbeta}}, \code{\link{dfbetas}}, \code{\link{cooks.distance}}, and influence on variance-covariance components based on the object computed by \code{influence.lme}. } \usage{ \method{influence}{lme}(model, groups, data, ncores=1, ...) \method{cooks.distance}{influence.lme}(model, ...) \method{dfbeta}{influence.lme}(model, which = c("fixed", "var.cov"), ...) \method{dfbetas}{influence.lme}(model, ...) } \arguments{ \item{model}{in the case \code{influence}, a model of class \code{"lme"}; in the case of \code{cooks.distance}, \code{dfbeta}, or \code{dfbetas}, an object returned by \code{influence.lme}.} \item{groups}{a character vector containing the name of a grouping factor or names of grouping factors; if more than one name is supplied, then groups are defined by all combinations of levels of the grouping factors that appear in the data. If omitted, then each individual row of the data matrix is treated as a "group" to be deleted in turn.} \item{data}{an optional data frame with the data to which \code{model} was fit; \code{influence.lme} can access the data unless \code{keep.data=FALSE} was specified in the call to \code{lme}, so it's usually unnecessary to supply the \code{data} argument.} \item{ncores}{number of cores for parallel computation of diagnostics; if \code{1} (the default), the computation isn't parallelized; if \code{Inf}, all of the available \emph{physical} cores (not necessarily \emph{logical} cores --- see \code{\link{detectCores}}) on the computer will be used.} \item{which}{if \code{"fixed.effects"} (the default), return influence on the fixed effects; if \code{"var.cov"}, return influence on the variance-covariance components.} \item{\dots}{ignored.} } \details{ \code{influence.lme} starts with the estimated variance-covariance components from \code{model} and then refits the model omitting each group in turn. The other functions are methods for the \code{\link{dfbeta}}, \code{\link{dfbetas}}, and \code{\link{cooks.distance}} generics, to be applied to the \code{"influence.lme"} object produced by the \code{influence} function; the \code{dfbeta} methods can also return influence on the variance-covariance components. } \value{ \code{influence.lme} returns an object of class %\code{"influence.merMod"} and \code{"influence.lme"},% respectively, which contains the following elements: \describe{ \item{\code{"fixed.effects"}}{the estimated fixed effects for the model.} \item{\code{"fixed.effects[-groups]"}}{a matrix with columns corresponding to the fixed-effects coefficients and rows corresponding to groups, giving the estimated fixed effects with each group deleted in turn; \emph{groups} is formed from the name(s) of the grouping factor(s).} \item{\code{"var.cov.comps"}}{the estimated variance-covariance parameters for the model.} \item{\code{"var.cov.comps[-groups]"}}{a matrix with the estimated covariance parameters (in columns) with each group deleted in turn.} \item{\code{"vcov"}}{The estimated covariance matrix of the fixed-effects coefficients.} \item{\code{"vcov[-groups]"}}{a list each of whose elements is the estimated covariance matrix of the fixed-effects coefficients with one group deleted.} \item{\code{"groups"}}{a character vector giving the names of the grouping factors.} \item{\code{"deleted"}}{the possibly composite grouping factor, each of whose elements is deleted in turn.} } For plotting \code{"influence.lme"} objects, see \code{\link{infIndexPlot}}. } \references{ Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. } \author{ J. Fox \email{jfox@mcmaster.ca} } \seealso{ \code{\link{lme}}, \code{\link{infIndexPlot}}. } \examples{ if (require(nlme)){ print(fm1 <- lme(distance ~ age, data = Orthodont)) infIndexPlot(influence(fm1, "Subject")) infIndexPlot(influence(fm1)) } } \keyword{models} car/man/scatterplot.Rd0000644000176000001440000003115514140261763014466 0ustar ripleyusers\name{scatterplot} \alias{scatterplot} \alias{scatterplot.formula} \alias{scatterplot.default} \alias{sp} \title{Enhanced Scatterplots with Marginal Boxplots, Point Marking, Smoothers, and More} \description{ This function uses basic R graphics to draw a two-dimensional scatterplot, with options to allow for plot enhancements that are often helpful with regression problems. Enhancements include adding marginal boxplots, estimated mean and variance functions using either parametric or nonparametric methods, point identification, jittering, setting characteristics of points and lines like color, size and symbol, marking points and fitting lines conditional on a grouping variable, and other enhancements. \code{sp} is an abbreviation for \code{scatterplot}. } \usage{ scatterplot(x, ...) \method{scatterplot}{formula}(formula, data, subset, xlab, ylab, id=FALSE, legend=TRUE, ...) \method{scatterplot}{default}(x, y, boxplots=if (by.groups) "" else "xy", regLine=TRUE, legend=TRUE, id=FALSE, ellipse=FALSE, grid=TRUE, smooth=TRUE, groups, by.groups=!missing(groups), xlab=deparse(substitute(x)), ylab=deparse(substitute(y)), log="", jitter=list(), cex=par("cex"), col=carPalette()[-1], pch=1:n.groups, reset.par=TRUE, ...) sp(x, ...) } \arguments{ \item{x}{vector of horizontal coordinates (or first argument of generic function).} \item{y}{vector of vertical coordinates.} \item{formula}{a model formula, of the form \code{y ~ x} or, if plotting by groups, \code{y ~ x | z}, where \code{z} evaluates to a factor or other variable dividing the data into groups. If \code{x} is a factor, then parallel boxplots are produced using the \code{\link{Boxplot}} function.} \item{data}{data frame within which to evaluate the formula.} \item{subset}{expression defining a subset of observations.} \item{boxplots}{if \code{"x"} a marginal boxplot for the horizontal \code{x}-axis is drawn below the plot; if \code{"y"} a marginal boxplot for vertical \code{y}-axis is drawn to the left of the plot; if \code{"xy"} both marginal boxplots are drawn; set to \code{""} or \code{FALSE} to suppress both boxplots.} \item{regLine}{controls adding a fitted regression line to the plot. if \code{regLine=FALSE}, no line is drawn. If \code{TRUE}, the default, an OLS line is fit. This argument can also be a list. The default of \code{TRUE} is equivalent to \code{regLine=list(method=lm, lty=1, lwd=2, col=col)}, which specifies using the \code{lm} function to estimate the fitted line, to draw a solid line (\code{lty=1}) of width 2 times the nominal width (\code{lwd=2}) in the color given by the first element of the \code{col} argument described below. } \item{legend}{when the plot is drawn by groups and \code{legend=TRUE}, controls placement and properties of a legend; if \code{FALSE}, the legend is suppressed. Can be a list of named arguments, as follows: \code{title} for the legend; \code{inset}, giving space as a proportion of the axes to offset the legend from the axes; \code{coords} specifying the position of the legend in any form acceptable to the \code{\link{legend}} function or, if not given, the legend is placed \emph{above} the plot in the upper margin; \code{columns} for the legend, determined automatically to prefer a horizontal layout if not given explicitly; \code{cex} giving the relative size of the legend symbols and text. \code{TRUE} (the default) is equivalent to \code{list(title=deparse(substitute(groups)), inset=0.02, cex=1)}.} \item{id}{controls point identification; if \code{FALSE} (the default), no points are identified; can be a list of named arguments to the \code{\link{showLabels}} function; \code{TRUE} is equivalent to \code{list(method="mahal", n=2, cex=1, col=carPalette()[-1], location="lr")}, which identifies the 2 points (in each group) with the largest Mahalanobis distances from the center of the data. See \code{\link{showLabels}} for a description of the other arguments. The default behavior of \code{id} is not the same in all graphics functions in \pkg{car}, as the \code{method} used depends on the type of plot.} \item{ellipse}{controls plotting data-concentration ellipses. If \code{FALSE} (the default), no ellipses are plotted. Can be a list of named values giving \code{levels}, a vector of one or more bivariate-normal probability-contour levels at which to plot the ellipses; \code{robust}, a logical value determing whether to use the \code{\link{cov.trob}} function in the \pkg{MASS} package to calculate the center and covariance matrix for the data ellipses; and \code{fill} and \code{fill.alpha}, which control whether the ellipse is filled and the transparency of the fill. \code{TRUE} is equivalent to \code{list(levels=c(.5, .95), robust=TRUE, fill=TRUE, fill.alpha=0.2)}.} \item{grid}{If TRUE, the default, a light-gray background grid is put on the graph} \item{smooth}{specifies a nonparametric estimate of the mean or median function of the vertical axis variable given the horizontal axis variable and optionally a nonparametric estimate of the conditional variance. If \code{smooth=FALSE} neither function is drawn. If \code{smooth=TRUE}, then both the mean function and variance funtions are drawn for ungrouped data, and the mean function only is drawn for grouped data. The default smoother is \code{\link{loessLine}}, which uses the \code{\link{loess}} function from the \pkg{stats} package. This smoother is fast and reliable. See the details below for changing the smoother, line type, width and color, of the added lines, and adding arguments for the smoother.} \item{groups}{a factor or other variable dividing the data into groups; groups are plotted with different colors, plotting characters, fits, and smooths. Using this argument is equivalent to specifying the grouping variable in the formula.} \item{by.groups}{if \code{TRUE} (the default when there are groups), regression lines are fit by groups.} \item{xlab}{label for horizontal axis.} \item{ylab}{label for vertical axis.} \item{log}{same as the \code{log} argument to \code{\link{plot}}, to produce log axes.} \item{jitter}{a list with elements \code{x} or \code{y} or both, specifying jitter factors for the horizontal and vertical coordinates of the points in the scatterplot. The \code{\link{jitter}} function is used to randomly perturb the points; specifying a factor of \code{1} produces the default jitter. Fitted lines are unaffected by the jitter.} \item{col}{with no grouping, this specifies a color for plotted points; with grouping, this argument should be a vector of colors of length at least equal to the number of groups. The default is value returned by \code{\link{carPalette}[-1]}.} \item{pch}{plotting characters for points; default is the plotting characters in order (see \code{\link{par}}).} \item{cex}{sets the size of plotting characters, with \code{cex=1} the standard size. You can also set the sizes of other elements with the arguments \code{cex.axis}, \code{cex.lab}, \code{cex.main}, and \code{cex.sub}. See \code{\link{par}}.} \item{reset.par}{if \code{TRUE} (the default) then plotting parameters are reset to their previous values when \code{scatterplot} exits; if \code{FALSE} then the \code{mar} and \code{mfcol} parameters are altered for the current plotting device. Set to \code{FALSE} if you want to add graphical elements (such as lines) to the plot.} \item{\dots}{other arguments passed down and to \code{plot}. For example, the argument \code{las} sets the style of the axis labels, and \code{xlim} and \code{ylim} set the limits on the horizontal and vertical axes, respectively; see \code{\link{par}}.} } \details{ Many arguments to \code{scatterplot} were changed in version 3 of \pkg{car} to simplify use of this function. The \code{smooth} argument is used to control adding smooth curves to the plot to estimate the conditional center of the vertical axis variable given the horizontal axis variable, and also the conditional variability. Setting \code{smooth=FALSE} omits all smoothers, while \code{smooth=TRUE}, the default, includes default smoothers. Alternatively \code{smooth} can be set to a list of subarguments that provide finer control over the smoothing. The default behavior of \code{smooth=TRUE} is equivalent to \code{smooth=list(smoother=loessLine, var=!by.groups, lty.var=2, lty.var=4, style="filled", alpha=0.15, border=TRUE, vertical=TRUE)}, specifying the default \code{\link{loessLine}} smoother for the conditional mean smooth and variance smooth. The color of the smooths is the same of the color of the points, but this can be changed with the arguments \code{col.smooth} and \code{col.var}. Additional available smoothers are \code{\link{gamLine}} which uses the \code{\link[mgcv]{gam}} function and \code{\link{quantregLine}} which uses quantile regression to estimate the median and quartile functions using \code{\link[quantreg]{rqss}}. All of these smoothers have one or more arguments described on their help pages, and these arguments can be added to the \code{smooth} argument; for example, \code{smooth = list(span=1/2)} would use the default \code{loessLine} smoother, include the variance smooth, and change the value of the smoothing parameter to 1/2. For \code{loessLine} and \code{gamLine} the variance smooth is estimated by separately smoothing the squared positive and negative residuals from the mean smooth, using the same type of smoother. The displayed curves are equal to the mean smooth plus the square root of the fit to the positive squared residuals, and the mean fit minus the square root of the smooth of the negative squared residuals. The lines therefore represent the comnditional variabiliity at each value on the horizontal axis. Because smoothing is done separately for positive and negative residuals, the variation shown will generally not be symmetric about the fitted mean function. For the \code{quantregLine} method, the center estimates the conditional median, and the variability estimates the lower and upper quartiles of the estimated conditional distribution. The default depection of the variance functions is via a shaded envelope between the upper and lower estimate of variability. setting the subarguement \code{style="lines"} will display only the boundaries of this region, and \code{style="none"} suppresses variance smoothing. For \code{style="filled"} several subarguments modify the appearance of the region: code{alpha} is a number between 0 and 1 that specifies opacity with defualt 0.15, \code{border}, \code{TRUE} or \code{FALSE} specifies a border for the envelope, and \code{vertical} either \code{TRUE} or \code{FALSE}, modifies the behavior of the envelope at the edges of the graph. The sub-arguments \code{spread}, \code{lty.spread} and \code{col.spread} of the \code{smooth} argument are equivalent to the newer \code{var}, \code{col.var} and \code{lty.var}, respectively, recognizing that the spread is a measuure of conditional variability. } \value{ If points are identified, their labels are returned; otherwise \code{NULL} is returned invisibly. } \author{John Fox \email{jfox@mcmaster.ca}} \references{ Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. } \seealso{\code{\link{boxplot}}, \code{\link{jitter}}, \code{\link{legend}}, \code{\link{scatterplotMatrix}}, \code{\link{dataEllipse}}, \code{\link{Boxplot}}, \code{\link{cov.trob}}, \code{\link{showLabels}}, \code{\link{ScatterplotSmoothers}}.} \examples{ scatterplot(prestige ~ income, data=Prestige, ellipse=TRUE, smooth=list(style="lines")) scatterplot(prestige ~ income, data=Prestige, smooth=list(smoother=quantregLine)) scatterplot(prestige ~ income, data=Prestige, smooth=list(smoother=quantregLine, border="FALSE")) # use quantile regression for median and quartile fits scatterplot(prestige ~ income | type, data=Prestige, smooth=list(smoother=quantregLine, var=TRUE, span=1, lwd=4, lwd.var=2)) scatterplot(prestige ~ income | type, data=Prestige, legend=list(coords="topleft")) scatterplot(vocabulary ~ education, jitter=list(x=1, y=1), data=Vocab, smooth=FALSE, lwd=3) scatterplot(infantMortality ~ ppgdp, log="xy", data=UN, id=list(n=5)) scatterplot(income ~ type, data=Prestige) \dontrun{ # remember to exit from point-identification mode scatterplot(infantMortality ~ ppgdp, id=list(method="identify"), data=UN) } } \keyword{hplot} car/man/carWeb.Rd0000644000176000001440000000342014140261763013317 0ustar ripleyusers\name{carWeb} \alias{carWeb} \title{ Access to the R Companion to Applied Regression Website } \description{ This function will access the website for \emph{An R Companion to Applied Regression}, or setup files or data.} \usage{ carWeb(page = c("webpage", "errata", "taskviews"), script, data, setup) } \arguments{ \item{page}{ A character string indicating what page to open. The default \code{"webpage"} will open the main web page, \code{"errata"} displays the errata sheet for the book, \code{"taskviews"} fetches and displays a list of available task views from CRAN. } \item{script}{The quoted name of a chapter in \emph{An R Companion to Applied Regression}, like \code{"chap-1"}, \code{"chap-2"}, up to \code{"chap-10"}. All the R commands used in that chapter will be displayed in your browser, where you can save them as a text file. } \item{data}{The quoted name of a data file in \emph{An R Companion to Applied Regression}, like \code{"Duncan.txt"} or \code{"Prestige.txt"}. The file will be opened in your web browser. You do not need to specify the extension \code{.txt} } \item{setup}{If \code{TRUE} this command will download a number of files to your computer that are discussed in Fox and Weisberg (2019), beginning in Chapter 1.} } \value{ Either displays a web page or a PDF document or downloads files to your working directory. } \references{ Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. } \author{ Sanford Weisberg, based on the function \code{UsingR} in the \pkg{UsingR} package by John Verzani } \examples{ \dontrun{ carWeb() carWeb(setup=TRUE) } } \keyword{ interface } car/man/car-defunct.Rd0000644000176000001440000000517014140261763014313 0ustar ripleyusers\name{car-defunct} \alias{car-defunct} \alias{av.plot} \alias{av.plots} \alias{box.cox} \alias{bc} \alias{box.cox.powers} \alias{box.cox.var} \alias{box.tidwell} \alias{cookd} \alias{confidence.ellipse} \alias{ceres.plot} \alias{ceres.plots} \alias{cr.plot} \alias{cr.plots} \alias{data.ellipse} \alias{durbin.watson} \alias{levene.test} \alias{leverage.plot} \alias{leverage.plots} \alias{linear.hypothesis} \alias{outlier.test} \alias{ncv.test} \alias{qq.plot} %\alias{scatterplot.matrix} \alias{spread.level.plot} \alias{skewPower} \title{Defunct Functions in the car Package} \description{ These functions are were deprecated in 2009 and are now defunct. } \usage{ av.plot(...) av.plots(...) box.cox(...) bc(...) box.cox.powers(...) box.cox.var(...) box.tidwell(...) cookd(...) confidence.ellipse(...) ceres.plot(...) ceres.plots(...) cr.plot(...) cr.plots(...) data.ellipse(...) durbin.watson(...) levene.test(...) leverage.plot(...) leverage.plots(...) linear.hypothesis(...) ncv.test(...) outlier.test(...) qq.plot(...) skewPower(...) spread.level.plot(...) } \arguments{ \item{\dots}{pass arguments down.} } \details{ \code{av.plot} and \code{av.plots} are replaced by \code{\link{avPlot}} and \code{\link{avPlots}} functions. \code{box.cox} and \code{bc} are now replaced by \code{\link{bcPower}}. \code{box.cox.powers} is replaced by \code{\link{powerTransform}}. \code{box.cox.var} is replaced by \code{\link{boxCoxVariable}}. \code{box.tidwell} is replaced by \code{\link{boxTidwell}}. \code{cookd} is replaced by \code{\link[stats:influence.measures]{cooks.distance}} in the \pkg{stats} package. \code{confidence.ellipse} is replaced by \code{\link{confidenceEllipse}}. \code{ceres.plot} and \code{ceres.plots} are now replaced by the \code{\link{ceresPlot}} and \code{\link{ceresPlots}} functions. \code{cr.plot} and \code{cr.plots} are now replaced by the \code{\link{crPlot}} and \code{\link{crPlots}} functions. \code{data.ellipse} is replaced by \code{\link{dataEllipse}}. \code{durbin.watson} is replaced by \code{\link{durbinWatsonTest}}. \code{levene.test} is replaced by \code{\link{leveneTest}} function. \code{leverage.plot} and \code{leverage.plots} are now replaced by the \code{\link{leveragePlot}} and \code{\link{leveragePlots}} functions. \code{linear.hypothesis} is replaced by the \code{\link{linearHypothesis}} function. \code{ncv.test} is replaced by \code{\link{ncvTest}}. \code{outlier.test} is replaced by \code{\link{outlierTest}}. \code{qq.plot} is replaced by \code{\link{qqPlot}}. \code{skewPower} is replaced by \code{\link{bcnPower}}. \code{spread.level.plot} is replaced by \code{\link{spreadLevelPlot}}. } car/man/which.names.Rd0000644000176000001440000000205114140261763014317 0ustar ripleyusers\name{whichNames} \alias{which.names} \alias{whichNames} \alias{whichNames.data.frame} \alias{whichNames.default} \title{Position of Row Names} \description{ These functions return the indices of the supplied row names of a data frame or names of another object, such as a vector or list. \code{whichNames} is just an alias for \code{which.names}. } \usage{ whichNames(names, object, ...) which.names(names, object, ...) \method{whichNames}{data.frame}(names, object, ...) \method{whichNames}{default}(names, object, ...) } \arguments{ \item{names}{a name or character vector of names.} \item{object}{a data frame or an object with a names attribute.} \item{\dots}{not used.} } \value{ Returns the index or indices of \code{names} in row names of the data frame or names of an object of another class. } \author{John Fox \email{jfox@mcmaster.ca}} \references{ Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. } \examples{ whichNames(c('minister', 'conductor'), Duncan) } \keyword{utilities} car/man/sigmaHat.Rd0000644000176000001440000000152714140261763013657 0ustar ripleyusers\name{sigmaHat} \alias{sigmaHat} \alias{sigmaHat.default} \alias{sigmaHat.glm} \alias{sigmaHat.lm} \title{ Return the scale estimate for a regression model } \description{ This function provides a consistent method to return the estimated scale from a linear, generalized linear, nonlinear, or other model. } \usage{ sigmaHat(object) } \arguments{ \item{object}{A regression object of type lm, glm or nls} } \details{ For an lm or nls object, the returned quantity is the square root of the estimate of \eqn{\sigma^2}{sigma^2}. For a glm object, the returned quantity is the square root of the estimated dispersion parameter. } \value{ A nonnegative number } \author{Sanford Weisberg, \email{sandy@umn.edu} } \examples{ m1 <- lm(prestige ~ income + education, data=Duncan) sigmaHat(m1) } \keyword{ regression }% at least one, from doc/KEYWORDS car/man/carHexsticker.Rd0000644000176000001440000000066714140261763014725 0ustar ripleyusers\name{carHexsticker} \alias{carHexsticker} \title{ View the Official Hex Sticker for the car Package} \description{ Open the official hex sticker for the car package in your browser} \usage{ carHexsticker() } \value{ Used for its side effect of openning the hex sticker for the car package in your browser. } \author{ John Fox \email{jfox@mcmaster.ca} } \examples{ \dontrun{ carHexsticker() } } \keyword{misc} car/man/strings2factors.Rd0000644000176000001440000000505314140261763015255 0ustar ripleyusers\name{strings2factors} \alias{strings2factors} \alias{strings2factors.data.frame} \title{ Convert Character-String Variables in a Data Frame to Factors } \description{ Converts the character variables (or a subset of these variables) in a data frame to factors, with optional control of the order of the resulting factor levels. } \usage{ strings2factors(object, which, not, exclude.unique, levels, verbose, ...) \method{strings2factors}{data.frame}(object, which, not, exclude.unique=TRUE, levels=list(), verbose=TRUE, ...) } \arguments{ \item{object}{a data frame or an object inheriting from the \code{"data.frame"} class.} \item{which}{an optional character vector of names or column numbers of the character variables to be converted to factors; if absent, \emph{all} character variables will be converted, except as excluded by the \code{not} and \code{exclude.unique} arguments (see below).} \item{not}{an optional character vector of names or column numbers of character variables \emph{not} to be converted to factors.} \item{exclude.unique}{if \code{TRUE} (the default), character variables all of whose values are unique (i.e., all different from each other) are not converted to factors. Such variables, which would have as many levels as there are cases, are typically case identifiers and not categorical variables. If \code{FALSE}, character variables all of whose values are unique are converted to factors with a warning.} \item{levels}{an optional named list, each element of which is a character vector of levels of the corresponding factor. This argument allows you to control the order of levels of the factor; if omitted, or if a particular factor is omitted from the list, the levels will be in the default alphabetic order.} \item{verbose}{if \code{TRUE} (the default), the names of the character variables that were converted to factors are printed on the console.} \item{\dots}{not used.} } \value{a data frame with (some) character variables replaced by corresponding factors.} \author{John Fox \email{jfox@mcmaster.ca}} \seealso{\code{\link{factor}}, \code{\link{data.frame}}} \examples{ M <- Moore # from the carData package M$partner <- as.character(Moore$partner.status) M$fcat <- as.character(Moore$fcategory) M$names <- rownames(M) # values are unique str(M) str(strings2factors(M)) str(strings2factors(M, levels=list(partner=c("low", "high"), fcat=c("low", "medium", "high")))) str(strings2factors(M, which="partner", levels=list(partner=c("low", "high")))) str(strings2factors(M, not="partner", exclude.unique=FALSE)) } \keyword{manip} car/man/qqPlot.Rd0000644000176000001440000001640514140261763013403 0ustar ripleyusers\name{qqPlot} \alias{qqPlot} \alias{qqp} \alias{qqPlot.default} \alias{qqPlot.formula} \alias{qqPlot.lm} \alias{qqPlot.glm} \title{Quantile-Comparison Plot} \description{ Plots empirical quantiles of a variable, or of studentized residuals from a linear model, against theoretical quantiles of a comparison distribution. Includes options not available in the \code{\link{qqnorm}} function. } \usage{ qqPlot(x, ...) qqp(...) \method{qqPlot}{default}(x, distribution="norm", groups, layout, ylim=range(x, na.rm=TRUE), ylab=deparse(substitute(x)), xlab=paste(distribution, "quantiles"), glab=deparse(substitute(groups)), main=NULL, las=par("las"), envelope=TRUE, col=carPalette()[1], col.lines=carPalette()[2], lwd=2, pch=1, cex=par("cex"), line=c("quartiles", "robust", "none"), id=TRUE, grid=TRUE, ...) \method{qqPlot}{formula}(formula, data, subset, id=TRUE, ylab, glab, ...) \method{qqPlot}{lm}(x, xlab=paste(distribution, "Quantiles"), ylab=paste("Studentized Residuals(", deparse(substitute(x)), ")", sep=""), main=NULL, distribution=c("t", "norm"), line=c("robust", "quartiles", "none"), las=par("las"), simulate=TRUE, envelope=TRUE, reps=100, col=carPalette()[1], col.lines=carPalette()[2], lwd=2, pch=1, cex=par("cex"), id=TRUE, grid=TRUE, ...) } \arguments{ \item{x}{vector of numeric values or \code{lm} object.} \item{distribution}{root name of comparison distribution -- e.g., \code{"norm"} for the normal distribution; \code{t} for the t-distribution.} \item{groups}{an optional factor; if specified, a QQ plot will be drawn for \code{x} within each level of \code{groups}.} \item{layout}{a 2-vector with the number of rows and columns for plotting by groups -- for example \code{c(1, 3)} for 1 row and 3 columns; if omitted, the number of rows and columns will be selected automatically; the specified number of rows and columns must be sufficient to accomodate the number of groups; ignored if there is no grouping factor.} \item{formula}{one-sided formula specifying a single variable to be plotted or a two-sided formula of the form \code{variable ~ factor}, where a QQ plot will be drawn for \code{variable} within each level of \code{factor}.} \item{data}{optional data frame within which to evaluage the formula.} \item{subset}{optional subset expression to select cases to plot.} \item{ylim}{limits for vertical axis; defaults to the range of \code{x}. If plotting by groups, a common y-axis is used for all groups.} \item{ylab}{label for vertical (empirical quantiles) axis.} \item{xlab}{label for horizontal (comparison quantiles) axis.} \item{glab}{label for the grouping variable.} \item{main}{label for plot.} \item{envelope}{\code{TRUE} (the default), \code{FALSE}, a confidence level such as \code{0.95}, or a list specifying how to plot a point-wise confidence envelope (see Details).} \item{las}{if \code{0}, ticks labels are drawn parallel to the axis; set to \code{1} for horizontal labels (see \code{\link{par}}).} \item{col}{color for points; the default is the \emph{first} entry in the current \pkg{car} palette (see \code{\link{carPalette}} and \code{\link{par}}).} \item{col.lines}{color for lines; the default is the \emph{second} entry in the current \pkg{car} palette.} \item{pch}{plotting character for points; default is \code{1} (a circle, see \code{\link{par}}).} \item{cex}{factor for expanding the size of plotted symbols; the default is \code{1}.} \item{id}{controls point identification; if \code{FALSE}, no points are identified; can be a list of named arguments to the \code{\link{showLabels}} function; \code{TRUE} is equivalent to \code{list(method="y", n=2, cex=1, col=carPalette()[1], location="lr")}, which identifies the 2 points with the 2 points with the most extreme verical values --- studentized residuals for the \code{"lm"} method. Points labels are by default taken from the names of the variable being plotted is any, else case indices are used. Unlike most graphical functions in \pkg{car}, the default is \code{id=TRUE} to include point identification.} \item{lwd}{line width; default is \code{2} (see \code{\link{par}}).} \item{line}{\code{"quartiles"} to pass a line through the quartile-pairs, or \code{"robust"} for a robust-regression line; the latter uses the \code{rlm} function in the \code{MASS} package. Specifying \code{line = "none"} suppresses the line.} \item{simulate}{if \code{TRUE} calculate confidence envelope by parametric bootstrap; for \code{lm} object only. The method is due to Atkinson (1985).} \item{reps}{integer; number of bootstrap replications for confidence envelope.} \item{\dots}{arguments such as \code{df} to be passed to the appropriate quantile function.} \item{grid}{If TRUE, the default, a light-gray background grid is put on the graph} } \details{ Draws theoretical quantile-comparison plots for variables and for studentized residuals from a linear model. A comparison line is drawn on the plot either through the quartiles of the two distributions, or by robust regression. Any distribution for which quantile and density functions exist in R (with prefixes \code{q} and \code{d}, respectively) may be used. When plotting a vector, the confidence envelope is based on the SEs of the order statistics of an independent random sample from the comparison distribution (see Fox, 2016). Studentized residuals from linear models are plotted against the appropriate t-distribution with a point-wise confidence envelope computed by default by a parametric bootstrap, as described by Atkinson (1985). The function \code{qqp} is an abbreviation for \code{qqPlot}. The \code{envelope} argument can take a list with the following named elements; if an element is missing, then the default value is used: \describe{ \item{\code{level}}{confidence level (default \code{0.95}).} \item{\code{style}}{one of \code{"filled"} (the default), \code{"lines"}, or \code{"none"}.} \item{\code{col}}{color (default is the value of \code{col.lines}).} \item{\code{alpha}}{transparency/opacity of a filled confidence envelope, a number between 0 and 1 (default \code{0.15}).} \item{\code{border}}{controls whether a border is drawn around a filled confidence envelope (default \code{TRUE}).} } } \value{ These functions return the labels of identified points, unless a grouping factor is employed, in which case \code{NULL} is returned invisibly. } \references{ Fox, J. (2016) \emph{Applied Regression Analysis and Generalized Linear Models}, Third Edition. Sage. Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. Atkinson, A. C. (1985) \emph{Plots, Transformations, and Regression.} Oxford. } \author{John Fox \email{jfox@mcmaster.ca}} \seealso{\code{\link{qqplot}}, \code{\link{qqnorm}}, \code{\link{qqline}}, \code{\link{showLabels}}} \examples{ x<-rchisq(100, df=2) qqPlot(x) qqPlot(x, dist="chisq", df=2, envelope=list(style="lines")) qqPlot(~ income, data=Prestige, subset = type == "prof") qqPlot(income ~ type, data=Prestige, layout=c(1, 3)) qqPlot(lm(prestige ~ income + education + type, data=Duncan), envelope=.99) } \keyword{distribution} \keyword{univar} \keyword{regression} car/man/subsets.Rd0000644000176000001440000000556014140261763013613 0ustar ripleyusers\name{subsets} \alias{subsets} \alias{subsets.regsubsets} \title{Plot Output from regsubsets Function in leaps package} \description{ The \code{\link[leaps]{regsubsets}} function in the \pkg{leaps} package finds optimal subsets of predictors based on some criterion statistic. This function plots a measure of fit against subset size. } \usage{ subsets(object, ...) \method{subsets}{regsubsets}(object, names=abbreviate(object$xnames, minlength = abbrev), abbrev=1, min.size=1, max.size=length(names), legend="interactive", statistic=c("bic", "cp", "adjr2", "rsq", "rss"), las=par('las'), cex.subsets=1, ...) } \arguments{ \item{object}{a \code{regsubsets} object produced by the \code{regsubsets} function in the \pkg{leaps} package.} \item{names}{a vector of (short) names for the predictors, excluding the regression intercept, if one is present; if missing, these are derived from the predictor names in \code{object}.} \item{abbrev}{minimum number of characters to use in abbreviating predictor names.} \item{min.size}{minimum size subset to plot; default is \code{1}.} \item{max.size}{maximum size subset to plot; default is number of predictors.} \item{legend}{If not \code{FALSE}, in which case the legend is suppressed, the coordinates at which to place a legend of the abbreviated predictor names on the plot, in a form recognized by the \code{\link{legend}} function. If \code{"interactive"}, the legend is placed on the plot interactively with the mouse. By expanding the left or right plot margin, you can place the legend in the margin, if you wish (see \code{\link{par}}).} \item{statistic}{statistic to plot for each predictor subset; one of: \code{"bic"}, Bayes Information Criterion; \code{"cp"}, Mallows's \eqn{C_{p}}{Cp}; \code{"adjr2"}, \eqn{R^{2}}{R^2} adjusted for degrees of freedom; \code{"rsq"}, unadjusted \eqn{R^{2}}{R^2}; \code{"rss"}, residual sum of squares.} \item{las}{if \code{0}, ticks labels are drawn parallel to the axis; set to \code{1} for horizontal labels (see \code{\link{par}}).} \item{cex.subsets}{can be used to change the relative size of the characters used to plot the regression subsets; default is \code{1}.} \item{\dots}{arguments to be passed down to \code{subsets.regsubsets} and \code{plot}.} } \value{ \code{NULL} if the \code{legend} is \code{TRUE}; otherwise a data frame with the legend. } \author{John Fox} \references{ Fox, J. (2016) \emph{Applied Regression Analysis and Generalized Linear Models}, Third Edition. Sage. Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. } \seealso{\code{\link[leaps]{regsubsets}}} \examples{ if (require(leaps)){ subsets(regsubsets(undercount ~ ., data=Ericksen), legend=c(3.5, -37)) } } \keyword{hplot} \keyword{regression} car/man/wcrossprod.Rd0000644000176000001440000000266514140261763014333 0ustar ripleyusers\name{wcrossprod} \alias{wcrossprod} \title{ Weighted Matrix Crossproduct } \description{ Given matrices \code{x} and \code{y} as arguments and an optional matrix or vector of weights, \code{w}, return a weighted matrix cross-product, \code{t(x) w y}. If no weights are supplied, or the weights are constant, the function uses \code{\link{crossprod}} for speed. } \usage{ wcrossprod(x, y, w) } \arguments{ \item{x,y}{ x, y numeric matrices; \code{missing(y)} is taken to be the same matrix as x. Vectors are promoted to single-column or single-row matrices, depending on the context. } \item{w}{ A numeric vector or matrix of weights, conformable with \code{x} and \code{y}. } } \value{ A numeric matrix, with appropriate dimnames taken from \code{x} and \code{y}. } \author{ Michael Friendly, John Fox \email{jfox@mcmaster.ca} } \seealso{ \code{\link{crossprod}} } \examples{ set.seed(12345) n <- 24 drop <- 4 sex <- sample(c("M", "F"), n, replace=TRUE) x1 <- 1:n x2 <- sample(1:n) extra <- c( rep(0, n - drop), floor(15 + 10 * rnorm(drop)) ) y1 <- x1 + 3*x2 + 6*(sex=="M") + floor(10 * rnorm(n)) + extra y2 <- x1 - 2*x2 - 8*(sex=="M") + floor(10 * rnorm(n)) + extra # assign non-zero weights to 'dropped' obs wt <- c(rep(1, n-drop), rep(.2,drop)) X <- cbind(x1, x2) Y <- cbind(y1, y2) wcrossprod(X) wcrossprod(X, w=wt) wcrossprod(X, Y) wcrossprod(X, Y, w=wt) wcrossprod(x1, y1) wcrossprod(x1, y1, w=wt) } \keyword{ array} \keyword{algebra} car/man/regLine.Rd0000644000176000001440000000275414140261763013512 0ustar ripleyusers\name{regLine} \alias{regLine} \title{Plot Regression Line} \description{ Plots a regression line on a scatterplot; the line is plotted between the minimum and maximum x-values. } \usage{ regLine(mod, col=carPalette()[2], lwd=2, lty=1,...) } \arguments{ \item{mod}{a model, such as produced by \code{lm}, that responds to the \code{coef} function by returning a 2-element vector, whose elements are interpreted respectively as the intercept and slope of a regresison line.} \item{col}{color for points and lines; the default is the \emph{second} entry in the current \pkg{car} palette (see \code{\link{carPalette}} and \code{\link{par}}).} \item{lwd}{line width; default is \code{2} (see \code{\link{par}}).} \item{lty}{line type; default is \code{1}, a solid line (see \code{\link{par}}).} \item{\dots}{optional arguments to be passed to the \code{lines} plotting function.} } \details{ In contrast to \code{abline}, this function plots only over the range of the observed x-values. The x-values are extracted from \code{mod} as the second column of the model matrix. } \value{ \code{NULL}. This function is used for its side effect: adding a line to the plot. } \author{John Fox \email{jfox@mcmaster.ca}} \seealso{\code{\link{abline}}, \code{\link{lines}}} \examples{ plot(repwt ~ weight, pch=c(1,2)[sex], data=Davis) regLine(lm(repwt~weight, subset=sex=="M", data=Davis)) regLine(lm(repwt~weight, subset=sex=="F", data=Davis), lty=2) } \keyword{aplot} car/man/Tapply.Rd0000644000176000001440000000456114140261763013374 0ustar ripleyusers\name{Tapply} \alias{Tapply} \title{Apply a Function to a Variable Within Factor Levels} \description{ Applies a function, typically to compute a single statistic, like a mean, median, or standard deviation, within levels of a factor or within combinations of levels of two or more factors to produce a table of statistics. This function provides a formula interface to the standard R \code{\link{tapply}} function. } \usage{ Tapply(formula, fun, data, na.action = na.pass, ..., targs = list()) } \arguments{ \item{formula}{ a two-sided formula of the form \code{variable ~ factor.1 + factor.2 + ... + factor.n} or, equivalently, \code{variable ~ factor.1*factor.2* ... *factor.n}. The variables on the right-hand side of the formula are normally factors or are otherwise coerced to factors.} \item{fun}{a function, like \code{mean}, \code{median}, or \code{sd}, that takes a vector first argument and typically returns a single number as its value.} \item{data}{an optional data frame within which to find the variable and factor(s).} \item{na.action}{a function to handle missing values, as in statistical modeling functions like \code{\link{lm}}; the default is \code{\link{na.pass}}.} \item{\dots}{arguments to pass to the function given in the \code{fun} argument, such as (commonly) \code{na.rm=TRUE}.} \item{targs}{a list of optional arguments to pass to \code{\link{tapply}}.} } \details{ The function given by \code{fun} is applied to the values of the left-hand-side variable in \code{formula} within (combination of) levels of the factor(s) given in the right-hand side of \code{formula}, producing a table of statistics. } \value{ The object returned by \code{\link{tapply}}, typically simply printed. } \author{John Fox \email{jfox@mcmaster.ca}} \references{ Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition. Sage. } \seealso{\code{\link{tapply}}.} \examples{ Tapply(conformity ~ partner.status + fcategory, mean, data=Moore) Tapply(conformity ~ partner.status + fcategory, mean, data=Moore, trim=0.2) Moore[1, 2] <- NA Tapply(conformity ~ partner.status + fcategory, mean, data=Moore) Tapply(conformity ~ partner.status + fcategory, mean, data=Moore, na.rm=TRUE) Tapply(conformity ~ partner.status + fcategory, mean, data=Moore, na.action=na.omit) # equivalent remove("Moore") } \keyword{misc} \keyword{manip} car/man/symbox.Rd0000644000176000001440000000546614140261763013451 0ustar ripleyusers\name{symbox} \alias{symbox} \alias{symbox.formula} \alias{symbox.default} \alias{symbox.lm} \title{Boxplots for transformations to symmetry} \description{\code{symbox} first transforms \code{x} to each of a series of selected powers, with each transformation standardized to mean 0 and standard deviation 1. The results are then displayed side-by-side in boxplots, permiting a visual assessment of which power makes the distribution reasonably symmetric. For the \code{"lm"} method, the response variable in the model is successively transformed.} \usage{ symbox(x, ...) \method{symbox}{formula}(formula, data=NULL, subset, na.action=NULL, ylab, ...) \method{symbox}{default}(x, powers = c(-1, -0.5, 0, 0.5, 1), start, trans=bcPower, xlab="Powers", ylab, ...) \method{symbox}{lm}(x, powers = c(-1, -0.5, 0, 0.5, 1), start, trans=bcPower, xlab, ylab="Studentized residuals", ...) } \arguments{ \item{x}{a numeric vector.} \item{formula}{a one-sided formula specifying a single numeric variable.} \item{data, subset, na.action}{as for statistical modeling functions (see, e.g., \code{\link{lm}}).} \item{xlab, ylab}{axis labels; if \code{ylab} is missing, a label will be supplied. For the \code{"lm"} method, if \code{xlab} is missing, a label will also be supplied.} \item{powers}{a vector of selected powers to which \code{x} is to be raised. For meaningful comparison of powers, \code{1} should be included in the vector of powers.} \item{start}{a constant to be added to \code{x}. If \code{start} is missing and \code{trans} is \code{\link{bcPower}} (the default) or \code{\link{bcnPower}}, then a start will be automatically generated if there are zero or negative values in \code{x}, and a warning will be printed; the auto-generated \code{start} is the absolute value of the minimum \code{x} plus 1 percent of the range of \code{x}.} \item{trans}{a transformation function whose first argument is a numeric vector and whose second argument is a transformation parameter, given by the \code{powers} argument; the default is \code{\link{bcPower}}, and another possibility is \code{\link{yjPower}}. \code{\link{bcnPower}} may also be used, in which case the \code{gamma} parameter is set to the value of \code{start}.} \item{\ldots}{arguments to be passed down.} } \value{as returned by \code{boxplot}.} \author{Gregor Gorjanc, John Fox \email{jfox@mcmaster.ca}.} \references{ Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition. Sage. } \seealso{\code{\link{boxplot}}, \code{\link{boxcox}}, \code{\link{bcPower}}, \code{\link{yjPower}}} \examples{ symbox(~ income, data=Prestige) symbox(lm(wages ~ education + poly(age, 2) + sex, data=SLID)) } \keyword{hplot} car/man/residualPlots.Rd0000644000176000001440000002337714140261763014763 0ustar ripleyusers\name{residualPlots} \alias{residualPlots} \alias{residualPlots.default} \alias{residualPlots.lm} \alias{residualPlots.glm} \alias{residualPlot} \alias{residualPlot.default} \alias{residualPlot.lm} \alias{residualPlot.glm} \alias{residCurvTest} \alias{residCurvTest.lm} \alias{residCurvTest.glm} \alias{tukeyNonaddTest} \title{Residual Plots for Linear and Generalized Linear Models} \description{ Plots the residuals versus each term in a mean function and versus fitted values. Also computes a curvature test for each of the plots by adding a quadratic term and testing the quadratic to be zero. For linear models, this is Tukey's test for nonadditivity when plotting against fitted values. } \usage{ ### This is a generic function with only one required argument: residualPlots (model, ...) \S3method{residualPlots}{default}(model, terms = ~., layout = NULL, ask, main = "", fitted = TRUE, AsIs=TRUE, plot = TRUE, tests = TRUE, groups, ...) \S3method{residualPlots}{lm}(model, ...) \S3method{residualPlots}{glm}(model, ...) ### residualPlots calls residualPlot, so these arguments can be ### used with either function residualPlot(model, ...) \S3method{residualPlot}{default}(model, variable = "fitted", type = "pearson", groups, plot = TRUE, linear = TRUE, quadratic = if(missing(groups)) TRUE else FALSE, smooth=FALSE, id=FALSE, col = carPalette()[1], col.quad = carPalette()[2], pch=1, xlab, ylab, lwd = 1, lty = 1, grid=TRUE, key=!missing(groups), ...) \S3method{residualPlot}{lm}(model, ...) \S3method{residualPlot}{glm}(model, variable = "fitted", type = "pearson", plot = TRUE, quadratic = FALSE, smooth=TRUE, ...) } \arguments{ \item{model}{ A regression object. } \item{terms}{ A one-sided formula that specifies a subset of the factors and the regressors that appear in the formula that defined the model. The default \code{~ .} is to plot against all first-order terms, both regressors and factors. Higher order terms are skipped. For example, the specification \code{terms = ~ . - X3} would plot against all regressors except for \code{X3}. To get a plot against fitted values only, use the arguments \code{terms = ~ 1}. Interactions are skipped. For polynomial terms, the plot is against the first-order variable (which may be centered and scaled depending on how the \code{poly} function is used). Plots against factors are boxplots. Plots against other matrix terms, like splines, use the result of \code{predict(model), type="terms")[, variable])} as the horizontal axis; if the \code{predict} method doesn't permit this type, then matrix terms are skipped. A grouping variable can also be specified in the terms, so, for example \code{terms= ~ .|type} would use the factor \code{type} to set a different color and symbol for each level of \code{type}. Any fits in the plots will also be done separately for each level of group. } \item{layout}{ If set to a value like \code{c(1, 1)} or \code{c(4, 3)}, the layout of the graph will have this many rows and columns. If not set, the program will select an appropriate layout. If the number of graphs exceed nine, you must select the layout yourself, or you will get a maximum of nine per page. If \code{layout=NA}, the function does not set the layout and the user can use the \code{par} function to control the layout, for example to have plots from two models in the same graphics window. } \item{ask}{ If \code{TRUE}, ask the user before drawing the next plot; if \code{FALSE}, don't ask. } \item{main}{ Main title for the graphs. The default is \code{main=""} for no title. } \item{fitted}{ If \code{TRUE}, the default, include the plot against fitted values. } \item{AsIs}{ If \code{FALSE}, terms that use the \dQuote{as-is} function \code{I} are skipped; if \code{TRUE}, the default, they are included. } \item{plot}{ If \code{TRUE}, draw the plot(s). } \item{tests}{ If \code{TRUE}, display the curvature tests. With glm's, the argument \code{start} is ignored in computing the curvature tests. } \item{...}{ Additional arguments passed to \code{residualPlot} and then to \code{plot}. } \item{variable}{ Quoted variable name for the factor or regressor to be put on the horizontal axis, or the default \code{"fitted"} to plot versus fitted values. } \item{type}{ Type of residuals to be used. Pearson residuals are appropriate for \code{lm} objects since these are equivalent to ordinary residuals with ols and correctly weighted residuals with wls. Any quoted string that is an appropriate value of the \code{type} argument to \code{\link{residuals.lm}} or \code{"rstudent"} or \code{"rstandard"} for Studentized or standardized residuals. } \item{groups}{A grouping indicator. Points in different groups will be plotted with different colors and symbols. If missing, no grouping is used. In \code{residualPlots}, the grouping variable can also be set in the \code{terms} argument, as described above. The default is no grouping. If used, the \code{groups} argument shoud be a vector of values of the same length as the vector of residuals, for example \code{groups = subject} where \code{subject} indicates the grouping. } \item{linear}{If \code{TRUE}, adds a horizontal line at zero if no groups. With groups, display the within level of groups ols regression of the residuals as response and the horizontal axis as the regressor. } \item{quadratic}{ if \code{TRUE}, fits the quadratic regression of the vertical axis on the horizontal axis and displays a lack of fit test. Default is \code{TRUE} for \code{lm} and \code{FALSE} for \code{glm} or if \code{groups} not missing. } \item{smooth}{specifies the smoother to be used along with its arguments; if \code{FALSE}, which is the default except for generalized linear models, no smoother is shown; can be a list giving the smoother function and its named arguments; \code{TRUE} is equivalent to \code{list(smoother=loessLine, span=2/3, col=carPalette()[3])}, which is the default for a GLM. See \code{\link{ScatterplotSmoothers}} for the smoothers supplied by the \pkg{car} package and their arguments.} \item{id}{controls point identification; if \code{FALSE} (the default), no points are identified; can be a list of named arguments to the \code{\link{showLabels}} function; \code{TRUE} is equivalent to \code{list(method="r", n=2, cex=1, col=carPalette()[1], location="lr")}, which identifies the 2 points with the largest absolute residuals.} \item{col}{ default color for points. If groups is set, col can be a list at least as long as the number of levels for groups giving the colors for each groups. } \item{col.quad}{ default color for quadratic fit if groups is missing. Ignored if groups are used. } \item{pch}{plotting character. The default is pch=1. If groups are used, pch can be set to a vector at least as long as the number of groups. } \item{xlab}{ X-axis label. If not specified, a useful label is constructed by the function. } \item{ylab}{ Y-axis label. If not specified, a useful label is constructed by the function. } \item{lwd}{ line width for lines. } \item{lty}{ line type for quadratic. } \item{grid}{If TRUE, the default, a light-gray background grid is put on the graph} \item{key}{Should a key be added to the plot? Default is \code{!is.null(groups)}. } } \details{ \code{residualPlots} draws one or more residuals plots depending on the value of the \code{terms} and \code{fitted} arguments. If \code{terms = ~ .}, the default, then a plot is produced of residuals versus each first-order term in the formula used to create the model. Interaction terms, spline terms, and polynomial terms of more than one predictor are skipped. In addition terms that use the \dQuote{as-is} function, e.g., \code{I(X^2)}, will also be skipped unless you set the argument \code{AsIs=TRUE}. A plot of residuals versus fitted values is also included unless \code{fitted=FALSE}. In addition to plots, a table of curvature tests is displayed. For plots against a term in the model formula, say \code{X1}, the test displayed is the t-test for for \code{I(X1^2)} in the fit of \code{update, model, ~. + I(X1^2))}. Econometricians call this a specification test. For factors, the displayed plot is a boxplot, no curvature test is computed, and grouping is ignored. For fitted values in a linear model, the test is Tukey's one-degree-of-freedom test for nonadditivity. You can suppress the tests with the argument \code{tests=FALSE}. If grouping is used curvature tests are not displayed. \code{residualPlot}, which is called by \code{residualPlots}, should be viewed as an internal function, and is included here to display its arguments, which can be used with \code{residualPlots} as well. The \code{residualPlot} function returns the curvature test as an invisible result. \code{residCurvTest} computes the curvature test only. For any factors a boxplot will be drawn. For any polynomials, plots are against the linear term. Other non-standard predictors like B-splines are skipped. } \value{ For \code{lm} objects, returns a data.frame with one row for each plot drawn, one column for the curvature test statistic, and a second column for the corresponding p-value. This function is used primarily for its side effect of drawing residual plots. } \references{ Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition. Sage. Weisberg, S. (2014) \emph{Applied Linear Regression}, Fourth Edition, Wiley, Chapter 8} \author{Sanford Weisberg, \email{sandy@umn.edu}} \seealso{See Also \code{\link{lm}}, \code{\link{identify}}, \code{\link{showLabels}} } \examples{ m1 <- lm(prestige ~ income, data=Prestige) residualPlots(m1) residualPlots(m1, terms= ~ 1 | type) # plot vs. yhat grouping by type } \keyword{ hplot }% at least one, from doc/KEYWORDS \keyword{ regression }% __ONLY ONE__ keyword per line car/man/showLabels.Rd0000644000176000001440000001242314140261763014222 0ustar ripleyusers\name{showLabels} \Rdversion{1.1} \alias{showLabels} \title{ Functions to Identify and Mark Extreme Points in a 2D Plot. } \description{ This function is called by several graphical functions in the \pkg{car} package to mark extreme points in a 2D plot. Although the user is unlikely to call this function directly, the documentation below applies to all these other functions. } \usage{ showLabels(x, y, labels=NULL, method="identify", n = length(x), cex=1, col=carPalette()[1], location=c("lr", "ab", "avoid"), ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ Plotted horizontal coordinates. } \item{y}{ Plotted vertical coordinates. } \item{labels}{ Plotting labels. When called from within a \pkg{car} plotting function, the labels are automatically obtained from the row names in the data frame used to create the modeling object. If \code{labels=NULL}, case numbers will be used. If labels are long, the \code{\link{substr}} or \code{\link{abbreviate}} functions can be used to shorten them. Users may supply their own labels as a character vector of length equal to the number of plotted points. For use with \pkg{car} plotting functions, the number of plotted points is equal to the number of rows of data that have neither missing values nor are excluded using the `subset' argument. When called directly, the length of labels shoud equal the length of x. } \item{method}{ How points are to be identified. See Details below. } \item{n}{ Number of points to be identified. If set to 0, no points are identified. } \item{cex}{ Controls the size of the plotted labels. The default is \code{1}. } \item{col}{ Controls the color of the plotted labels. The default is the first element returned by \code{carPalette()}. } \item{location}{Where should the label be drawn? The default is \code{"lr"} to draw the label to the left of the point for points in the right-half of the graph and to the right for points in the left-half. The other option is \code{"ab"} for above the point for points below the middle of the graph and above the point below the middle. Finally, \code{"avoid"} tries to avoid over-plotting labels. } \item{...}{not used.} } \details{ The argument \code{method} determine how the points to be identified are selected. For the default value of \code{method="identify"}, the \code{\link{identify}} function is used to identify points interactively using the mouse. Up to \code{n} points can be identified, so if \code{n=0}, which is the default in many functions in the \pkg{car} package, then no point identification is done. Automatic point identification can be done depending on the value of the argument \code{method}. \itemize{ \item \code{method = "x"} select points according to their value of \code{abs(x - mean(x))} \item \code{method = "y"} select points according to their value of \code{abs(y - mean(y))} \item \code{method = "r"} select points according to their value of \code{abs(y)}, as may be appropriate in residual plots, or others with a meaningful origin at 0 \item \code{method = "mahal"} Treat \code{(x, y)} as if it were a bivariate sample, and select cases according to their Mahalanobis distance from \code{(mean(x), mean(y))} \item \code{method} can be a vector of the same length as \code{x} consisting of values to determine the points to be labeled. For example, for a linear model \code{m}, setting \code{method=cooks.distance(m)} will label the points corresponding to the largest values of Cook's distance, or \code{method = which(abs(residuals(m, type="pearson")) > 2} would label all observations with Pearson residuals greater than 2 in absolute value. Warning: If missing data are present, points may be incorrectly labelled. \item \code{method} can be a vector of case numbers or case-labels, in which case those cases will be labeled. Warning: If missing data are present, a list of case numbers may identify the wrong points. A list of case labels, however, will work correctly with missing values. \item \code{method = "none"} causes no point labels to be shown. } With \code{showLabels}, the \code{method} argument can be a list, so, for example \code{method=list("x", "y")} would label according to the horizontal and vertical axes variables. Finally, if the axes in the graph are logged, the function uses logged-variables where appropriate. } \value{ A function primarily used for its side-effect of drawing point labels on a plot. Returns invisibly the labels of the selected points, or NULL if no points are selected. Although intended for use with other functions in the \pkg{car} package, this function can be used directly. } \references{ Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. } \author{John Fox \email{jfox@mcmaster.ca}, Sanford Weisberg \email{sandy@umn.edu}} \seealso{\code{\link{avPlots}}, \code{\link{residualPlots}}, \code{\link{crPlots}}, \code{\link{leveragePlots}} } \examples{ plot(income ~ education, Prestige) with(Prestige, showLabels(education, income, labels = rownames(Prestige), method=list("x", "y"), n=3)) m <- lm(income ~ education, Prestige) plot(income ~ education, Prestige) abline(m) with(Prestige, showLabels(education, income, labels=rownames(Prestige), method=abs(residuals(m)), n=4)) } \keyword{ utilities } car/man/infIndexPlot.Rd0000644000176000001440000000723614140261763014530 0ustar ripleyusers\name{infIndexPlot} \alias{infIndexPlot} \alias{influenceIndexPlot} \alias{infIndexPlot.lm} \alias{infIndexPlot.lmerMod} \alias{infIndexPlot.influence.merMod} \alias{infIndexPlot.influence.lme} \title{Influence Index Plot} \description{ Provides index plots of influence and related diagnostics for a regression model. } \usage{ infIndexPlot(model, ...) influenceIndexPlot(model, ...) \method{infIndexPlot}{lm}(model, vars=c("Cook", "Studentized", "Bonf", "hat"), id=TRUE, grid=TRUE, main="Diagnostic Plots", ...) \method{infIndexPlot}{influence.merMod}(model, vars = c("dfbeta", "dfbetas", "var.cov.comps", "cookd"), id = TRUE, grid = TRUE, main = "Diagnostic Plots", ...) \method{infIndexPlot}{influence.lme}(model, vars = c("dfbeta", "dfbetas", "var.cov.comps", "cookd"), id = TRUE, grid = TRUE, main = "Diagnostic Plots", ...) } \arguments{ \item{model}{A regression object of class \code{lm}, \code{glm}, or \code{lmerMod}, or an influence object for a \code{lmer}, \code{glmer}, or \code{lme} object (see \code{\link{influence.mixed.models}}). The \code{"lmerMod"} method calls the \code{"lm"} method and can take the same arguments.} \item{vars}{ All the quantities listed in this argument are plotted. Use \code{"Cook"} for Cook's distances, \code{"Studentized"} for Studentized residuals, \code{"Bonf"} for Bonferroni p-values for an outlier test, and and \code{"hat"} for hat-values (or leverages) for a linear or generalized linear model, or \code{"dfbeta"}, \code{"dfbetas"}, \code{"var.cov.comps"}, and \code{"cookd"} for an influence object derived from a mixed model. Capitalization is optional. All but \code{"dfbeta"} and \code{"dfbetas"} may be abbreviated by the first one or more letters. } \item{main}{main title for graph} \item{id}{a list of named values controlling point labelling. The default, \code{TRUE}, is equivalent to \code{id=list(method="y", n=2, cex=1, col=carPalette()[1], location="lr")}; \code{FALSE} suppresses point labelling. See \code{\link{showLabels}} for details.} \item{grid}{If TRUE, the default, a light-gray background grid is put on the graph.} \item{\dots}{Arguments passed to \code{plot}} } \value{ Used for its side effect of producing a graph. Produces index plots of diagnostic quantities. } \references{ Cook, R. D. and Weisberg, S. (1999) \emph{Applied Regression, Including Computing and Graphics.} Wiley. Fox, J. (2016) \emph{Applied Regression Analysis and Generalized Linear Models}, Third Edition. Sage. Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. Weisberg, S. (2014) \emph{Applied Linear Regression}, Fourth Edition, Wiley. } \author{Sanford Weisberg \email{sandy@umn.edu} and John Fox} \seealso{ \code{\link{cooks.distance}}, \code{\link{rstudent}}, \code{\link{outlierTest}}, \code{\link{hatvalues}}, \code{\link{influence.mixed.models}}. } \examples{ influenceIndexPlot(lm(prestige ~ income + education + type, Duncan)) \dontrun{ # a little slow if (require(lme4)){ print(fm1 <- lmer(Reaction ~ Days + (Days | Subject), sleepstudy)) # from ?lmer infIndexPlot(influence(fm1, "Subject")) infIndexPlot(influence(fm1)) } if (require(lme4)){ gm1 <- glmer(cbind(incidence, size - incidence) ~ period + (1 | herd), data = cbpp, family = binomial) # from ?glmer infIndexPlot(influence(gm1, "herd", maxfun=100)) infIndexPlot(influence(gm1, maxfun=100)) gm1.11 <- update(gm1, subset = herd != 11) # check deleting herd 11 compareCoefs(gm1, gm1.11) } } } \keyword{ hplot }% at least one, from doc/KEYWORDS \keyword{ regression }% __ONLY ONE__ keyword per line car/man/influencePlot.Rd0000644000176000001440000000473114140261763014731 0ustar ripleyusers\name{influencePlot} \alias{influencePlot} \alias{influencePlot.lm} \alias{influencePlot.lmerMod} \alias{influence.plot} \title{Regression Influence Plot} \description{ This function creates a \dQuote{bubble} plot of Studentized residuals versus hat values, with the areas of the circles representing the observations proportional to the value Cook's distance. Vertical reference lines are drawn at twice and three times the average hat value, horizontal reference lines at -2, 0, and 2 on the Studentized-residual scale. } \usage{ influencePlot(model, ...) \method{influencePlot}{lm}(model, scale=10, xlab="Hat-Values", ylab="Studentized Residuals", id=TRUE, ...) \method{influencePlot}{lmerMod}(model, ...) } \arguments{ \item{model}{a linear, generalized-linear, or linear mixed model; the \code{"lmerMod"} method calls the \code{"lm"} method and can take the same arguments.} \item{scale}{a factor to adjust the size of the circles. } \item{xlab, ylab}{axis labels. } \item{id}{settings for labelling points; see \code{link{showLabels}} for details. To omit point labelling, set \code{id=FALSE}; the default, \code{id=TRUE} is equivalent to \code{id=list(method="noteworthy", n=2, cex=1, col=carPalette()[1], location="lr")}. The default \code{method="noteworthy"} is used only in this function and indicates setting labels for points with large Studentized residuals, hat-values or Cook's distances. Set \code{id=list(method="identify")} for interactive point identification.} \item{\dots}{arguments to pass to the \code{plot} and \code{points} functions.} } \value{ If points are identified, returns a data frame with the hat values, Studentized residuals and Cook's distance of the identified points. If no points are identified, nothing is returned. This function is primarily used for its side-effect of drawing a plot. } \references{ Fox, J. (2016) \emph{Applied Regression Analysis and Generalized Linear Models}, Third Edition. Sage. Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. } \author{John Fox \email{jfox@mcmaster.ca}, minor changes by S. Weisberg \email{sandy@umn.edu}} \seealso{\code{\link{cooks.distance}}, \code{\link{rstudent}}, \code{\link{hatvalues}}, \code{\link{showLabels}}} \examples{ influencePlot(lm(prestige ~ income + education, data=Duncan)) \dontrun{ influencePlot(lm(prestige ~ income + education, data=Duncan), id=list(method="identify")) } } \keyword{regression} car/man/Anova.Rd0000644000176000001440000004557714140261763013203 0ustar ripleyusers%------------------------------------------------------------------------------------- % Revision history: % checked in 2008-12-29 by J. Fox (corresponds to version 1.2-10 of car) % 2009-01-16 updated doc to correspond to changes in linearHypothesis. J. Fox % 2009-09-16 updated to reflect new singular.ok argument % 2009-09-26 updated for removal from car. J. Fox % 2009-12-22 updated to reflect new imatrix argument to Anova.mlm(). J. Fox % 2012-02-28 updated to reflect new test.statistic argument to Anova.mer(). J. Fox % 2012-03-01 removed commented-out output listings. J. Fox % 2013-06-17 update for summary.Anova.mlm and print.summary.Anova.mlm. J. Fox % 2013-06-20 added Anova.merMod(). J. Fox % 2014-08-09: added vcov. argument to Anova.lm(). J. Fox % 2014-09-23: added Anova.rlm(). J. Fox % 2015-02-18: updated info about when Anova.default() works. J. Fox % 2015-09-04: added Anova.coxme(). J. Fox % 2016-06-03: added SSP and SSPE arguments to print.summary.ANova.mlm(). J. Fox % 2016-06-25: provision to print univariate ANOVAs for a mlm. J. Fox % 2017-11-02: added warning about KR F-tests % 2017-11-07: make compatible with vcov() in re-devel. J. Fox % 2021-06-14: updates for vcov. arg. J. Fox %------------------------------------------------------------------------------------- \name{Anova} \alias{Anova} \alias{Anova.lm} \alias{Anova.lme} \alias{Anova.aov} \alias{Anova.glm} \alias{Anova.multinom} \alias{Anova.polr} \alias{Anova.mer} \alias{Anova.merMod} \alias{Anova.mlm} \alias{Anova.manova} \alias{Manova} \alias{Manova.mlm} \alias{print.Anova.mlm} \alias{summary.Anova.mlm} \alias{print.summary.Anova.mlm} \alias{print.univaov} \alias{as.data.frame.univaov} \alias{Anova.coxph} \alias{Anova.svyglm} \alias{Anova.rlm} \alias{Anova.coxme} \alias{Anova.default} \title{Anova Tables for Various Statistical Models} \description{ Calculates type-II or type-III analysis-of-variance tables for model objects produced by \code{lm}, \code{glm}, \code{multinom} (in the \pkg{nnet} package), \code{polr} (in the \pkg{MASS} package), \code{coxph} (in the \pkg{survival} package), \code{coxme} (in the \pkg{coxme} pckage), \code{svyglm} (in the \pkg{survey} package), \code{rlm} (in the \pkg{MASS} package), \code{lmer} in the \pkg{lme4} package, \code{lme} in the \pkg{nlme} package, and (by the default method) for most models with a linear predictor and asymptotically normal coefficients (see details below). For linear models, F-tests are calculated; for generalized linear models, likelihood-ratio chisquare, Wald chisquare, or F-tests are calculated; for multinomial logit and proportional-odds logit models, likelihood-ratio tests are calculated. Various test statistics are provided for multivariate linear models produced by \code{lm} or \code{manova}. Partial-likelihood-ratio tests or Wald tests are provided for Cox models. Wald chi-square tests are provided for fixed effects in linear and generalized linear mixed-effects models. Wald chi-square or F tests are provided in the default case. } \usage{ Anova(mod, ...) Manova(mod, ...) \method{Anova}{lm}(mod, error, type=c("II","III", 2, 3), white.adjust=c(FALSE, TRUE, "hc3", "hc0", "hc1", "hc2", "hc4"), vcov.=NULL, singular.ok, ...) \method{Anova}{aov}(mod, ...) \method{Anova}{glm}(mod, type=c("II","III", 2, 3), test.statistic=c("LR", "Wald", "F"), error, error.estimate=c("pearson", "dispersion", "deviance"), vcov.=vcov(mod, complete=TRUE), singular.ok, ...) \method{Anova}{multinom}(mod, type = c("II","III", 2, 3), ...) \method{Anova}{polr}(mod, type = c("II","III", 2, 3), ...) \method{Anova}{mlm}(mod, type=c("II","III", 2, 3), SSPE, error.df, idata, idesign, icontrasts=c("contr.sum", "contr.poly"), imatrix, test.statistic=c("Pillai", "Wilks", "Hotelling-Lawley", "Roy"),...) \method{Anova}{manova}(mod, ...) \method{Manova}{mlm}(mod, ...) \method{print}{Anova.mlm}(x, ...) \method{summary}{Anova.mlm}(object, test.statistic, univariate=object$repeated, multivariate=TRUE, p.adjust.method, ...) \method{print}{summary.Anova.mlm}(x, digits = getOption("digits"), SSP=TRUE, SSPE=SSP, ... ) \method{print}{univaov}(x, digits = max(getOption("digits") - 2L, 3L), style=c("wide", "long"), by=c("response", "term"), ...) \method{as.data.frame}{univaov}(x, row.names, optional, by=c("response", "term"), ...) \method{Anova}{coxph}(mod, type=c("II", "III", 2, 3), test.statistic=c("LR", "Wald"), ...) \method{Anova}{coxme}(mod, type=c("II", "III", 2, 3), test.statistic=c("Wald", "LR"), ...) \method{Anova}{lme}(mod, type=c("II","III", 2, 3), vcov.=vcov(mod, complete=FALSE), singular.ok, ...) \method{Anova}{mer}(mod, type=c("II", "III", 2, 3), test.statistic=c("Chisq", "F"), vcov.=vcov(mod, complete=FALSE), singular.ok, ...) \method{Anova}{merMod}(mod, type=c("II", "III", 2, 3), test.statistic=c("Chisq", "F"), vcov.=vcov(mod, complete=FALSE), singular.ok, ...) \method{Anova}{svyglm}(mod, ...) \method{Anova}{rlm}(mod, ...) \method{Anova}{default}(mod, type=c("II", "III", 2, 3), test.statistic=c("Chisq", "F"), vcov.=vcov(mod, complete=FALSE), singular.ok, ...) } \arguments{ \item{mod}{\code{lm}, \code{aov}, \code{glm}, \code{multinom}, \code{polr} \code{mlm}, \code{coxph}, \code{coxme}, \code{lme}, \code{mer}, \code{merMod}, \code{svyglm}, \code{rlm}, or other suitable model object.} \item{error}{for a linear model, an \code{lm} model object from which the error sum of squares and degrees of freedom are to be calculated. For F-tests for a generalized linear model, a \code{glm} object from which the dispersion is to be estimated. If not specified, \code{mod} is used.} \item{type}{type of test, \code{"II"}, \code{"III"}, \code{2}, or \code{3}. Roman numerals are equivalent to the corresponding Arabic numerals.} \item{singular.ok}{defaults to \code{TRUE} for type-II tests, and \code{FALSE} for type-III tests where the tests for models with aliased coefficients will not be straightforwardly interpretable; if \code{FALSE}, a model with aliased coefficients produces an error.} \item{test.statistic}{for a generalized linear model, whether to calculate \code{"LR"} (likelihood-ratio), \code{"Wald"}, or \code{"F"} tests; for a Cox or Cox mixed-effects model, whether to calculate \code{"LR"} (partial-likelihood ratio) or \code{"Wald"} tests; in the default case or for linear mixed models fit by \code{lmer}, whether to calculate Wald \code{"Chisq"} or Kenward-Roger \code{"F"} tests with Satterthwaite degrees of freedom (\emph{warning:} the KR F-tests can be very time-consuming). For a multivariate linear model, the multivariate test statistic to compute --- one of \code{"Pillai"}, \code{"Wilks"}, \code{"Hotelling-Lawley"}, or \code{"Roy"}, with \code{"Pillai"} as the default. The \code{summary} method for \code{Anova.mlm} objects permits the specification of more than one multivariate test statistic, and the default is to report all four.} \item{error.estimate}{for F-tests for a generalized linear model, base the dispersion estimate on the Pearson residuals (\code{"pearson"}, the default); use the dispersion estimate in the model object (\code{"dispersion"}); or base the dispersion estimate on the residual deviance (\code{"deviance"}). For binomial or Poisson GLMs, where the dispersion is fixed to 1, setting \code{error.estimate="dispersion"} is changed to \code{"pearson"}, with a warning.} \item{white.adjust}{if not \code{FALSE}, the default, tests use a heteroscedasticity-corrected coefficient covariance matrix; the various values of the argument specify different corrections. See the documentation for \code{\link{hccm}} for details. If \code{white.adjust=TRUE} then the \code{"hc3"} correction is selected.} \item{SSPE}{For \code{Anova} for a multivariate linear model, the error sum-of-squares-and-products matrix; if missing, will be computed from the residuals of the model; for the \code{print} method for the \code{summary} of an \code{Anova} of a multivariate linear model, whether or not to print the error SSP matrix (defaults to \code{TRUE}).} \item{SSP}{if \code{TRUE} (the default), print the sum-of-squares and cross-products matrix for the hypothesis and the response-transformation matrix.} \item{error.df}{The degrees of freedom for error; if missing, will be taken from the model.} \item{idata}{an optional data frame giving a factor or factors defining the intra-subject model for multivariate repeated-measures data. See \emph{Details} for an explanation of the intra-subject design and for further explanation of the other arguments relating to intra-subject factors.} \item{idesign}{a one-sided model formula using the ``data'' in \code{idata} and specifying the intra-subject design.} \item{icontrasts}{names of contrast-generating functions to be applied by default to factors and ordered factors, respectively, in the within-subject ``data''; the contrasts must produce an intra-subject model matrix in which different terms are orthogonal. The default is \code{c("contr.sum", "contr.poly")}.} \item{imatrix}{as an alternative to specifying \code{idata}, \code{idesign}, and (optionally) \code{icontrasts}, the model matrix for the within-subject design can be given directly in the form of list of named elements. Each element gives the columns of the within-subject model matrix for a term to be tested, and must have as many rows as there are responses; the columns of the within-subject model matrix for different terms must be mutually orthogonal.} \item{x, object}{object of class \code{"Anova.mlm"} to print or summarize.} \item{multivariate, univariate}{compute and print multivariate and univariate tests for a repeated-measures ANOVA or multivariate linear model; the default is \code{TRUE} for both for repeated measures and \code{TRUE} for \code{multivariate} for a multivariate linear model.} \item{p.adjust.method}{if given for a multivariate linear model when univariate tests are requested, the univariate tests are corrected for simultaneous inference by term; if specified, should be one of the methods recognized by \code{\link{p.adjust}} or \code{TRUE}, in which case the default (Holm) adjustment is used.} \item{digits}{minimum number of significant digits to print.} \item{style}{for printing univariate tests if requested for a multivariate linear model; one of \code{"wide"}, the default, or \code{"long"}.} \item{by}{if univariate tests are printed in \code{"long"} \code{style}, they can be ordered \code{by} \code{"response"}, the default, or by \code{"term"}.} \item{row.names, optional}{not used.} \item{vcov.}{in the \code{default} method, an optional coefficient-covariance matrix or function to compute a covariance matrix, computed by default by applying the generic \code{vcov} function to the model object. A similar argument may be supplied to the \code{lm} method, and the default (\code{NULL}) is to ignore the argument; if both \code{vcov.} and \code{white.adjust} are supplied to the \code{lm} method, the latter is used.} In the \code{glm} method, \code{vcov.} is ignored unless \code{test="Wald"}; in the \code{mer} and \code{merMod} methods, \code{vcov.} is ignored if \code{test="F"}. \item{\dots}{do not use.} } \details{ The designations "type-II" and "type-III" are borrowed from SAS, but the definitions used here do not correspond precisely to those employed by SAS. Type-II tests are calculated according to the principle of marginality, testing each term after all others, except ignoring the term's higher-order relatives; so-called type-III tests violate marginality, testing each term in the model after all of the others. This definition of Type-II tests corresponds to the tests produced by SAS for analysis-of-variance models, where all of the predictors are factors, but not more generally (i.e., when there are quantitative predictors). Be very careful in formulating the model for type-III tests, or the hypotheses tested will not make sense. As implemented here, type-II Wald tests are a generalization of the linear hypotheses used to generate these tests in linear models. For tests for linear models, multivariate linear models, and Wald tests for generalized linear models, Cox models, mixed-effects models, generalized linear models fit to survey data, and in the default case, \code{Anova} finds the test statistics without refitting the model. The \code{svyglm} method simply calls the \code{default} method and therefore can take the same arguments. The standard R \code{anova} function calculates sequential ("type-I") tests. These rarely test interesting hypotheses in unbalanced designs. A MANOVA for a multivariate linear model (i.e., an object of class \code{"mlm"} or \code{"manova"}) can optionally include an intra-subject repeated-measures design. If the intra-subject design is absent (the default), the multivariate tests concern all of the response variables. To specify a repeated-measures design, a data frame is provided defining the repeated-measures factor or factors via \code{idata}, with default contrasts given by the \code{icontrasts} argument. An intra-subject model-matrix is generated from the formula specified by the \code{idesign} argument; columns of the model matrix corresponding to different terms in the intra-subject model must be orthogonal (as is insured by the default contrasts). Note that the contrasts given in \code{icontrasts} can be overridden by assigning specific contrasts to the factors in \code{idata}. As an alternative, the within-subjects model matrix can be specified directly via the \code{imatrix} argument. \code{Manova} is essentially a synonym for \code{Anova} for multivariate linear models. If univariate tests are requested for the \code{summary} of a multivariate linear model, the object returned contains a \code{univaov} component of \code{"univaov"}; \code{print} and \code{as.data.frame} methods are provided for the \code{"univaov"} class. For the default method to work, the model object must contain a standard \code{terms} element, and must respond to the \code{vcov}, \code{coef}, and \code{model.matrix} functions. If any of these requirements is missing, then it may be possible to supply it reasonably simply (e.g., by writing a missing \code{vcov} method for the class of the model object). } \value{ An object of class \code{"anova"}, or \code{"Anova.mlm"}, which usually is printed. For objects of class \code{"Anova.mlm"}, there is also a \code{summary} method, which provides much more detail than the \code{print} method about the MANOVA, including traditional mixed-model univariate F-tests with Greenhouse-Geisser and Huynh-Feldt corrections. } \references{ Fox, J. (2016) \emph{Applied Regression Analysis and Generalized Linear Models}, Third Edition. Sage. Fox, J. and Weisberg, S. (2019) \emph{An R Companion to Applied Regression}, Third Edition, Sage. Hand, D. J., and Taylor, C. C. (1987) \emph{Multivariate Analysis of Variance and Repeated Measures: A Practical Approach for Behavioural Scientists.} Chapman and Hall. O'Brien, R. G., and Kaiser, M. K. (1985) MANOVA method for analyzing repeated measures designs: An extensive primer. \emph{Psychological Bulletin} \bold{97}, 316--333. } \author{John Fox \email{jfox@mcmaster.ca}; the code for the Mauchly test and Greenhouse-Geisser and Huynh-Feldt corrections for non-spericity in repeated-measures ANOVA are adapted from the functions \code{stats:::stats:::mauchly.test.SSD} and \code{stats:::sphericity} by R Core; \code{summary.Anova.mlm} and \code{print.summary.Anova.mlm} incorporates code contributed by Gabriel Baud-Bovy.} \section{Warning}{ Be careful of type-III tests: For a traditional multifactor ANOVA model with interactions, for example, these tests will normally only be sensible when using contrasts that, for different terms, are orthogonal in the row-basis of the model, such as those produced by \code{\link{contr.sum}}, \code{\link{contr.poly}}, or \code{\link{contr.helmert}}, but \emph{not} by the default \code{\link{contr.treatment}}. In a model that contains factors, numeric covariates, and interactions, main-effect tests for factors will be for differences over the origin. In contrast (pun intended), type-II tests are invariant with respect to (full-rank) contrast coding. If you don't understand this issue, then you probably shouldn't use \code{Anova} for type-III tests. } \seealso{ \code{\link{linearHypothesis}}, \code{\link{anova}} \code{\link{anova.lm}}, \code{\link{anova.glm}}, \code{\link{anova.mlm}}, \code{\link{anova.coxph}}, \code{\link[survey]{svyglm}}.} \examples{ ## Two-Way Anova mod <- lm(conformity ~ fcategory*partner.status, data=Moore, contrasts=list(fcategory=contr.sum, partner.status=contr.sum)) Anova(mod) Anova(mod, type=3) # note use of contr.sum in call to lm() ## One-Way MANOVA ## See ?Pottery for a description of the data set used in this example. summary(Anova(lm(cbind(Al, Fe, Mg, Ca, Na) ~ Site, data=Pottery))) ## MANOVA for a randomized block design (example courtesy of Michael Friendly: ## See ?Soils for description of the data set) soils.mod <- lm(cbind(pH,N,Dens,P,Ca,Mg,K,Na,Conduc) ~ Block + Contour*Depth, data=Soils) Manova(soils.mod) summary(Anova(soils.mod), univariate=TRUE, multivariate=FALSE, p.adjust.method=TRUE) ## a multivariate linear model for repeated-measures data ## See ?OBrienKaiser for a description of the data set used in this example. phase <- factor(rep(c("pretest", "posttest", "followup"), c(5, 5, 5)), levels=c("pretest", "posttest", "followup")) hour <- ordered(rep(1:5, 3)) idata <- data.frame(phase, hour) idata mod.ok <- lm(cbind(pre.1, pre.2, pre.3, pre.4, pre.5, post.1, post.2, post.3, post.4, post.5, fup.1, fup.2, fup.3, fup.4, fup.5) ~ treatment*gender, data=OBrienKaiser) (av.ok <- Anova(mod.ok, idata=idata, idesign=~phase*hour)) summary(av.ok, multivariate=FALSE) ## A "doubly multivariate" design with two distinct repeated-measures variables ## (example courtesy of Michael Friendly) ## See ?WeightLoss for a description of the dataset. imatrix <- matrix(c( 1,0,-1, 1, 0, 0, 1,0, 0,-2, 0, 0, 1,0, 1, 1, 0, 0, 0,1, 0, 0,-1, 1, 0,1, 0, 0, 0,-2, 0,1, 0, 0, 1, 1), 6, 6, byrow=TRUE) colnames(imatrix) <- c("WL", "SE", "WL.L", "WL.Q", "SE.L", "SE.Q") rownames(imatrix) <- colnames(WeightLoss)[-1] (imatrix <- list(measure=imatrix[,1:2], month=imatrix[,3:6])) contrasts(WeightLoss$group) <- matrix(c(-2,1,1, 0,-1,1), ncol=2) (wl.mod<-lm(cbind(wl1, wl2, wl3, se1, se2, se3)~group, data=WeightLoss)) Anova(wl.mod, imatrix=imatrix, test="Roy") ## mixed-effects models examples: \dontrun{ library(nlme) example(lme) Anova(fm2) } \dontrun{ library(lme4) example(glmer) Anova(gm1) } } \keyword{htest} \keyword{models} \keyword{regression} car/DESCRIPTION0000644000176000001440000000547714141412044012565 0ustar ripleyusersPackage: car Version: 3.0-12 Date: 2021-11-02 Title: Companion to Applied Regression Authors@R: c(person("John", "Fox", role = c("aut", "cre"), email = "jfox@mcmaster.ca"), person("Sanford", "Weisberg", role = "aut", email = "sandy@umn.edu"), person("Brad", "Price", role = "aut", email = "brad.price@mail.wvu.edu"), person("Daniel", "Adler", role="ctb"), person("Douglas", "Bates", role = "ctb"), person("Gabriel", "Baud-Bovy", role = "ctb"), person("Ben", "Bolker", role="ctb"), person("Steve", "Ellison", role="ctb"), person("David", "Firth", role = "ctb"), person("Michael", "Friendly", role = "ctb"), person("Gregor", "Gorjanc", role = "ctb"), person("Spencer", "Graves", role = "ctb"), person("Richard", "Heiberger", role = "ctb"), person("Pavel", "Krivitsky", role = "ctb"), person("Rafael", "Laboissiere", role = "ctb"), person("Martin", "Maechler", role="ctb"), person("Georges", "Monette", role = "ctb"), person("Duncan", "Murdoch", role="ctb"), person("Henric", "Nilsson", role = "ctb"), person("Derek", "Ogle", role = "ctb"), person("Brian", "Ripley", role = "ctb"), person("William", "Venables", role = "ctb"), person("Steve", "Walker", role="ctb"), person("David", "Winsemius", role="ctb"), person("Achim", "Zeileis", role = "ctb"), person("R-Core", role="ctb")) Depends: R (>= 3.5.0), carData (>= 3.0-0) Imports: abind, MASS, mgcv, nnet, pbkrtest (>= 0.4-4), quantreg, grDevices, utils, stats, graphics, maptools, lme4 (>= 1.1-27.1), nlme Suggests: alr4, boot, coxme, effects, knitr, leaps, lmtest, Matrix, MatrixModels, rgl (>= 0.93.960), rio, sandwich, SparseM, survival, survey ByteCompile: yes LazyLoad: yes Description: Functions to Accompany J. Fox and S. Weisberg, An R Companion to Applied Regression, Third Edition, Sage, 2019. License: GPL (>= 2) URL: https://r-forge.r-project.org/projects/car/, https://CRAN.R-project.org/package=car, https://socialsciences.mcmaster.ca/jfox/Books/Companion/index.html VignetteBuilder: knitr NeedsCompilation: no Packaged: 2021-11-02 20:02:44 UTC; zeileis Author: John Fox [aut, cre], Sanford Weisberg [aut], Brad Price [aut], Daniel Adler [ctb], Douglas Bates [ctb], Gabriel Baud-Bovy [ctb], Ben Bolker [ctb], Steve Ellison [ctb], David Firth [ctb], Michael Friendly [ctb], Gregor Gorjanc [ctb], Spencer Graves [ctb], Richard Heiberger [ctb], Pavel Krivitsky [ctb], Rafael Laboissiere [ctb], Martin Maechler [ctb], Georges Monette [ctb], Duncan Murdoch [ctb], Henric Nilsson [ctb], Derek Ogle [ctb], Brian Ripley [ctb], William Venables [ctb], Steve Walker [ctb], David Winsemius [ctb], Achim Zeileis [ctb], R-Core [ctb] Maintainer: John Fox Repository: CRAN Date/Publication: 2021-11-06 05:35:32 UTC car/build/0000755000176000001440000000000014140314544012146 5ustar ripleyuserscar/build/vignette.rds0000644000176000001440000000033314140314544014504 0ustar ripleyusersuQ0 Q0$&W/|MNVA7\, 6i%Ģ&A"\kVw'OԢR ~`kS \OF zYƤt!Yze%H??~iQV{E5rf5PcE"qQԟy!LSm0qС&S.g5 'pcar/vignettes/0000755000176000001440000000000014140314544013057 5ustar ripleyuserscar/vignettes/embedding.bib0000644000176000001440000000071314140261762015457 0ustar ripleyusers @BOOK{FoxWeisberg19, author = {J. Fox and S. Weisberg}, year = 2019, title = {An {R} Companion to Applied Regression}, edition={3rd}, publisher = {Sage}, address = {Thousand Oaks {CA}}, url={http://z.umn.edu/carbook} } @techreport{FoxWeisberg12, author = {J. Fox and S. Weisberg}, year = 2012, title = {Bootstrapping Regression Models in {R}}, url={http://socserv.mcmaster.ca/jfox/Books/Companion/appendix/Appendix-Bootstrapping.pdf} } car/vignettes/embedding.Rnw0000644000176000001440000001221314140261762015467 0ustar ripleyusers\documentclass{article} \usepackage{url,Sweave} %\VignetteIndexEntry{Using car functions inside user functions} \newcommand{\R}{{\normalfont\textsf{R}}{}} \newcommand{\car}{\texttt{car}} \newcommand{\effects}{\texttt{effects}} \newcommand{\code}[1]{\texttt{#1}} \usepackage[authoryear,round]{natbib} \bibliographystyle{plainnat} <>= library(knitr) library(effects) library(car) render_sweave() options(width=80, digits=4, useFancyQuotes=FALSE, prompt=" ", continue=" ") @ \title{Using \car{} and \code{effects} Functions in Other Functions} \author{John Fox\footnote{Department of Sociology, McMaster University} \&{} Sanford Weisberg\footnote{ School of Statistics, University of Minnesota}} \date{\today} \SweaveOpts{concordance=TRUE} \begin{document} \maketitle \begin{abstract} The \car{} package \citep{FoxWeisberg19} provides many functions that are applied to a fitted regression model, perform additional calculations on the model or possibly compute a different model, and then return values and graphs. In some cases, users may wish to write functions that call functions in \car{} for a particular purpose. Because of the scoping rules used in \R{}, several functions in \car{} that work when called from the command prompt may fail when called inside another function. We discuss how users can modify their programs to avoid this problem. \end{abstract} Some users of the \code{car} and \code{effects} package have found it convenient to write their own functions that call the functions in \code{car} or \code{effects}. While this will generally occur as expected, in some instances calls to \code{car} or \code{effects} functions will fail because the results of an input fitted model may not be available inside a user-written function. This brief note describes how this problem can be solved. For an illustration of the problem, the function \code{car::ncvTest} \citep[Sec.~8.5.1]{FoxWeisberg19} computes tests for non-constant variance in linear models as a function of the mean, the default, or any other linear function of regressors, even for regressors not part of the mean function. For example, <<>>= m2 <- lm(prestige ~ education, data=carData::Prestige) car::ncvTest(m2, ~ income) @ This fits \texttt{prestige} as a linear function of \texttt{education}, and tests for nonconstant variance as a function of \texttt{income}, another regressor in the data set \texttt{Prestige}. Embedding this in a function fails: <>= f3 <- function(meanmod, dta, varmod) { m3 <- lm(meanmod, dta) car::ncvTest(m3, varmod) } f3(meanmod=prestige ~ education, dta=carData::Prestige, varmod ~ income) @ \begin{Schunk} \begin{Soutput} Error in eval(data, envir = environment(formula(model))) : object 'dta' not found \end{Soutput} \end{Schunk} The arguments \code{dta} and \code{meanmod} are defined in the environment of the function, but the call to \code{lm} looks for them in the global environment, and they are therefore invisible when \code{lm} is called. A solution is to copy \code{dta} to the global environment. <<>>= f4 <- function(meanmod, dta, varmod) { assign(".dta", dta, envir=.GlobalEnv) assign(".meanmod", meanmod, envir=.GlobalEnv) m1 <- lm(.meanmod, .dta) ans <- car::ncvTest(m1, varmod) remove(".dta", envir=.GlobalEnv) remove(".meanmod", envir=.GlobalEnv) ans } f4(prestige ~ education, carData::Prestige, ~income) @ The \code{assign} function copies the \code{dta} and \code{meanmod} arguments to the global environment where \code{ncvTest} will be evaluated, and the \code{remove} function removes them before exiting the function. This is an inherently problematic strategy, because an object assigned in the global environment will replace an existing object of the same name. Consequently we renamed the \code{dta} argument \code{.dta}, with an initial period, but this is not a \emph{guarantee} that there was no preexisting object with this name. The functions \code{effects::Effect} and \code{effects::predictorEffect} may fail similarly when embedded in user-written functions because of scoping. Assigning arguments to the global environment as illustrated with the \code{car::ncvTest} function can again be applied. The following function will fail: <>= fc <- function(dta, formula, terms) { if (!require("effects")) stop("effects package unavailable") print(m1 <- lm(formula, dta)) Effect(terms, m1) } form <- prestige ~ income*type + education terms <- c("income", "type") fc(carData::Duncan, form, terms) @ \begin{Schunk} \begin{Soutput} Error in is.data.frame(data) : object 'dta' not found \end{Soutput} \end{Schunk} Assigning \code{.dta} to the global environment solves the problem: <<>>= fc.working <- function(dta, formula, terms) { if (!require("effects")) stop("effects package unavailable") assign(".dta", dta, env=.GlobalEnv) print(m1 <- lm(formula, .dta)) e1 <- Effect(terms, m1) remove(".dta", envir=.GlobalEnv) e1 } form <- prestige ~ income*type + education terms <- c("income", "type") fc.working(carData::Duncan, form, terms) @ Assigning \code{formula} to the global environment is not necessary here because it is used by \code{lm} but not by \code{Effect}. \bibliography{embedding} \end{document} car/NEWS0000644000176000001440000011776314140314134011560 0ustar ripleyusersChanges to Version 3.0-12 o hccm() now reports an interpretable error, except for type = "hc0" or "hc1", when there are cases with hatvalues = 1 (following problem reported by Peng Ding). o Fix bug in rownames in dfbetasPlots.lm() (reported by Shu Fai Cheun). o Package 'rio' was moved from Imports to Suggests. Both Import() and Export() now check for the availability of 'rio' first and report an error otherwise. Changes to Version 3.0-11 o boxCox() function now allows the use of any of the usual graphics parameters in the plot() function. If particuar boxCox(model, main="my title") will add a title to the plot, and boxCox(model, main="") will suppress it. o car::Boot(object, method="residual") will work for method="residual" only if the car package has been previously attached via either library(car) or require(car). o Added error checking with vcov. argument. Changed vcov.boot to print a warning of bootstrap replicates that returned NA o Introduced brief.tbl(), which simply calls print(), to cope with changes to tibbles. o qqPlot() fills (shades) confidence envelopes by default, and smoothers for scatterplots fill variance (spread) envelopes by default (suggestions of Michael Friendly). o Fixed problem in infIndexPlot.influence.lme() (reported by Francis L. Huang). o New "polr" and "svyolr" methods for vif() (following report by Abra Jeffers). o Make linearHypothesis() and Anova() work with "svyolr" objects via their default methods. o Regularize handling of vcov. argument in Anova() and linearHypothesis(). o vcov. argument now works with Anova() for models produced by lme4::lmer() and glmer(), (fixing a bug reported by Amy MacDougall). o New linearHypothesis.lmList() method. o New "lm" method for symbox(). o New cex and pt.wts arguments for avPlot() "lm" and "glm" methods, and for mcPlot.lm(). o Fix handling of imatrix argument to Anova.mlm() (suggestion of Benedikt Langenberg). o Remove influence.merMod() and related methods in favor of versions of these methods in the lme4 package. o Rewrite "embedding" vignette. o Small fixes and improvements. Changes to Version 3.0-10 o Fixed as error when using parameter name "(Intercept)" with deltaMethod(). o Several changes to Boot() to correct bugs, support the plinear algorithm, to correct use of weights for lm, and allow use of weights for nls. o Fix quantregLine() to work with development version 5.69 of quantreg package (following heads-up from Roger Koenker). Changes to Version 3.0-9 o Declare linearHypothesis.survreg() method, previously omitted from NAMESPACE (following question by Robert Dinterman); tweaks to survreg methods for linearHypothesis(), Anova(), and deltaMethod() to make them more robust. o Fix bug in hccm() when model matrix includes just one column (reported by Justin Yap). o Fix buglet in scatterplotMatrix.formula() when groups specified. o Several functions are now generic: avPlots(), ceresPlots(), crPlots(), mcPlots(). o Enable spread smoothers for crPlot(), ceresPlot(), and residualPlot() (suggestion of Dave Armstrong). o Small changes to docs. Changes to Version 3.0-8 o Import() now defaults to stringsAsFactors=FALSE to match the default behavior of read.table() as of R 4.0.0. o New strings2factors() function to convert character variables in a data frame to factors. o Added data.frame method for S(). o Fixed a bug in estimateTransform.lm() that returned the correct answer with an unneeded warning. o Fixed Anova.coxph() to handle weights properly (problem reported by Daniel Morillo Cuadrado). Changes to Version 3.0-7 o Fixed boxCox(), powerTransform() to work when 'car' package is not attached o Fixed Anova() to work with "lme" models without an intercept (to fix bug reported by Benjamin Tyner). Changes to Version 3.0-6 o Explicitly import utils::globalVariables() (suggestion of Vince Carey). Changes to Version 3.0-5 o Change class(x) == "y" to inherits(x, "y") throughout code (thanks to Martin Maechler). Changes to Version 3.0-4 o Scoping improvements to deltaMethod(), which now also takes an optional hypothesized value; contribution and suggestion by Pavel Krivitsky. o Make Anova() work for coxph() models with strata (following problem reported by Susan Galloway Hilsenbeck). o Modify carPalette() to provide a colorblind-friendly palette as an option (suggestion of Sercan Kahveci). o Small improvements. Changes to Version 3.0-3 o Fixed a bug in mmp.glm, so the horizontal axis for the default plot is the linear predictor, not the fitted values. o Fixed a bug in estimatePower.bncPowerlmer when the shift parameter is too close to the lower bound, thanks to Wouter van der Bijl o Fixed a bug in brief.lm the caused an error with rank-deficient models. o Fixed a bug in deltaMethod() when a variable in the model is named "g" (reported by Chris Andrews.) o Added a title argument to mcPlots o influence.merMod() and influence.lme() now support parallel computations. o Fix a bug in gamLine() to return values in the response scale, rather than the linear predictor scale, for glms. o Fixed a bug that caused the error argument to be ignored in Anova() for type-III tests in linear models (reported by Austin Hurst). o New lmerMod method for influencePlot(), infIndexPlot(), and outlierTest(). o Made scatterplot.formula() more robust. o Fixed qqPlot() to respect order of factor levels when plotting by groups (suggestion of Vilmantas Gegzna). o Fixed bug in S.multinom() that exponentiated coefficients twice (reported by Thamron Keowmani). o Made several S() methods tolerant of models with just one coefficient or, for multinom model, 2 response levels (problem reported for S.polr() by Thamron Keowmani). o Added carHexsticker(). o Updated CITATION file. o Small corrections. Changes to Version 3.0-2 o Include unexported copy of rather than import utils::askYesNo(), which doesn't exist before R 3.5.0. To be reversed in car 3.0-3 which will require R >= 3.5.0 o Fix a bug in confint.boot() and hence Confint.boot() that always set level=0.95 when confint when function falls back to type="perc" (reported by Derek Lee Sonderegger). Changes to Version 3.0-1 o Fix a bug in 'Boot()' so lm and glm models work with transformed predictors like log(x) or I(x-34). o For 'smooth' argument to scatterplot() and scatterPlot matrix(), the 'smooth' subargument is replaced by a new argument 'var', and 'lty.smooth', 'col.smooth', 'lwd.smooth' are replaced by 'lty.var', 'col.var' and 'lwd.var', respectively, although the old arguments are still allowed. o Mofidied man page for showLabels() to clarify setting the labels argument o Too few colors in scatterplot() and scatterplotMatrix() now produces a warning rather than an error (suggestion of John Maindonald). o Bug fix to Boot.nlm() (reported by Derek Ogle). o Fixed bug in linearHypothesis() for lmer() models using pbkrtest (following report by Francois Piraux). This bug indirectly affected Anova(). o Fixed bug in scatterplot() when groups variable is not a factor (reported by Alexandre Courtiol). o Fixed bug in scatterplot() when legend=FALSE (reported by Castor Guisande). o Fixed bug in influence.merMod() and influence.lme() when there is more than one grouping variable (reported by Maarten Jung). o Make model.matrix.lme() more bullet proof (following report by Peter Grossmann). o Anova.lm() now doesn't permit non-standard coefficient covariance matrix for model with aliased coefficients (following report by Ariel Muldoon). o Added kernel functions depan() and dbiwt() for use with adaptiveKernel(). o Updated carWeb(). o Small improvements. o Small edits to docs. Changes to Version 3.0-0 o This version of the package corresponds to the third edition of Fox and Weisberg, An R Companion to Applied Regression (Sage, forthcoming). o Reorganized plotting functions. o Functions deprecated in 2009 are now defunct. o bootCase(), nextBoot(), and their methods are now deprecated in favor of Boot(). o All data sets moved to the carData package. o Improved handling of imports (suggestion of Jonathon Love). o Changed as.factor.result argument in recode() to as.factor, and as.numeric.result to as.numeric. o New brief(), Confint(), Predict(), Tapply(), S() functions. o New poTest() function for testing for proportional odds in "polr" models. o New deletion diagnostics for mixed-effects models, e.g., influence.merMod(). o Fixed bug in LinearHypothesis.merMod() when rhs of "F" test is specified (reported by Patrick Forscher). o Anova.lm() now computes SSs by model comparison for models with aliased coefficients (response to problem reported by Ruchi Mahadeshwar). o Introduced carPalette() for color selection. o new bcnPowerAxis() function for bcnPower() transformations. o New vif.merMod() method. o Various small improvements and fixes. Changes to Version 2.1-6 o Made several functions compatible with vcov() in R-devel (3.5.0). Changes to Version 2.1-5 o Fixed bug in boot.hist, and made Boot.default more general. Added a vcov method for boot objects o Fixed bug in gamLine with non-dentity links. o Removed the skewPower transformation functions, and added bcnPower transformation family. Same transformation, new name, new computational algorithms, improved documentation. o Fixed bug (reported by Bruno Hebling Vieira) in print.summary.Anova.mlm() that could cause adjusted p-values to be incorrectly ordered. Changes to Version 2.1-4 o The smoother functions loessLine, gamLine and quantregLine used in many car functions now evaluate the smoother at an equally spaced grid of points rather than at the observed values on the horizontal axis of a plot. o spreadLevelPlot.lm now accepts point marking as in most other graphical functions in car. o Bug fixed in one of the skewPower support functions; thans to Balazs Banfai o Added support for lmer objects in power transformations o Added support for skewPower family power transformations for lm and lmer objects o Added list, data.frame, and matrix methods for Boxplot(), suggestion of Michael Friendly o Added adaptiveKernel() density estimator, with option to use it in densityPlot(). Changes to Version 2.1-3 o Corrected documentation for mcPlots o added id.location argument to showLabels to vary location of labels o added fix for compatiblity with Rcmdr with missing data in several plotting functions. o deltaMethod() now reports confidence intervals. o print.summary.Anova.mlm() has new SSP and SSPE arguments to determine whether the corresponding matrices are printed (suggestion of Michael Friendly). o summary() and print() methods for Anova.mlm() can now report univariate ANOVAs (suggestion and some code by Michael Friendly). o added "value" and "vcov" attributes to objects returned by linearHypothesis() (after suggestions by Liviu Andronic and Steven Yen). o compareCoefs() now checks classes of models. o small fixes/changes. Changes to Version 2.1-2 o Modified scatter3d() so that plots can be embedded in HTML. Changes to Version 2.1-1 o influencePlot now returns Cook's distance, not its square root. o Anova() now supports "coxme" objects (produced by coxme() in coxme package) (request of Philipp Sprenger). o Anova() now works via its default method with "vglm" objects produced by functions in the VGAM package; and the default method of linearHypothesis() again works with these objects (problem reported by Michael Friendly). o Fixed Anova.coxph() so that it takes account of method (ties) argument (bug reported by Karl Ove Hufthammer). o Improvements to Anova.default() so that a wider variety of model classes are accommodated (following request of Liviu Andronic.) o dataEllipse() now throws an error if there are too few colors for the number of groups (fixing bug reported by Ottorino Pantani). o spreadLevelPlot.lm() now includes an optional smoother in addition to the fitted straight line (suggestion of Michael Friendly). o No longer import methods (as opposed to generics) directly from pbkrtest. o Added axis.ticks argument to scatter3d() (code contributed by David Winsemius). Changes to Version 2.1-0 o New power family called skewPower has been added that can be used with the Box Cox method with a few negative responses (joint work with Doug Hawkins). Several functions modified to accomodate two-parameter power families. o Fixed bug in Anova() for coxph models with clusters (reported by Jesus Humberto Gomez ), due apparently to a change in coxph(). Changes to Version 2.0-26 o Anova() F-tests for binomial and Poisson GLMs now changes error.estimate="dispersion" to "pearson" as advertized (bug reported by Will Petry). o Improved behavior of above-plot legends in scatterplot(). o Fixed sp() (bug reported by Cesar Rabak). o Conforms to new CRAN requirements for package imports. Changes to Version 2.0-25 o Fixed df check in linearHypothesis.default() (bug report by Pierre Chausse). o Fixed bug when vcov. argument to Anova() is a function (reported by Liviu Andronic). o Now export .carEnv to avoid problem with update() in Boot() (reported by Alan T. Arnholt). Changes to Version 2.0-24 o Fixed broken URLs. o Changed handling of .carEnv environment. o Moved pbkrtest, quantreg, and mgcv from Suggests: to Imports:. Changes to Version 2.0-23 o Modified ScatterplotSmoothers to add an 'offset' to the vertical axis of spread smooths. This is required in the marginal model plot functions. o Fixed labels on mcPlot with overlay=FALSE o Check for 0 residual df and 0 residual deviance (within rounding) in Anova() and linearHypothesis() (problem reported by Jonathan Love). o Fixed model.matrix.lme and model.matrix.gls utility functions, and hence Anova and vif, respectively, to work with models specified with formulas supplied as objects (after problem noted by Gang Chen). o Added Wong data set, used in mixed-models appendix. Changes to Version 2.0-22 o corrected bug in 'terms' argument in residualPlots, and other graphic functions with a 'terms' argument o added residual curvature tests for glm.nb o mcPlot and mcPlots draw 'marginal/conditional' plots for lm objects. The marginal plot is of the centered response versus a centered regressor; the conditional plot is the corresponding added-variable plot. The plots can be overlaid or viewed side-by-side. o added argument marginal.scale to avPlots to scale the added-variable plot for Y on X|Z using the scale from the marginal plot of Y vs X ignoring X. The default is FALSE, corresponding to using scaling to maximize resolution or use xlim and ylim to set user scaling. o Fixed bugs in Anova.survreg() that could affect types II, II tests, both Wald and LR, and one similar bug in linearHypothesis.survreg(). o Replaced calls to require() with requireNamespace() where possible (suggestion of Brian Ripley). o The following functions now produce warnings rather than errors when there are empty groups: scatterplot(), scatterplotMatrix(), scatter3d(), densityPlot(). o Corrected name of "Blackmoor" dataset to "Blackmore". o Added KosteckiDillon migraines dataset (contributed by Georges Monette). o introduced linearHypothesis.rlm() for rlm models (suggestion of Matthieu Stigler). o Small bug fixes/improvements. Changes to Version 2.0-21 o residualPlot error when using 'type="rstudent" has been fixed. o Minor change to "recode" documentation; improved error checking in recode(). o Fixed a bug in gamLine with non-canonical links. (Thanks to Hani Christoph) o Added has.intercept.multinom() to make Anova() work with multinom objects fit to a dichotomous response (after bug report by Kristian Hovde Liland). o Replaced vif.lm() with vif.default() to cover wider variety of models (after question by Laura Rigg about gls models). o Diagonal panels in scatterplotMatrix() (except for histograms) show groups separately when plotted by groups (suggestion by Erich Neuwirth). o Added vcov. argument to Anova.lm(). Changes to Version 2.0-20 o Added new id.method="r" to showLabels for labeling plots of residuals; default id.method changed in residualPlots. o Fixed handling of labels argument to outlierTest() (bug report by Stephane Laurent). o Accommodate numeric variables consisting entirely of NAs in recode() (suggestion of Karl Ove Hufthammer). o Prevent dataEllipse() from opening a graphics device when draw=FALSE (fixing bug reported by Rafael Laboissiere). o The functions makeHypothesis() and printHypothesis(), intended for internal use, are exported so that they can be used in other packages (request of Arne Henningsen). o Small fixes. Changes to Version 2.0-19 o allow a grouping variable for color, symbol and fits in residualPlots o fixed axis labelling probelm in influenceIndexPlot o fixed scoping problems in Boot, bootCase, and ncvTest o added an argument to deltaMethod for passing arguments to get scoping right when calling linearHypothesis in another function; other deltaMethod bugs fixed o slight modification to documentation of Boot o summary() method for "Anova.mlm" objects now returns an object, printed by a corresponding print() method (adapting code contributed by Gabriel Baud-Bovy). o added .merMod methods to Anova(), deltaMethod(), linearHypothesis(), matchCoefs(), and unexported utilities df.residual() and has.intercept(); insured compatibility with nlme and CRAN and developments versions of lme4. o added use argument to scatterplotMatrix() (suggestion of Antoine Lizee). o export linearHypothesis.default() for use in other packages (suggestion of Achim Zeileis). o small changes and fixes. Changes to Version 2.0-18 o Bug fix to boot with type="residual" o Added densityPlot() function. Changes to Version 2.0-17 o Add a variable to AMSsurvey. o Fix to residualPlots to compute lack of fit tests with missing values and glms. o Fix to residualPlots with a 0/1 variable not declared a factor. o Boxplot() now works properly with at argument passed to boxplot() via ... (contribution of Steve Ellison). o qqPlot.lm() now works with "aov" objects (fixing problem reported by Thomas Burk). o Small fixes to code and docs. Changes to Version 2.0-16 o Fixed bug in printing of hypotheses by linearHypothesis(), where numeric constants of the form 1.* or -1.* were printed incorrectly (reported by Johannes Kutsam). o Fixed a bug in showLabels() with multiple groups in the scatterplot() and scatterplotMatrix() function. o linearHypothesisTest() now tolerates newlines and tabs in hypotheses (suggestion of David Hugh-Jones). o two bugs fixed in Boot() (found by David Pain) changed argument f to f. in bootCase(). o summary.Boot(), confint.Boot() and hist.Boot() handle aliases correctly. o Boxplot.formula() now accepts more than one conditioning variable (suggestion of Christina Yassouridis). o Boxplot() now properly handles at argument passed through via ... to boxplot() (contribution of Steve Ellison). o Small fixes. Changes to Version 2.0-15 o Added an argument coef. to linearHypothesis so tests of the linear hypohtesis form can be computed without reference to a fitted model o Added a linearHypothesis.nlsList method o Added an nls method for Boot o Recode() introduced as alias for recode() to avoid name clash with Hmisc. o residualPlots for glms now ignore starting values for the computing algorithm when computing lack of fit tests; starting values previously caused an error. o Marginal Model Plots now allow conditioning on a categorical variable. Changes to Version 2.0-14 o Smoothers now given as arguments to scatterplot(), scatterplotMatrix(), residualPlots() and other functions; gamLine(), loessLine() (default), and quantregLine() smoothers provided. o linearHypothesis.mer() and Anova.mer() now consistent with pbkrtest version 0.3-2. o Small changes and fixes. Changes to Version 2.0-13 o Added point marking (id.n, etc.) to dataEllipse o Changed the default for id.method with the invTranPlot to "x". o The ncvTest has been rewritten for stability, and unneeded 'data', 'subset' and 'na.action' argument have been removed o Added new function 'Boot' that is a simple front-end to boot::boot that will be useful when bootstrapping regression models. Implemented for lm and glm, but this is likely to work for many other S3 regression models with and 'update' method, 'subset' argument. o Fixed bug in 'compareCoefs' with non-full rank models o Modified 'bootCase' to return a matrix of class c("bootCase", "matrix") so generic functions can be written to summarize these objects. o Minor changes to the returned value of showLabels to give both the label and the corresponding row number. showLabels documentation tweaked. o Improved handling of center.pch argument to ellipse() (suggestion of Rob Kushler). o New test argument for linearHypothesis.mer() and test.statistic argument for Anova.mer() for F-tests with Kenward/Roger df, provided by pbkrtest package. o Anova.mlm() now will do univariate repeated-measures ANOVA even if the error SSP matrix is singular. o hccm() will now accept a weighted linear models (suggestion of Stefan Holst Bache). o deltaMethod.default() now applies coef() and vcov() to a model for which these are supported (generalizing a suggestion by Scott Kostyshak). o Fixed handling of labels argument in scatterplot.formula() and scatterplotMatrix.formula(). o Fixed qqPlot.default() so that it honors line="none" (bug reported by Rob Kushler). o Added new default method for confidenceEllipse(), which now can construct confidence ellipses for linear functions of coefficients. o globalVariables() called for R 2.15.1 or later. o Fixed bug in logit() when percents=TRUE and largest percent is 1 (reported by Eric Goodwin). o Added radius argument to scatter3d() (suggestion of Antonino Messina). o Fixed spurious errors message in scatter3d() when groups present but surface=FALSE (reported by David L. Carlson). Changes to Version 2.0-12 o modified compareCoefs to support any S4 object with that responds to the 'coefs' and 'vcov' methods (suggestion of David Hugh-Jones). o fixed bug in deltaMethod.surveg and deltaMethod.coxph to all use of the 'parameterNames' argument. o compareCoefs: added an argument 'print' to suppress printing output. Added support for 'lme' objects. o fixed xlab, ylab arguments and added dfn argument to confidenceEllipse() (suggestions of Michael Friendly). o moved survival from Depends to Suggests (request of Michael Friendly); added survey to Suggests. o added Anova.svyglm and linearHypothesis.svyglm. o fixed bug in linearHypothesis() that affected printing of some hypotheses (reported by Arne Henningsen). o fixed bug in Anova() for GLMs when F-test used with na.exclude. o package now byte-compiled. Changes to Version 2.0-11 o the arguments to deltaMethod have changed, with parameterPrefix replaced by parameterNames. See documentation for useage. o deltaMethod methods for lmList, nlsList, and mer objects have been added. The syntax for the multinom method has been improved. o the 'layout' argument is used in several graphical functions to determine the layout of multiple graphs within the same graphical window. Setting layout=NA in these functions suppresses this behavior and the user can set the layout outside the function (suggested by Steve Milborrow) o compareCoefs() works with 'mer' objects created by lme4 o avPlot() now will optionally plot concentration ellipses; avPlot() and avPlots() invisibly return coordinates (suggested by Michael Friendly, with contributed code). o dataEllipse() now allows combination of add=FALSE and plot.points=FALSE (suggested by Michael Friendly, with contributed code); the ellipse functions have acquired a "draw" argument, which can be used to suppress graphical output (suggestion of Benoit Bruneau). o ellipse(), confidenceEllipse(), and dataEllipse() return coordinates invisibly (suggested by Michael Friendly, with contributed code). o fixed bug in printed representation of hypotheses with numbers starting with "-1" or "+1" (e.g., "-10") by linearHypothesis() (reported by Vincent Arel-Bundock). o local version of fixef() to avoid lme4/nlme conflicts that surfaced in some situations with Anova(). o changed order of columns in ANOVA tables for mixed models to make them consistent with other models. Changes to Version 2.0-10 o changed tukeyNonaddTest to be sure the test exists. o changed the default in residualPlots for AsIs from FALSE to TRUE. o improved color choice in scatterplot and scatterplotMatrix (at suggestion of Dan Putler). o moved up ... argument in qqPlot.default (suggestion of Peter Ehlers). o changed label on marginal model plot for generalized linear models verses fitted values to 'fitted values' rather than the incorrect 'Linear predictor" o mmp now passes graphical parameters to par o mmps now works correctly with 'gam' models (mgcv package) o modified bootCase to work with multivariate lm objects Changes to Version 2.0-9 o added Anova and linearHypothesis methods for mixed-effects model objects created by lmer in lme4 and lme in nlme. o added matchCoefs, convenience function to use with linearHypothesis. o scatterplot makes parallel boxplots, calling Boxplot, when x is a factor. o mmps (marginal model plots) works better with multidimensional terms like splines and polynomials, and permits plotting against terms in the data frame but not in the model formula. AsIs argument removed. o residualPlots handles matrix-predictors similarly to mmps, above. o recode allows the recode-specification string to be split over more than one line. o small fixes to Anova.multinom, Anova.polr, and leveneTest. Changes to Version 2.0-8 o added optional argument legend.coords to scatterplot to place legend (after question by Blaine Maley). o bug fixes to powerTransform and residualPlots. Changes to Version 2.0-7 o added fill and fill.alpha arguments to ellipse, etc., for translucent filled ellipses (suggested by Michael Friendly). o fixed bug in recode, when a legitimate string includes the characters "else" (reported by Gustaf Rydevik). o carWeb() now works with web site for the R Companion, Second Edition. Changes to Version 2.0-6 o change influenceIndexPlots to used type="h" rather than type="l". o added surface.alpha and ellipsoid.alpha arguments to scatter3d. Changes to Version 2.0-5 o add xlab and ylab arguments to avPlots, crPlots, ceresPlots, etc., to override default labeling if desired. o fix col and col.lines arguments in avPlots, crPlots, ceresPlots, etc., so graphical functions work the same way. o confidenceEllipse.lm and .glm now have add argument, courtesy of Rafael Laboissiere. o small fixes to docs. Changes to Version 2.0-4 o fix col argument to work to set point colors with residualPlots, leveragePlots, invTranPlot, marginalModelPlots Changes to Version 2.0-3 o coefTable() changed to compareCoefs() to avoid name clash with the miscTools package (reported Arne Henningsen). o Small changes. Changes to Version 2.0-2 o leaps package demoted from Depends to Suggests to avoid problem for Debian (reported by Dirk Eddelbuettel). Changes to Version 2.0-1 o No longer export non-standard coef.multinom() (problem reported by Brian Ripley, Achim Zeileis). Changes to Version 2.0-0 o Functions renamed to camel case. o New functions: bootCase(), Boxplot(), deltaMethod(), inverseResponsePlot(), invTranPlot(), various transformation functions o Reworked (or renamed): Anova(), avPlots(), boxCoxVariable(), boxTidwell(), ceresPlots(), crPlots(), durbinWatsonTest(), hccm(), influencePlot(), leveneTest(), leveragePlots(), linearHypothesis(), ncvTest(), outlierTest(), qqPlot(), regLine(), scatterplot(), scatterplotMatrix(), spreadLevelPlot(), transformation-axis functions, vif(). o Removed: Ask(), box.cox.powers(), box.cox(), cookd(), n.bins(). o Added WeightLoss data set (courtesy of Michael Friendly). o Utility functions no longer exported; some removed. o Most moved, renamed, removed functions retained as deprecated functions. o Improvements to linearHypothesis(), thanks to Achim Zeileis. o Small changes. Changes to Version 1.0-0 o Added functions for effects plots [see help(effect)]. o Edited .Rd files to use \method{} for generics. o Changed some F's to f's o Modified durbin.watson to allow directional alternative hypotheses Changes to Version 1.0-1 o Reworked glm methods for Anova for type II LR and F tests to avoid scoping issues produced by use of update. o Added reset.par argument to scatterplot.default to allow addition of graphical elements to the plot. o The generic function Var and its methods are deprecated, in favour of vcov, now in the base package. Changes to Version 1.0-2 o The fitted line can be suppressed in qq.plot. o ceres.plots can now handle models that include transformed predictors -- e.g., log(x), I(x^2). o Fixed bug in Anova which caused it to fail calculating type-II F or LR tests for glms in certain circumstances. (Bug introduced in version 1.0-1.) o Made arguments of method functions consistent with generics (mostly adding ... to methods). o Fixed a bug in plot.effect which caused nonalphabetical orderings of factor levels to be lost; added arguments cex, xlim, and ylim to plot.effect. o Modified effect to permit computing effects for terms not in the model or with higher-order relatives in the model. o Added functions contr.Treatment, contr.Sum, and contr.Helmert; see help(Contrasts). o Added Burt.txt data set (to go with Burt.Rd documentation file already there). o Added Arrests.txt data set. o Fixed an error in hccm.lm which produced incorrect values for the "hc1", "hc2", and "hc3" corrections; added "hc4" correction. o Modified influence.glm to handle 0 prior weights; changes to influence.lm and influence.glm to insure compatibility with R 1.7.0. o removed quietly=TRUE from several calls to require(), to avoid invisibly altering the search path. Changes to Version 1.0-3 o All deletion diagnostics (with the exception of cookd) have been moved to the base package (as of R 1.7.0) and are removed from car; cookd now simply calls cooks.distance in the base package. o plot.effect modified was modified so that it can plot on the scale of the "link" function but label axes on the scale of the response. See ?plot.effect for details. Changes to Version 1.0-4 o Modified box.cox.powers to accept hypotheses to be tested. o Removed effect-display functions (to effects package). o Added warnings to Anova methods for F-tests in binomial and Poisson GLMs that the dispersion is estimated rather than taken as 1. Changes to Version 1.0-5 o Small changes to scatterplot and scatterplot.matrix to avoid "condition has length > 1" warnings. Changes to Version 1.0-6 o Print method for outlier.test no longer prints NA for Bonferroni p-values > 1; prints "> 1". Changes to Version 1.0-7 o More small changes to scatterplot to avoid "condition has length > 1" warnings. Changes to Version 1.0-8 o Small correction to documentation for recode. o Restored missing States data frame. o Small documentation changes to pass new package checks. Changes to Version 1.0-9 o vif now reports an error if the model has fewer than 2 terms (not counting the constant) o Small changes. Changes to Version 1.0-10 o scatterplot.formula made compatible with na.action=na.exclude. o Documentation corrections to satisfy package checks in R 1.9.0 (devel). Changes to Version 1.0-11 o More documentation fixes. o Fix to print method for outlier.test. Changes to Version 1.0-12 o Small fix to box.cox.powers to avoid inconsequential warnings. o Removed dependency on now nonexistent modreg package. o Moved levene.test and influence.plot functions to car from the Rcmdr package. o box.cox now reports an error when it cannot compute an automatic start. o Fixed bug in ceres.plot.lm that caused an error when the subset argument was used to exclude observations in fitting the model. o Changed ncv.test to allow weighted lm object (suggested by Sandy Weisberg). o scatterplot.matrix now passes ... argument to pairs (also suggested by Sandy Weisberg). Changes to Version 1.0-13 o Small changes to levene.test and box.cox.powers to make output compatible with version 0.9-10 of the Rcmdr package. Changes to Version 1.0-14 o cr.plots() ignored its span argument when variable was specified in the call (thanks to Christophe Pallier for pointing this out). o Added some(), which prints a few randomly selected elements (or rows) of an object. o Added Anova() methods for multinomial logistic regression [via multinom() in the nnet package], and for proportional-odds logistic regression [via polr() in the MASS package). o Made influence.plot() generic, with a method for lm objects that handles glm objects as well. Changes to Version 1.0-15 o Changed recode() to accommodate factor levels with spaces (suggested by Dan Putler). o Added cex* arguments to scatterplot() and scatterplot.matrix(), and a jitter argument to scatterplot (suggested by CG Pettersson). o Added symbox() function for selecting a transformation to symmetry (a modified version of a function contributed by Gregor Gorjanc). o ncv.test() modified so that it doesn't fail when the variance formula has a different pattern of NAs than the model formula (adapting a suggestion by Achim Zeileis). o Added argument to spread.level.plot.default() to optionally suppress point labels (suggested by Josyf Mychaleckyj). o vif() modified by Henric Nilsson to be applicable to generalized linear models and other models inheriting from class lm. Weighted linear models are now allowed. Changes to Version 1.0-16 o Modified to linear.hypothesis by Achim Zeleis to support alternative coefficient covariance-matrix estimators for linear models (via new vcov argument); to provide both chisquare and F tests for both linear and generalized-linear models (via new test argument); and to produce neater output (from both .lm and .glm methods). o Anova methods modified to work with new linear.hypothesis functions. Changes to Version 1.0-17 o Fixed a bug in scatterplot() that caused marginal boxplots to be incorrect when xlim or ylim arguments are supplied (pointed out by Erich Neuwirth). Changes to Version 1.0-18 o Restored print.chisq.test(), used by ncv.test() (which had been removed when linear.hypothesis was changed). o Fixed bug in recode() that could cause values with mixed letters and numbers to be treated incorrectly (reported by David Dailey and Tom Mulholland). Changes to Version 1.0-19 o Fix to linear.hypothesis.lm and linear.hypothesis.glm, which were printing long formulas awkwardly (thanks to Henric Nilsson). Changes to Version 1.0-20 o Major reworking of linear.hypothesis (mostly due to Achim Zeleis) (1) to allow symbollic specification of the hypothesis, and (2) to provide a default method that is applicable to any model for which coef and vcov methods exist (or, in the latter case, for which a coefficient-covariance matrix is supplied). o The car package now has a namespace. o Fixes to Anova.multinom and Anova.polr reflecting changes to multinom and polr (thanks Huaibao Feng for a bug report). o Added cex argument to qq.plot methods, suggested by Peter Ehlers. o Modified box.cox so that the power argument can be a vector, returning a matrix of transformed values, adapting code contributed by Spencer Graves (but implementing different behaviour than the one suggested by Spencer). o Added identity.cex and identify.col arguments to influence.plot, as suggested by John Wilkinson. o Data sets are now provided as lazy data; Rd files updated to remove references to data() in examples. o Small modifications to documentation. Changes to Version 1.1-0 o New version of linear.hypothesis (mostly due to Achim Zeleis); some changes to other functions as a consequence. Changes to Version 1.1-1 o Small changes to scatterplot.matrix, adapting contribution of Richard Heiberger. o scatterplot now places the legend in the top margin rather than positioning it interactively. o Cleaned up links to help files in standard packages. Changes to Version 1.1-2 o Fixed small bug in linear.hypothesis() that caused the RHS to printed with NAs in some circumstances. Changes to Version 1.2-0 o vif now reports a more understandable error message when a coefficient in the model is aliased (thanks to a question posed by Ulrike Gr?mping). o recode now takes a levels argument (as suggested by Adrian Dusa). o Corrected diagonal panel functions local to scatterplot.matrix.default, which omitted ... argument (pointed out by Kurt Hornik and Brian Ripley). o New methods for multivariate-linear models (mlm objects) for linear.hypothesis and Anova. Added OBrienKaiser data set for examples. Changes to Version 1.2-1 o The name of the function influence.plot was changed to influencePlot to avoid confusion with the influence generic in the stats package. Changes to Version 1.2-2 o Bug fixed in the bc function (reported by Henric Nilsson). o Error in Bfox data set is now pointed out. o levene.test now checks that second argument is a factor. o Removed extended=FALSE argument to gsub() in some internal functions, since this argument is ignored when fixed=TRUE and generates a warning in R 2.6.0 (reported by Arne Henningsen). Changes to Version 1.2-3 o Replaced obsolete \non_function{} markup in Rd files (reported by Kurt Hornik). Changes to Version 1.2-4 o Avoid warnings in linear.hypothesis() produced by unnecessary use of extended = FALSE argument to strsplit() (problem reported by Alejandro Collantes Ch?vez-Costa). Changes to Version 1.2-5 o Fixed small bug in reg.line() (pointed out by Kurt Hornik). Changes to Version 1.2-5 o Improvements to linear.hypothesis.mlm() and Anova.mlm(), e.g., to detect deficient-rank error SSP matrices (as suggested by Ralf Goertz). o For models with only an intercept, Anova() with type="II" now substitutes equivalent type="III" tests (since the code for type="II" doesn't handle intercepts). This is especially useful for repeated-measures designs with only within-subjects factors (in response to a problem reported by Ralf Goertz). Changes to Version 1.2-7 o Added Mauchly tests for sphericity in repeated-measures designs to summary.Anova.mlm() (suggested by Ralf Goertz). Changes to Version 1.2-8 o HF eps > 1 is now set to 1 in adjusting df in summary.Anova.mlm(), consistent with the behaviour of anova.mlm() (suggested by Ralf Goertz). o Fixed bug in summary.Anova.mlm() that surfaced when all univariate repeated-measures tests have 1 df and hence GG and HF corrections don't apply to any of the tests (reported by Ralf Goertz). o levene.test() is now generic, contributed by Derek Ogle. o Small changes. Changes to Version 1.2-9 o Fixed bug in scatterplot() that left room for a legend even when legend.plot=FALSE (reported by David Carlson). o Allowed colours in col argument to scatterplot() to recycle (suggested by David Carlson). o verbose=TRUE in linear.hypothesis() now prints (in addition to previous output) the estimated value of the hypothesis (Oleksandr Perekhozhuk). Changes to Version 1.2-10 o Reworked Anova(), including adding default method and method for coxph objects. Changes to Version 1.2-11 o Bug fix to Anova(). o Small changes. Changes to Version 1.2-12 o Anova() now works properly with coxph objects with clusters. o Fixed bug in ncv.test.lm() that could cause the function to fail. o Small changes. Changes to Version 1.2-13 o influencePlot() optionally automatically identifies points with large Cook's Ds (suggested by Michael Friendly). o Fixed bug in recode() (reported by Andrew McFadden). o Small changes. Changes to Version 1.2-14 o Small correction to Chile data set. Changes to Version 1.2-15 o Small changes. car/R/0000755000176000001440000000000014140313736011252 5ustar ripleyuserscar/R/Tapply.R0000644000176000001440000000057714140261763012661 0ustar ripleyusersTapply <- function(formula, fun, data, na.action=na.pass, ..., targs=list()){ yx <- if (missing(data)) model.frame(formula, na.action=na.action) else model.frame(formula, data=data, na.action=na.action) if (ncol(yx) < 2) stop("fewer than two variables") targs[c("X", "INDEX", "FUN")] <- list(yx[, 1], yx[, -1], fun) targs <- c(targs, list(...)) do.call(tapply, targs) }car/R/boxTidwell.R0000644000176000001440000000567014140261763013524 0ustar ripleyusers#------------------------------------------------------------------------------- # Revision history: # 2009-09-29 by J. Fox (renamed) # 2010-03-11 by J. Fox: output changed # 2010-03-13 by J. Fox: output row label fixed when just one X #------------------------------------------------------------------------------- # Box-Tidwell transformations (J. Fox) boxTidwell <- function(y, ...){ UseMethod("boxTidwell") } boxTidwell.formula <- function(formula, other.x=NULL, data=NULL, subset, na.action=getOption("na.action"), verbose=FALSE, tol=.001, max.iter=25, ...) { m <- match.call(expand.dots = FALSE) if (is.matrix(eval(m$data, sys.frame(sys.parent())))) m$data <- as.data.frame(data) m$formula <- if (is.null(other.x)) formula else as.formula(paste(formula[2], "~", formula[3], "+", other.x[2])) m$max.iter <- m$tol <- m$verbose <- m$other.x <- m$... <- NULL m[[1]] <- as.name("model.frame") mf <- eval(m, sys.frame(sys.parent())) response <- attr(attr(mf, "terms"), "response") if (!response) stop(paste("no response variable in model")) X1 <- model.matrix(formula, data=mf)[,-1] X2 <- if (is.null(other.x)) NULL else model.matrix(other.x, data=mf)[,-1] y <- model.response(mf, "numeric") boxTidwell.default(y, X1, X2, max.iter=max.iter, tol=tol, verbose=verbose, ...) } boxTidwell.default <- function(y, x1, x2=NULL, max.iter=25, tol=.001, verbose=FALSE, ...) { x1 <- as.matrix(x1) if (any(x1 <= 0)) stop("the variables to be transformed must have only positive values") var.names <- if(is.null(colnames(x1))) seq(length.out=ncol(x1)) else colnames(x1) k.x1 <- length(var.names) x.log.x <- x1*log(x1) mod.1 <- lm(y ~ cbind(x1, x2), ...) mod.2 <- lm(y ~ cbind(x.log.x, x1, x2), ...) seb <- sqrt(diag(vcov(mod.2))) which.coefs <- 2:(1 + k.x1) t.vals <- ((coefficients(mod.2))/seb)[which.coefs] initial <- powers <- 1 + coefficients(mod.2)[which.coefs]/coefficients(mod.1)[which.coefs] pvalues<-2*(pnorm(abs(t.vals), lower.tail=FALSE)) iter <- 0 last.powers <- 1 while ((max(abs((powers - last.powers)/(powers + tol))) > tol) && (iter <= max.iter) ) { iter <- iter+1 x1.p <- x1^matrix(powers, nrow=nrow(x1), ncol=ncol(x1), byrow=TRUE) x.log.x <- x1.p*log(x1.p) mod.1 <- lm.fit(cbind(1, x1.p, x2), y, ...) mod.2 <- lm.fit(cbind(1, x.log.x, x1.p, x2), y, ...) last.powers <- powers powers <- powers * (1 + coefficients(mod.2)[which.coefs]/coefficients(mod.1)[which.coefs]) if (verbose) cat(" iter =", iter, " powers =", powers, "\n") } if (iter > max.iter) warning("maximum iterations exceeded") result <- cbind(powers, t.vals, pvalues) colnames(result) <- c("MLE of lambda", "Score Statistic (z)", "Pr(>|z|)") rownames(result) <- if (nrow(result) == 1) "" else var.names result <- list(result=result, iterations=iter) class(result)<-"boxTidwell" result } print.boxTidwell <- function(x, digits=getOption("digits") - 2, ...){ printCoefmat(x$result, digits=digits, has.Pvalue=TRUE) cat("\niterations = ", x$iterations,"\n") } car/R/Export.R0000644000176000001440000000156514140313736012665 0ustar ripleyusers# Export March 2017 # Wrapper for the 'export' function in the 'rio' package that adds automatic support for row names by # converting the row names to the left-most column of the saved data file. # 3/15/2017: S. Weisberg # 11/2/2021: A. Zeileis, check for rio availability (so that rio can be in Suggests only) Export <- function(x, file, format, ..., keep.row.names){ if(!requireNamespace("rio")) stop("Export() relies on rio::export(), please install package 'rio'") stopifnot(is.data.frame(x)) if(!missing(keep.row.names)){ name <- if(is.logical(keep.row.names) & keep.row.names==TRUE) "id" else keep.row.names if(name != FALSE){ if(name %in% names(x)) stop("There is a column named ", name, " already!") x <- cbind(rownames(x), x) names(x)[1] <- name attr(x, "row.names") <- 1:dim(x)[1] }} rio::export(x, file, format, ...) } car/R/logit.R0000644000176000001440000000132314140261763012514 0ustar ripleyusers# logit transformation of proportion or percent (J. Fox) # last modified 2012-06-24 by J. Fox logit <- function(p, percents=range.p[2] > 1, adjust){ range.p <- range(p, na.rm=TRUE) if (percents){ if (range.p[1] < 0 || range.p[1] > 100) stop("p must be in the range 0 to 100") p <- p/100 range.p <- range.p/100 } else if (range.p[1] < 0 || range.p[1] > 1) stop("p must be in the range 0 to 1") a <-if (missing(adjust)) { if (isTRUE(all.equal(range.p[1], 0)) || isTRUE(all.equal(range.p[2], 1))) .025 else 0 } else adjust if (missing(adjust) && a != 0) warning(paste("proportions remapped to (", a, ", ", 1-a, ")", sep="")) a <- 1 - 2*a log((0.50 + a*(p - 0.50))/(1 - (0.50 + a*(p - 0.50)))) } car/R/strings2factors.R0000644000176000001440000000236214140261763014537 0ustar ripleyusersstrings2factors <- function(object, which, not, exclude.unique, levels, verbose, ...){ UseMethod("strings2factors") } strings2factors.data.frame <- function(object, which, not, exclude.unique=TRUE, levels=list(), verbose=TRUE, ...){ if (missing(which)) which <- sapply(object, is.character) if (is.numeric(which)) which <- names(object)[which] if (!missing(not) && !is.character(not)) not <- names(object)[not] if (!is.character(which)) which <- names(object)[which] if (!missing(not)) which <- setdiff(which, not) n <- nrow(object) for (var in which){ levs <- levels[[var]] all.unique <- !anyDuplicated(object[[var]], incomparables=NA) if (all.unique){ if (exclude.unique) { which <- setdiff(which, var) next } else warning("all values of ", var, " are unique") } object[[var]] <- if (is.null(levs)){ factor(object[[var]]) } else { factor(object[[var]], levels=levels[[var]]) } } if (verbose){ if (length(which) > 1){ cat("\nThe following character variables were converted to factors\n", paste(which, sep=", "), "\n") } else { cat("\n", which, "was converted to a factor") } } object } car/R/scatter3d.R0000644000176000001440000005703114140261763013301 0ustar ripleyusers# 3D scatterplots and point identification via rgl # checked in 23 December 2009 by J. Fox # 5 January 2010: fixed axis labeling in scatter3d.formula. J. Fox # 13 May 2010: changed default id.n to conform to showLabels # 30 July 2010: checks for rgl # 23 October 2010: added surface.alpha and ellipsoid.alpha arguments # 2012-03-02: fixed some argument abbreviations. J. Fox # 2013-02-20: fixed error message, docs for surface.col argument. J. Fox # 2013-08-20: changed rgl:::rgl.projection to rgl::rgl.projection; more such fixes to come. J. Fox # 2013-08-31: rgl functions used now exported; got rid of ::: and ::. J. Fox # 2014-08-04: changed name of identify3d() to Identify3d(). J. Fox # 2014-08-17: added calls to requireNamespace and :: as needed. J. Fox # 2014-09-04: J. Fox: empty groups produce warning rather than error # 2015-12-12: Added axis.ticks argument and code contributed by David Winsemius to add tick labels to axes. J. Fox # 2016-02-06: Changed call to rgl.clear() to next3d() for compatibility with embedding in HTML. J. Fox # 2017-06-27: introduced id argument replacing several arguments. J. Fox # 2017-11-30: use carPalette(), avoid red and green. J. Fox scatter3d <- function(x, ...){ if (!requireNamespace("rgl")) stop("rgl package missing") UseMethod("scatter3d") } scatter3d.formula <- function(formula, data, subset, radius, xlab, ylab, zlab, id=FALSE, ...){ na.save <- options(na.action=na.omit) on.exit(options(na.save)) m <- match.call(expand.dots=FALSE) if (is.matrix(eval(m$data, sys.frame(sys.parent())))) m$data <- as.data.frame(data) m$na.action <- na.pass m$id <- m$xlab <- m$ylab <- m$zlab <- m$... <- NULL m[[1]] <- as.name("model.frame") formula <- as.character(formula) formula <- paste(formula[2], formula[1], formula[3]) formula <- as.formula(sub("\\|", "+", formula)) m$formula <- formula X <- eval(m, parent.frame()) if ("(radius)" %in% names(X)){ radius <- X[, "(radius)"] X <- X[, names(X) != "(radius)"] } else radius <- 1 names <- names(X) id <- applyDefaults(id, defaults=list(method="mahal", n=2, labels=rownames(X), offset = ((100/nrow(X))^(1/3))*0.02), type="id") if (missing(xlab)) xlab <- names[2] if (missing(ylab)) ylab <- names[1] if (missing(zlab)) zlab <- names[3] if (ncol(X) == 3) scatter3d(X[,2], X[,1], X[,3], xlab=xlab, ylab=ylab, zlab=zlab, radius=radius, id=id, ...) else if (ncol(X) == 4) scatter3d(X[,2], X[,1], X[,3], groups=X[,4], xlab=xlab, ylab=ylab, zlab=zlab, radius=radius, id=id, ...) else stop("incorrect scatter3d formula") } scatter3d.default <- function(x, y, z, xlab=deparse(substitute(x)), ylab=deparse(substitute(y)), zlab=deparse(substitute(z)), axis.scales=TRUE, axis.ticks=FALSE, revolutions=0, bg.col=c("white", "black"), axis.col=if (bg.col == "white") c("darkmagenta", "black", "darkcyan") else c("darkmagenta", "white", "darkcyan"), surface.col=carPalette()[-1], surface.alpha=0.5, neg.res.col="magenta", pos.res.col="cyan", square.col=if (bg.col == "white") "black" else "gray", point.col="yellow", text.col=axis.col, grid.col=if (bg.col == "white") "black" else "gray", fogtype=c("exp2", "linear", "exp", "none"), residuals=(length(fit) == 1), surface=TRUE, fill=TRUE, grid=TRUE, grid.lines=26, df.smooth=NULL, df.additive=NULL, sphere.size=1, radius=1, threshold=0.01, speed=1, fov=60, fit="linear", groups=NULL, parallel=TRUE, ellipsoid=FALSE, level=0.5, ellipsoid.alpha=0.1, # id.method=c("mahal", "xz", "y", "xyz", "identify", "none"), # id.n=if (id.method == "identify") Inf else 0, # labels=as.character(seq(along=x)), offset = ((100/length(x))^(1/3)) * 0.02, id=FALSE, model.summary=FALSE, ...){ if (!requireNamespace("rgl")) stop("rgl package missing") if (!requireNamespace("mgcv")) stop("mgcv package missing") id <- applyDefaults(id, defaults=list(method="mahal", n=2, labels=as.character(seq(along=x)), offset = ((100/length(x))^(1/3))*0.02), type="id") if (isFALSE(id)){ id.n <- 0 id.method <- "mahal" labels <- NULL } else{ labels <- id$labels id.method <- id$method id.n <- if ("identify" %in% id.method) Inf else id$n offset <- id$offset } # id.method <- match.arg(id.method) if (residuals == "squares"){ residuals <- TRUE squares <- TRUE } else squares <- FALSE summaries <- list() if ((!is.null(groups)) && (nlevels(groups) > length(surface.col))) stop(sprintf("Number of groups (%d) exceeds number of colors (%d)", nlevels(groups), length(surface.col))) if ((!is.null(groups)) && (!is.factor(groups))) stop("groups variable must be a factor") counts <- table(groups) if (any(counts == 0)){ levels <- levels(groups) warning("the following groups are empty: ", paste(levels[counts == 0], collapse=", ")) groups <- factor(groups, levels=levels[counts != 0]) } bg.col <- match.arg(bg.col) fogtype <- match.arg(fogtype) if ((length(fit) > 1) && residuals && surface) stop("cannot plot both multiple surfaces and residuals") xlab # cause these arguments to be evaluated ylab zlab rgl::next3d() rgl::rgl.viewpoint(fov=fov) rgl::rgl.bg(color=bg.col, fogtype=fogtype) if (id.method == "identify"){ xg <- x yg <- y zg <- z ggroups <- groups glabels <- labels } valid <- if (is.null(groups)) complete.cases(x, y, z) else complete.cases(x, y, z, groups) x <- x[valid] y <- y[valid] z <- z[valid] labels <- labels[valid] minx <- min(x) maxx <- max(x) miny <- min(y) maxy <- max(y) minz <- min(z) maxz <- max(z) if (axis.scales){ lab.min.x <- nice(minx) lab.max.x <- nice(maxx) lab.min.y <- nice(miny) lab.max.y <- nice(maxy) lab.min.z <- nice(minz) lab.max.z <- nice(maxz) minx <- min(lab.min.x, minx) maxx <- max(lab.max.x, maxx) miny <- min(lab.min.y, miny) maxy <- max(lab.max.y, maxy) minz <- min(lab.min.z, minz) maxz <- max(lab.max.z, maxz) min.x <- (lab.min.x - minx)/(maxx - minx) max.x <- (lab.max.x - minx)/(maxx - minx) min.y <- (lab.min.y - miny)/(maxy - miny) max.y <- (lab.max.y - miny)/(maxy - miny) min.z <- (lab.min.z - minz)/(maxz - minz) max.z <- (lab.max.z - minz)/(maxz - minz) if (axis.ticks){ if (axis.scales) { x.labels <- seq(lab.min.x, lab.max.x, by=diff(range(lab.min.x, lab.max.x))/4) x.at <- seq(min.x, max.x, by=nice(diff(range(min.x, max.x))/4)) rgl::rgl.texts(x.at, -0.05, 0, x.labels, col = axis.col[1]) z.labels <- seq(lab.min.z, lab.max.z, by=diff(range(lab.min.z, lab.max.z))/4) z.at <- seq(min.z, max.z, by=diff(range(min.z, max.z))/4) rgl::rgl.texts(0, -0.1, z.at, z.labels, col = axis.col[3]) y.labels <- seq(lab.min.y, lab.max.y, by=diff(range(lab.min.y, lab.max.y))/4) y.at <- seq(min.y, max.y, by=diff(range(min.y, max.y))/4) rgl::rgl.texts(-0.05, y.at, -0.05, y.labels, col = axis.col[2]) } } else { rgl::rgl.texts(min.x, -0.05, 0, lab.min.x, col=axis.col[1]) rgl::rgl.texts(max.x, -0.05, 0, lab.max.x, col=axis.col[1]) rgl::rgl.texts(0, -0.1, min.z, lab.min.z, col=axis.col[3]) rgl::rgl.texts(0, -0.1, max.z, lab.max.z, col=axis.col[3]) rgl::rgl.texts(-0.05, min.y, -0.05, lab.min.y, col=axis.col[2]) rgl::rgl.texts(-0.05, max.y, -0.05, lab.max.y, col=axis.col[2]) } } if (!is.null(groups)) groups <- groups[valid] x <- (x - minx)/(maxx - minx) y <- (y - miny)/(maxy - miny) z <- (z - minz)/(maxz - minz) size <- sphere.size*((100/length(x))^(1/3))*0.015 radius <- radius/median(radius) if (is.null(groups)){ if (size > threshold) rgl::rgl.spheres(x, y, z, color=point.col, radius=size*radius) else rgl::rgl.points(x, y, z, color=point.col) } else { if (size > threshold) rgl::rgl.spheres(x, y, z, color=surface.col[as.numeric(groups)], radius=size*radius) else rgl::rgl.points(x, y, z, color=surface.col[as.numeric(groups)]) } if (!axis.scales) axis.col[1] <- axis.col[3] <- axis.col[2] rgl::rgl.lines(c(0,1), c(0,0), c(0,0), color=axis.col[1]) rgl::rgl.lines(c(0,0), c(0,1), c(0,0), color=axis.col[2]) rgl::rgl.lines(c(0,0), c(0,0), c(0,1), color=axis.col[3]) rgl::rgl.texts(1, 0, 0, xlab, adj=1, color=axis.col[1]) rgl::rgl.texts(0, 1.05, 0, ylab, adj=1, color=axis.col[2]) rgl::rgl.texts(0, 0, 1, zlab, adj=1, color=axis.col[3]) # if (axis.scales){ # rgl::rgl.texts(min.x, -0.05, 0, lab.min.x, col=axis.col[1]) # rgl::rgl.texts(max.x, -0.05, 0, lab.max.x, col=axis.col[1]) # rgl::rgl.texts(0, -0.1, min.z, lab.min.z, col=axis.col[3]) # rgl::rgl.texts(0, -0.1, max.z, lab.max.z, col=axis.col[3]) # rgl::rgl.texts(-0.05, min.y, -0.05, lab.min.y, col=axis.col[2]) # rgl::rgl.texts(-0.05, max.y, -0.05, lab.max.y, col=axis.col[2]) # } if (ellipsoid) { dfn <- 3 if (is.null(groups)){ dfd <- length(x) - 1 ell.radius <- sqrt(dfn * qf(level, dfn, dfd)) ellips <- ellipsoid(center=c(mean(x), mean(y), mean(z)), shape=cov(cbind(x,y,z)), radius=ell.radius) if (fill) rgl::shade3d(ellips, col=surface.col[1], alpha=ellipsoid.alpha, lit=FALSE) if (grid) rgl::wire3d(ellips, col=surface.col[1], lit=FALSE) } else{ levs <- levels(groups) for (j in 1:length(levs)){ group <- levs[j] select.obs <- groups == group xx <- x[select.obs] yy <- y[select.obs] zz <- z[select.obs] dfd <- length(xx) - 1 ell.radius <- sqrt(dfn * qf(level, dfn, dfd)) ellips <- ellipsoid(center=c(mean(xx), mean(yy), mean(zz)), shape=cov(cbind(xx,yy,zz)), radius=ell.radius) if (fill) rgl::shade3d(ellips, col=surface.col[j], alpha=ellipsoid.alpha, lit=FALSE) if (grid) rgl::wire3d(ellips, col=surface.col[j], lit=FALSE) coords <- ellips$vb[, which.max(ellips$vb[1,])] if (!surface) rgl::rgl.texts(coords[1] + 0.05, coords[2], coords[3], group, col=surface.col[j]) } } } if (surface){ vals <- seq(0, 1, length.out=grid.lines) dat <- expand.grid(x=vals, z=vals) for (i in 1:length(fit)){ f <- match.arg(fit[i], c("linear", "quadratic", "smooth", "additive")) if (is.null(groups)){ mod <- switch(f, linear = lm(y ~ x + z), quadratic = lm(y ~ (x + z)^2 + I(x^2) + I(z^2)), smooth = if (is.null(df.smooth)) mgcv::gam(y ~ s(x, z)) else mgcv::gam(y ~ s(x, z, fx=TRUE, k=df.smooth)), additive = if (is.null(df.additive)) mgcv::gam(y ~ s(x) + s(z)) else mgcv::gam(y ~ s(x, fx=TRUE, k=df.additive[1]+1) + s(z, fx=TRUE, k=(rev(df.additive+1)[1]+1))) ) if (model.summary) summaries[[f]] <- summary(mod) yhat <- matrix(predict(mod, newdata=dat), grid.lines, grid.lines) if (fill) rgl::rgl.surface(vals, vals, yhat, color=surface.col[i], alpha=surface.alpha, lit=FALSE) if(grid) rgl::rgl.surface(vals, vals, yhat, color=if (fill) grid.col else surface.col[i], alpha=surface.alpha, lit=FALSE, front="lines", back="lines") if (residuals){ n <- length(y) fitted <- fitted(mod) colors <- ifelse(residuals(mod) > 0, pos.res.col, neg.res.col) rgl::rgl.lines(as.vector(rbind(x,x)), as.vector(rbind(y,fitted)), as.vector(rbind(z,z)), color=as.vector(rbind(colors,colors))) if (squares){ res <- y - fitted xx <- as.vector(rbind(x, x, x + res, x + res)) yy <- as.vector(rbind(y, fitted, fitted, y)) zz <- as.vector(rbind(z, z, z, z)) rgl::rgl.quads(xx, yy, zz, color=square.col, alpha=surface.alpha, lit=FALSE) rgl::rgl.lines(xx, yy, zz, color=square.col) } } } else{ if (parallel){ mod <- switch(f, linear = lm(y ~ x + z + groups), quadratic = lm(y ~ (x + z)^2 + I(x^2) + I(z^2) + groups), smooth = if (is.null(df.smooth)) mgcv::gam(y ~ s(x, z) + groups) else mgcv::gam(y ~ s(x, z, fx=TRUE, k=df.smooth) + groups), additive = if (is.null(df.additive)) mgcv::gam(y ~ s(x) + s(z) + groups) else mgcv::gam(y ~ s(x, fx=TRUE, k=df.additive[1]+1) + s(z, fx=TRUE, k=(rev(df.additive+1)[1]+1)) + groups) ) if (model.summary) summaries[[f]] <- summary(mod) levs <- levels(groups) for (j in 1:length(levs)){ group <- levs[j] select.obs <- groups == group yhat <- matrix(predict(mod, newdata=cbind(dat, groups=group)), grid.lines, grid.lines) if (fill) rgl::rgl.surface(vals, vals, yhat, color=surface.col[j], alpha=surface.alpha, lit=FALSE) if (grid) rgl::rgl.surface(vals, vals, yhat, color=if (fill) grid.col else surface.col[j], alpha=surface.alpha, lit=FALSE, front="lines", back="lines") rgl::rgl.texts(1, predict(mod, newdata=data.frame(x=1, z=1, groups=group)), 1, paste(group, " "), adj=1, color=surface.col[j]) if (residuals){ yy <- y[select.obs] xx <- x[select.obs] zz <- z[select.obs] fitted <- fitted(mod)[select.obs] res <- yy - fitted rgl::rgl.lines(as.vector(rbind(xx,xx)), as.vector(rbind(yy,fitted)), as.vector(rbind(zz,zz)), col=surface.col[j]) if (squares) { xxx <- as.vector(rbind(xx, xx, xx + res, xx + res)) yyy <- as.vector(rbind(yy, fitted, fitted, yy)) zzz <- as.vector(rbind(zz, zz, zz, zz)) rgl::rgl.quads(xxx, yyy, zzz, color=surface.col[j], alpha=surface.alpha, lit=FALSE) rgl::rgl.lines(xxx, yyy, zzz, color=surface.col[j]) } } } } else { levs <- levels(groups) for (j in 1:length(levs)){ group <- levs[j] select.obs <- groups == group mod <- switch(f, linear = lm(y ~ x + z, subset=select.obs), quadratic = lm(y ~ (x + z)^2 + I(x^2) + I(z^2), subset=select.obs), smooth = if (is.null(df.smooth)) mgcv::gam(y ~ s(x, z), subset=select.obs) else mgcv::gam(y ~ s(x, z, fx=TRUE, k=df.smooth), subset=select.obs), additive = if (is.null(df.additive)) mgcv::gam(y ~ s(x) + s(z), subset=select.obs) else mgcv::gam(y ~ s(x, fx=TRUE, k=df.additive[1]+1) + s(z, fx=TRUE, k=(rev(df.additive+1)[1]+1)), subset=select.obs) ) if (model.summary) summaries[[paste(f, ".", group, sep="")]] <- summary(mod) yhat <- matrix(predict(mod, newdata=dat), grid.lines, grid.lines) if (fill) rgl::rgl.surface(vals, vals, yhat, color=surface.col[j], alpha=surface.alpha, lit=FALSE) if (grid) rgl::rgl.surface(vals, vals, yhat, color=if (fill) grid.col else surface.col[j], alpha=surface.alpha, lit=FALSE, front="lines", back="lines") rgl::rgl.texts(1, predict(mod, newdata=data.frame(x=1, z=1, groups=group)), 1, paste(group, " "), adj=1, color=surface.col[j]) if (residuals){ yy <- y[select.obs] xx <- x[select.obs] zz <- z[select.obs] fitted <- fitted(mod) res <- yy - fitted rgl::rgl.lines(as.vector(rbind(xx,xx)), as.vector(rbind(yy,fitted)), as.vector(rbind(zz,zz)), col=surface.col[j]) if (squares) { xxx <- as.vector(rbind(xx, xx, xx + res, xx + res)) yyy <- as.vector(rbind(yy, fitted, fitted, yy)) zzz <- as.vector(rbind(zz, zz, zz, zz)) rgl::rgl.quads(xxx, yyy, zzz, color=surface.col[j], alpha=surface.alpha, lit=FALSE) rgl::rgl.lines(xxx, yyy, zzz, color=surface.col[j]) } } } } } } } else levs <- levels(groups) if (id.method == "identify"){ Identify3d(xg, yg, zg, axis.scales=axis.scales, groups=ggroups, labels=glabels, col=surface.col, offset=offset) } else if (id.method != "none"){ if (is.null(groups)) showLabels3d(x, y, z, labels, id.method=id.method, id.n=id.n, col=surface.col[1]) else { for (j in 1:length(levs)){ group <- levs[j] select.obs <- groups == group showLabels3d(x[select.obs], y[select.obs], z[select.obs], labels[select.obs], id.method=id.method, id.n=id.n, col=surface.col[j]) } } } if (revolutions > 0) { for (i in 1:revolutions){ for (angle in seq(1, 360, length.out=360/speed)) rgl::rgl.viewpoint(-angle, fov=fov) } } if (model.summary) return(summaries) else return(invisible(NULL)) } # the following function is a slight modification of rgl.select3d() in the rgl package, # altered to pass through arguments (via ...) to rgl.select() car.select3d <- function (...) { if (!requireNamespace("rgl")) stop("rgl package is missing") rgl::.check3d() rect <- rgl::rgl.select(...) llx <- rect[1] lly <- rect[2] urx <- rect[3] ury <- rect[4] if (llx > urx) { temp <- llx llx <- urx urx <- temp } if (lly > ury) { temp <- lly lly <- ury ury <- temp } proj <- rgl::rgl.projection() function(x, y, z) { pixel <- rgl::rgl.user2window(x, y, z, projection = proj) apply(pixel, 1, function(p) (llx <= p[1]) && (p[1] <= urx) && (lly <= p[2]) && (p[2] <= ury) && (0 <= p[3]) && (p[3] <= 1)) } } Identify3d <- function (x, y, z, axis.scales=TRUE, groups = NULL, labels = 1:length(x), col = c("blue", "green", "orange", "magenta", "cyan", "red", "yellow", "gray"), offset = ((100/length(x))^(1/3)) * 0.02){ if (!requireNamespace("rgl")) stop("rgl package is missing") if (!is.null(groups)){ counts <- table(groups) if (any(counts == 0)){ levels <- levels(groups) warning("the following groups are empty: ", paste(levels[counts == 0], collapse=", ")) groups <- factor(groups, levels=levels[counts != 0]) } } valid <- if (is.null(groups)) complete.cases(x, y, z) else complete.cases(x, y, z, groups) labels <- labels[valid] x <- x[valid] y <- y[valid] z <- z[valid] groups <- groups[valid] minx <- min(x) maxx <- max(x) miny <- min(y) maxy <- max(y) minz <- min(z) maxz <- max(z) if (axis.scales){ lab.min.x <- nice(minx) lab.max.x <- nice(maxx) lab.min.y <- nice(miny) lab.max.y <- nice(maxy) lab.min.z <- nice(minz) lab.max.z <- nice(maxz) minx <- min(lab.min.x, minx) maxx <- max(lab.max.x, maxx) miny <- min(lab.min.y, miny) maxy <- max(lab.max.y, maxy) minz <- min(lab.min.z, minz) maxz <- max(lab.max.z, maxz) min.x <- (lab.min.x - minx)/(maxx - minx) max.x <- (lab.max.x - minx)/(maxx - minx) min.y <- (lab.min.y - miny)/(maxy - miny) max.y <- (lab.max.y - miny)/(maxy - miny) min.z <- (lab.min.z - minz)/(maxz - minz) max.z <- (lab.max.z - minz)/(maxz - minz) } x <- (x - minx)/(maxx - minx) y <- (y - miny)/(maxy - miny) z <- (z - minz)/(maxz - minz) rgl::rgl.bringtotop() identified <- character(0) groups <- if (!is.null(groups)) as.numeric(groups[valid]) else rep(1, length(x)) repeat { f <- car.select3d(button="right") which <- f(x, y, z) if (!any(which)) break rgl::rgl.texts(x[which], y[which] + offset, z[which], labels[which], color = col[groups][which]) identified <- c(identified, labels[which]) } unique(identified) } showLabels3d <- function(x, y, z, labels, id.method = "identify", id.n=length(x), col=c("blue"), res=y - mean(y), range.x=range(x), range.z=range(z), offset = ((100/length(x))^(1/3)) * 0.02) { if (!requireNamespace("rgl")) stop("rgl package is missing") if (id.method == "none") return(NULL) if(id.n > 0L) { if (missing(labels)) labels <- as.character(seq(along=x)) getPoints <- function(w) { names(w) <- labels iid <- seq(length=id.n) ws <- w[order(-w)[iid]] match(names(ws), labels) } ind <- switch(id.method, xz = getPoints(rowSums(qr.Q(qr(cbind(1, x, z))) ^ 2)), y = getPoints(abs(res)), xyz = union(getPoints(abs(x - mean(x))), union(abs(z - mean(z)), getPoints(abs(res)))), mahal= getPoints(rowSums(qr.Q(qr(cbind(1, x, y, z))) ^ 2))) rgl::rgl.texts(x[ind], y[ind] + offset, z[ind], labels[ind], color = col) return(labels[ind]) } } ellipsoid <- function(center=c(0, 0, 0), radius=1, shape=diag(3), n=30){ if (!requireNamespace("rgl")) "rgl package is missing" # adapted from the shapes3d demo in the rgl package degvec <- seq(0, 2*pi, length.out=n) ecoord2 <- function(p) c(cos(p[1])*sin(p[2]), sin(p[1])*sin(p[2]), cos(p[2])) v <- t(apply(expand.grid(degvec,degvec), 1, ecoord2)) v <- center + radius * t(v %*% chol(shape)) v <- rbind(v, rep(1,ncol(v))) e <- expand.grid(1:(n-1), 1:n) i1 <- apply(e, 1, function(z) z[1] + n*(z[2] - 1)) i2 <- i1 + 1 i3 <- (i1 + n - 1) %% n^2 + 1 i4 <- (i2 + n - 1) %% n^2 + 1 i <- rbind(i1, i2, i4, i3) rgl::qmesh3d(v, i) } car/R/outlierTest.R0000644000176000001440000000376614140261763013736 0ustar ripleyusers#------------------------------------------------------------------------------- # Revision history: # 2009-09-28 by J. Fox (renamed) # 2010-04-14 by J. Fox fixed error in reporting largest abs rstudent # 2012-12-12 by J. Fox fixed handling of labels argument # 2019-01-02 by J. Fox added lmerMod method # 2019-05-12 by J. Fox fixed spelling of "Bonferroni" #------------------------------------------------------------------------------- # Bonferroni test for an outlier (J. Fox) outlierTest <- function(model, ...){ UseMethod("outlierTest") } outlierTest.lm <- function(model, cutoff=0.05, n.max=10, order=TRUE, labels=names(rstudent), ...){ rstudent <- rstudent(model) if (length(rstudent) != length(labels)) stop("Number of labels does not correspond to number of residuals.") else names(rstudent) <- labels df <- df.residual(model) - 1 rstudent <- rstudent[!is.na(rstudent)] n <- length(rstudent) p <- if (class(model)[1] == "glm") 2*(pnorm(abs(rstudent), lower.tail=FALSE)) else 2*(pt(abs(rstudent), df, lower.tail=FALSE)) bp <- n*p ord <- if (order) order(bp) else 1:n ord <- ord[bp[ord] <= cutoff] result <- if (length(ord) == 0){ which <- which.max(abs(rstudent)) list(rstudent=rstudent[which], p=p[which], bonf.p=bp[which], signif=FALSE, cutoff=cutoff) } else { if (length(ord) > n.max) ord <- ord[1:n.max] result <- list(rstudent=rstudent[ord], p=p[ord], bonf.p=bp[ord], signif=TRUE, cutoff=cutoff) } class(result)<-"outlierTest" result } outlierTest.lmerMod <- function(model, ...){ outlierTest.lm(model, ...) } print.outlierTest<-function(x, digits=5, ...){ if (!x$signif){ cat("No Studentized residuals with Bonferroni p <", x$cutoff) cat("\nLargest |rstudent|:\n") } bp <- x$bonf bp[bp > 1] <- NA table <- data.frame(rstudent=x$rstudent, "unadjusted p-value"=signif(x$p, digits), "Bonferroni p"=signif(bp, digits), check.names=FALSE) rownames(table) <- names(x$rstudent) print(table) invisible(x) } car/R/Boot.R0000644000176000001440000005362414140261763012314 0ustar ripleyusers# Boot: A reimplementation of bootCase using the 'boot' package to do the # work. The main function 'Boot' creates the 'statistic' argument to # 'boot', and passes this function to 'boot' # For the call b1 <- Boot(m1) and b2 <- bootCase(m1), # b2 was the returned bootstaps; this is in b1$t # b1 is of class c("Boot", "boot", so ALL the 'boot' generic methods work # 'Boot' has new generic methods 'summary', 'confint' and 'hist' # notes: See Davison and Hinkley Chapters 6 and 7. # Boot.lm, method="case" is the simple case resampling # method="residual" uses algorithm 6.3, p. 271 # The use of weights comes from using 'pearson' residuals # This is equivalent to alg. 6.1, p262, unweighted # Boot.glm method="case" as for lm # method="residual" not implemented. Too problematic. # May 23, 2012 Sanford Weisberg sandy@umn.edu # June 1, 2012: changed from class c("Boot", "boot") to just class "boot" # 2012-12-10 replaced .GlobalEnv with .carEnv to avoid warnings # 2013-07-08 changed .carEnv to car:::.carEnv so 'boot' could find the environment # 4014-08-17: added calls to requireNamespace() and :: where necessary. J. Fox # 2015-01-27 .carEnv now in global environment. John # 2015-02-20: fixed coding error in Boot.nls(). John # 2017-06-12: added a default for f in the generic method to suppress an error generated by Rstudio # 2017-06-22: added a vcov.boot method that simply returns cov(object$t) # 2017-06-22: fixed args to hist.boot as suggested by Achim Zeileis # 2017-06-22: Fixed bugs in Boot.default; updated .Rd file as suggested by Achim Zeileis # 2017-06-24: (Z) added '...' argument to generic and all methods # set labels=names(f(object)) with f() rather than coef() # simplified and avoid bug in computation of 'out' and check for $qr in Boot.default # do not rely on $model to be available # instead set up empty dummy data with right number of rows (either via nobs or # NROW(residuals(...))) # optionally use original estimates as starting values in update(object, ...) # within Boot.default # 2017-06-25: modified bca confidence intervals to default to 'perc' if adjustment is out of range # 2017-06-26: consistently use inherits(..., "try-error") rather than class(...) == "try-error" # 2017-09-16: Changed to vcov.boot method to pass arguments to cov. In # particular, if some of the bootstrap reps are NA, then the argument # use="complete.obs" may be desirable. # 2017-10-06: Corrected bug that put the wrong estimates in t0 if missing values were # present with case resampling. # 2017-10-19: Added "norm" as an option on histograms # 2017-11-30: Use carPalette() for colors in hist.boot() # 2017-12-24: Removed parallel argument that was added. If ncores<=1, no parallel processing is used. If ncores>1 # selects the correct parallel environment, and implements with that number of cores. # 2018-01-28: Changed print.summary.boot to print R once only if it is constant # 2018-04-02: John fixed error in Boot.nlm() reported by Derek Ogle. # 2018-05-16: John modified Confint.boot() to return a "confint.boot" object. # 2018-08-03: Sandy corrected bug in Boot.lm and Boot.glm that caused failure # with transformed predictors. Also added test to missing values. # If missing values are present, Boot returns an error. # 2018-09-21: John fixed bug that hard-coded level=0.95 when confint.boot() falls # back to type="perc" (reported by Derek Lee Sonderegger). # 2018-09-21: Brad removed the otpions for multicore on non-unix OS platforms. It now will # produce a warning and set ncores=1. ##2018-12-21: Brad changed the cluster initalizations for the parallel environements to makeCluster ## For non-unix environments we export the data, and model type to the cluster. ## 2020-09-02: Corrected weights with lm models and method="residual" to # match Alg 6.3 of Davison and Hinkley ## 2020-09=02: Removed unneeded code using missing values in Boot.nls ## 2020-09-02: Boot.nls failed if nls algorithm="plinear". This is fixed ## 2020-09-02: Correctly use weights in lm, nls ## 2020-12-03: changed vcov.boot to use="complete.obs" by default, added a warning if any bootstrap samples are NA ## 2021-04-21: Residual bootstrap fails if namespace not attached; was tentatively fixed, but the fix has been commented out with #ns ## 2021-05-27: Legend in hist.boot slightly improved. Boot <- function(object, f=coef, labels=names(f(object)), R=999, method=c("case", "residual"), ncores=1, ...){UseMethod("Boot")} Boot.default <- function(object, f=coef, labels=names(f(object)), R=999, method=c("case", "residual"), ncores=1, start=FALSE,...) { if(!(requireNamespace("boot"))) stop("The 'boot' package is missing") ## original statistic f0 <- f(object) if(length(labels) != length(f0)) labels <- paste0("V", seq_along(f0)) ## process starting values (if any) if(isTRUE(start)) start <- f0 ## set up bootstrap handling for case vs. residual bootstrapping method <- match.arg(method, c("case", "residual")) if(method=="case") { boot.f <- function(data, indices, .fn) { assign(".boot.indices", indices, envir=.carEnv) mod <- if(identical(start, FALSE)) { update(object, subset=get(".boot.indices", envir=.carEnv)) } else { update(object, subset=get(".boot.indices", envir=.carEnv), start=start) } out <- if(!is.null(object$qr) && (mod$qr$rank != object$qr$rank)) f0 * NA else .fn(mod) out } } else { boot.f <- function(data, indices, .fn) { first <- all(indices == seq(length(indices))) res <- if(first) residuals(object, type="pearson") else residuals(object, type="pearson")/sqrt(1 - hatvalues(object)) res <- if(!first) (res - mean(res)) else res # next two lines added 9/2/2020. This works for lm or other model methods # that return a slot called weights with the case weights wts <- if(!is.null(object$weights)) object$weights else 1 val <- fitted(object) + res[indices]/sqrt(wts) if (!is.null(object$na.action)){ pad <- object$na.action attr(pad, "class") <- "exclude" val <- naresid(pad, val) } assign(".y.boot", val, envir=.carEnv) #ns attach(.carEnv) # namespace fix deleted #ns on.exit(detach(.carEnv)) # namespace fix deleted mod <- if(identical(start, FALSE)) { update(object, get(".y.boot", envir=.carEnv) ~ .) } else { update(object, get(".y.boot", envir=.carEnv) ~ ., start=start) #ns update(object, .y.boot ~ .) #, data=Data) #ns } else { #ns update(object, .y.boot ~ ., start=start) #, data=Data, start=start) } out <- if(!is.null(object$qr) && (mod$qr$rank != object$qr$rank)) f0 * NA else .fn(mod) out } } ## try to determine number of observations and set up empty dummy data nobs0 <- function(x, ...) { rval <- try(stats::nobs(x, ...), silent = TRUE) if(inherits(rval, "try-error") | is.null(rval)) rval <- NROW(residuals(x, ...)) return(rval) } n <- nobs0(object) dd <- data.frame(.zero = rep.int(0L, n)) if(ncores<=1){ #parallel_env="no" #ncores=getOption("boot.ncpus",1L) cl2=NULL p_type="no" #}else{ #if(.Platform$OS.type=="unix"){ # parallel_env="multicore" }else{ #warning("Multicore processing in Boot is not avaliable for Windows. It is current under development") #ncores=1 #parallel_env="no" #ncores=getOption("boot.ncpus",1L) cl2 <- parallel::makeCluster(ncores) on.exit(parallel::stopCluster(cl2)) if(.Platform$OS.type=="unix"){ p_type="multicore" }else{ p_type="snow" parallel::clusterExport(cl2,varlist=c(".carEnv",sapply(c(1,3),function(m){gsub("()",getCall(object)[m],replacement="")}))) } } ## call boot() but set nice labels b <- boot::boot(dd, boot.f, R, .fn=f,parallel=p_type,ncpus = ncores, cl = cl2,...) colnames(b$t) <- labels ## clean up and return if(exists(".y.boot", envir=.carEnv)) remove(".y.boot", envir=.carEnv) if(exists(".boot.indices", envir=.carEnv)) remove(".boot.indices", envir=.carEnv) b } Boot.lm <- function(object, f=coef, labels=names(f(object)), R=999, method=c("case", "residual"), ncores=1, ...){ # check for missing values: if(!is.null(object$na.action)) stop("The Boot function in the 'car' package does not allow missing values for lm or glm models. Refit your model with rows with missing values removed. If you have a data frame called 'd', then the argument data=na.omit(d) is likely to work.") Boot.default(object, f, labels, R, method, ncores, ...) } Boot.glm <- function(object, f=coef, labels=names(f(object)), R=999, method=c("case", "residual"), ncores=1, ...) { method <- match.arg(method, c("case", "residual")) if(method != "case") stop("Residual bootstrap is not implemented in the 'car' function 'Boot'. Use the 'boot' function in the 'boot' package to write your own version of residual bootstrap for a glm.") # check for missing values: if(!is.null(object$na.action)) stop("The Boot function in the 'car' package does not allow missing values for lm or glm models. Refit your model with rows with missing values removed. If you have a data frame called 'd', then the argument data=na.omit(d) is likely to work.") Boot.default(object, f, labels, R, method,ncores, ...) } Boot.nls <- function(object, f=coef, labels=names(f(object)), R=999, method=c("case", "residual"), ncores=1, ...) { ## check for missing values: if(!is.null(object$na.action)) stop("The Boot function in the 'car' package does not allow missing values for nls models. Refit your model with rows with missing values removed. If you have a data frame called 'd', then the argument data=complete.cases(d) is likely to work.") if(!(requireNamespace("boot"))) stop("The 'boot' package is missing") f0 <- f(object) if(length(labels) != length(f0)) labels <- paste("V", seq(length(f0)), sep="") method <- match.arg(method) if(method=="case") { boot.f <- function(data, indices, .fn) { assign(".boot.indices", indices, envir=.carEnv) # When algorithm="plinear", remove all coefs with names starting with '.' # from the starting values sv <- coef(object) if(object$call$algorithm == "plinear") sv <- sv[!grepl("\\.", names(sv))] # update the call to use the bootstrap sample determined by indices # if the weights argument has been set then update it as well. newcall <- if(is.null(object$weights)) update(object, subset=get(".boot.indices", envir=.carEnv), start=sv, evaluate=FALSE) else update(object, subset=get(".boot.indices", envir=.carEnv), weights=object$weights, start=sv, evaluate=FALSE) # try to evaluate the call mod <- try(eval(newcall), silent=TRUE) if(inherits(mod, "try-error")){ out <- .fn(object) out <- rep(NA, length(out)) } else {out <- .fn(mod)} out } } else { boot.f <- function(data, indices, .fn) { wts <- if(is.null(object$weights)) 1 else object$weights res <- residuals(object) * sqrt(wts) # Pearson residuals val <- fitted(object) + res[indices]/sqrt(wts) assign(".y.boot", val, envir=.carEnv) assign(".wts", wts, envir=.carEnv) #ns attach(.carEnv) #ns on.exit(detach(.carEnv)) # When algorithm="plinear", remove all coefs with names starting with '.' # from the starting values sv <- coef(object) if(object$call$algorithm == "plinear") sv <- sv[!grepl("^\\.", names(sv))] # generate an updated call with .y.boot as the response but do not evaluate newcall <- if(is.null(object$call$weights)) update(object, get(".y.boot", envir=.carEnv) ~ ., start=sv, evaluate=FALSE) #ns update(object, .y.boot ~ ., start=sv, evaluate=FALSE) else update(object, get(".y.boot", envir=.carEnv) ~ ., weights= get(".wts", envir=.carEnv), start=sv, evaluate=FALSE) #ns update(object, .y.boot ~ ., # works #ns weights= .wts, #ns start=sv, evaluate=FALSE) # formula.update may have mangled the rhs of newcall$formula # copy it from the original call. I consider this to be a kludge to work # around a bug in formula.update newcall$formula[[3]] <- formula(object)[[3]] # refit to bootstrap sample mod <- try(eval(newcall), silent=TRUE) if(inherits(mod, "try-error")){ out <- .fn(object) out <- rep(NA, length(out)) } else {out <- .fn(mod)} out } } # multicore code if(ncores<=1){ #parallel_env="no" #ncores=getOption("boot.ncpus",1L) cl2=NULL p_type="no" #}else{ #if(.Platform$OS.type=="unix"){ # parallel_env="multicore" }else{ #warning("Multicore processing in Boot is not available for Windows. It is current under development") #ncores=1 #parallel_env="no" #ncores=getOption("boot.ncpus",1L) cl2 <- parallel::makeCluster(ncores) on.exit(parallel::stopCluster(cl2)) if(.Platform$OS.type=="unix"){ p_type="multicore" }else{ p_type="snow" parallel::clusterExport(cl2,varlist=c(".carEnv",sapply(c(1,3),function(m){gsub("()",getCall(object)[m],replacement="")}))) } } # call boot::boot. b <- boot::boot(data.frame(update(object, model=TRUE)$model), boot.f, R, .fn=f, parallel = p_type, ncpus = ncores, cl=cl2, ...) # b <- boot::boot(eval(object$data), boot.f, R, .fn=f, parallel = p_type, ncpus = ncores, cl=cl2, ...) colnames(b$t) <- labels if(exists(".y.boot", envir=.carEnv)) remove(".y.boot", envir=.carEnv) if(exists(".boot.indices", envir=.carEnv)) remove(".boot.indices", envir=.carEnv) if(exists(".wts", envir=.carEnv)) remove(".wts", envir=.carEnv) d <- dim(na.omit(b$t))[1] if(d != R) cat( paste("\n","Number of bootstraps was", d, "out of", R, "attempted", "\n")) b } Confint.boot <- function(object, parm, level = 0.95, type = c("bca", "norm", "basic", "perc"), ...){ ci <- confint(object, parm, level, type, ...) typelab <- attr(ci, "type") class <- class(ci) co <- object$t0 co <- co[names(co) %in% rownames(ci)] ci <- cbind(Estimate=co, ci) attr(ci, "type") <- typelab class(ci) <- class ci } confint.boot <- function(object, parm, level = 0.95, type = c("bca", "norm", "basic", "perc"), ...){ if (!requireNamespace("boot")) "boot package is missing" cl <- match.call() type <- match.arg(type) # if(type=="all") stop("Use 'boot::boot.ci' if you want to see 'all' types") # has no effect types <- c("bca", "norm", "basic", "perc") typelab <- c("bca", "normal", "basic", "percent")[match(type, types)] nn <- colnames(object$t) names(nn) <- nn parm <- if(missing(parm)) which(!is.na(object$t0)) else parm out <- list() for (j in 1:length(parm)){ out[[j]] <- try(boot::boot.ci(object, conf=level, type=type, index=parm[j], ...), silent=TRUE) if(inherits(out[[j]], "try-error") && type=="bca"){ warning("BCa method fails for this problem. Using 'perc' instead") return(confint(object, parm, level = level, type = "perc", ...))} } levs <- unlist(lapply(level, function(x) c( (1-x)/2, 1 - (1-x)/2))) ints <- matrix(0, nrow=length(parm), ncol=length(levs)) rownames(ints) <- nn[parm] for (j in 1:length(parm)){ which <- if(typelab=="normal") 2:3 else 4:5 ints[j, ] <- as.vector(t(out[[j]][[typelab]][, which])) } or <- order(levs) levs <- levs[or] ints <- ints[, or, drop=FALSE] colnames(ints) <- paste(round(100*levs, 1), " %",sep="") attr(ints,"type") <- typelab class(ints) <- c("confint.boot", class(ints)) ints } print.confint.boot <- function(x, ...) { cat("Bootstrap", attr(x, "type"), "confidence intervals\n\n") print(as.data.frame(x), ...) } summary.boot <- function (object, parm, high.moments = FALSE, extremes=FALSE, ...) { cl <- match.call() skew1 <- function(x){ x <- x[!is.na(x)] xbar <- mean(x) sum((x-xbar)^3)/(length(x) * sd(x)^3) } kurtosis1 <- function (x) { x <- x[!is.na(x)] xbar <- mean(x) sum((x - xbar)^4)/(length(x) * sd(x)^4) - 3 } not.aliased <- !is.na(object$t0) boots <- object$t[ , not.aliased, drop=FALSE ] nc <- if(is.matrix(boots)) ncol(boots) else 1 stats <- matrix(rep(NA, nc * 10), ncol = 10) rownames(stats) <- colnames(boots) stats[, 1] <- apply(boots, 2, function(x) sum(!is.na(x))) # num. obs stats[, 2] <- object$t0[not.aliased] # point estimate stats[, 3] <- apply(boots, 2, function(x) mean(x, na.rm=TRUE)) - stats[, 2] stats[, 5] <- apply(boots, 2, function(x) median(x, na.rm=TRUE)) stats[, 4] <- apply(boots, 2, function(x) sd(x, na.rm=TRUE)) stats[, 6] <- apply(boots, 2, function(x) min(x, na.rm=TRUE)) stats[, 7] <- apply(boots, 2, function(x) max(x, na.rm=TRUE)) stats[, 8] <- stats[, 7] - stats[, 6] stats[, 9] <- apply(boots, 2, skew1) stats[, 10] <- apply(boots, 2, kurtosis1) colnames(stats) <- c( "R", "original", "bootBias", "bootSE", "bootMed", "bootMin", "bootMax", "bootRange", "bootSkew", "bootKurtosis") stats <- as.data.frame(stats) class(stats) <- c("summary.boot", "data.frame") use <- rep(TRUE, 10) if (high.moments == FALSE) use[9:10] <- FALSE if (extremes==FALSE) use[6:8] <- FALSE parm <- if(missing(parm)) 1:dim(stats)[1] else parm return(stats[parm , use]) } print.summary.boot <- function(x, digits = max(getOption("digits") - 2, 3), ...) { if(dim(x)[1] == 1L){print.data.frame(x, digits=digits, ...)} else{ if(sd(x[, 1]) < 1.e-8 ) { cat(paste("\nNumber of bootstrap replications R =", x[1, 1], "\n", sep=" ")) print.data.frame(x[, -1], digits=digits, ...)} else print.data.frame(x, digits=digits, ...) }} hist.boot <- function(x, parm, layout=NULL, ask, main="", freq=FALSE, estPoint = TRUE, point.col=carPalette()[1], point.lty=2, point.lwd=2, estDensity = !freq, den.col=carPalette()[2], den.lty=1, den.lwd=2, estNormal = !freq, nor.col=carPalette()[3], nor.lty=2, nor.lwd=2, ci=c("bca", "none", "perc", "norm"), level=0.95, legend=c("top", "none", "separate"), box=TRUE, ...){ not.aliased <- which(!is.na(x$t0)) ci <- match.arg(ci) legend <- match.arg(legend) pe <- x$t0[not.aliased] if(is.null(names(pe))) names(pe) <- colnames(x$t) if(missing(parm)) parm <- not.aliased nt <- length(parm) + if(legend == "separate") 1 else 0 if (nt > 1 & (is.null(layout) || is.numeric(layout))) { if(is.null(layout)){ layout <- switch(min(nt, 9), c(1, 1), c(1, 2), c(2, 2), c(2, 2), c(3, 2), c(3, 2), c(3, 3), c(3, 3), c(3, 3)) } ask <- if(missing(ask) || is.null(ask)) prod(layout) < nt else ask oma3 <- if(legend == "top") 1.0 + estPoint + estDensity + estNormal else 1.5 op <- par(mfrow=layout, ask=ask, no.readonly=TRUE, oma=c(0, 0, oma3, 0), mar=c(5, 4, 1, 2) + .1) on.exit(par(op)) } if(ci != "none") clim <- confint(x, type=ci, level=level) pn <- colnames(x$t) names(pn) <- pn what <- c(estNormal & !freq, estDensity & !freq, ci != "none", estPoint) for (j in parm){ # determine the range of the y-axis z <- na.omit(x$t[, j]) h <- hist(z, plot=FALSE) d <- density(z) n <- pnorm(0)/(sd <- sd(z)) m <- if(freq == FALSE) max(h$density, d$y, n) else max(h$counts) plot(h, xlab=pn[j], freq=freq, main=if(length(parm)==1) main else "", ylim=c(0, m), ...) if(estDensity & !freq){ lines(d, col=den.col, lty=den.lty, lwd=den.lwd) } if(estNormal & !freq){ z <- na.omit(x$t[, j]) xx <- seq(-4, 4, length=400) xbar <- mean(z) sd <- sd(z) lines( xbar + sd*xx, dnorm(xx)/sd, col=nor.col, lty=nor.lty, lwd=nor.lwd) } if(ci != "none") lines( clim[j ,], c(0, 0), lwd=4) if(estPoint) abline(v=pe[j], lty=point.lty, col=point.col, lwd=point.lwd) if(box) box() if( j == parm[1] & legend == "top" ) { # add legend usr <- par("usr") legend.coords <- list(x=usr[1], y=usr[4] * 1.05 + 1.3 * (1 + sum(what)) *strheight("N")) legend( legend.coords, c("Normal Density", "Kernel Density", paste(ci, " ", round(100*level), "% CI", sep=""), "Obs. Value")[what], lty=c(nor.lty, den.lty, 1, point.lty)[what], col=c(nor.col, den.col, "black", point.col)[what], fill=c(nor.col, den.col, "black", point.col)[what], lwd=c(2, 2, 4, 2)[what], border=c(nor.col, den.col, "black", point.col)[what], bty="n", cex=0.9, xpd=NA)#, #horiz=TRUE, offset= } } mtext(side=3, outer=TRUE, main, cex=1.2) if(legend == "separate") { plot(0:1, 0:1, xaxt="n", yaxt="n", xlab="", ylab="", type="n") use <- (1:4)[c( estNormal, estDensity, TRUE, ci != "none")] curves <- c("Normal Density", "Kernel Density", paste(ci, " ", 100*level, "% CI", sep=""), "Obs. Value") colors <- c(nor.col, den.col, "black", point.col) lines <- c(nor.lty, den.lty, 1, point.lty) widths<- c(nor.lwd, den.lwd, 2, point.lty) legend("center", curves[use], lty=lines[use], lwd=widths[use], col=colors[use], bty="n", #box.col=par()$bg, title="Bootstrap histograms") } invisible(NULL) } vcov.boot <- function(object, use="complete.obs", ...){ if(use == "complete.obs"){ num <- nrow(object$t) - nrow(na.omit(object$t)) if(num == 1L) warning( "one bootstrap sample returned NA and was omitted") if(num > 1L) warning( paste(num, " bootstrap samples returned NA and were omitted", sep=""))} cov(object$t, use=use) } car/R/symbox.R0000644000176000001440000000575314140261763012732 0ustar ripleyusers# 2010-09-05: J. Fox: allow xlab argument, pass through ... # 2013-08-19: J. Fox: remove loading of stats package # 2018-07-27: J. Fox: automatically generate start # 2021-04-08: J. Fox: added symbox.lm() method. symbox <- function(x, ...){ UseMethod("symbox") } symbox.formula <- function(formula, data=NULL, subset, na.action=NULL, ylab, ...){ variable <- all.vars(formula) if (length(variable) != 1) stop("the formula must specify one variable") m <- match.call(expand.dots = FALSE) if (is.matrix(eval(m$data, parent.frame()))) m$data <- as.data.frame(data) m$ylab <- m$... <- NULL m$na.action <- na.action m[[1]] <- as.name("model.frame") mf <- eval(m, parent.frame()) if (missing(ylab)) ylab <- paste("Transformations of", variable) symbox(as.vector(mf[[1]]), ylab=ylab, ...) } symbox.default <- function(x, powers = c(-1, -0.5, 0, 0.5, 1), start, trans=bcPower, xlab="Powers", ylab, ...) { if (!(is.vector(x) && is.numeric(x))) stop("x should be a numeric vector.") if (missing(ylab)) ylab <- deparse(substitute(x)) trans.name <- deparse(substitute(trans)) if (missing(start)){ if (trans.name %in% c("bcPower", "bcnPower")){ if ((min.x <- min(x, na.rm=TRUE)) <= 0){ max.x <- max(x, na.rm=TRUE) start <- abs(min.x) + 0.01*(max.x - min.x) warning("start set to ", format(start)) } else { start <- 0 } } else { start <- 0 } } x <- x + start if (trans.name == "bcnPower") trans <- function(x, lambda) bcnPower(x, lambda, gamma=start) result <- lapply(powers, function(lambda) trans(x, lambda)) names <- as.character(powers) names[powers == 0] <- "log" names(result) <- names result <- as.data.frame(scale(do.call(cbind, result))) boxplot(result, xlab=xlab, ylab=ylab, yaxt="n", ...) } symbox.lm <- function(x, powers = c(-1, -0.5, 0, 0.5, 1), start, trans=bcPower, xlab, ylab="Studentized residuals", ...) { trans.name <- deparse(substitute(trans)) if (missing(xlab)) xlab <- paste("Powers of:", responseName(x)) y <- model.response(model.frame(x)) if (missing(start)){ if (trans.name %in% c("bcPower", "bcnPower")){ if ((min.y <- min(y, na.rm=TRUE)) <= 0){ max.y <- max(y, na.rm=TRUE) start <- abs(min.y) + 0.01*(max.y - min.y) warning("start set to ", format(start)) } else { start <- 0 } } else { start <- 0 } } y <- y + start if (trans.name == "bcnPower") trans <- function(x, lambda) bcnPower(x, lambda, gamma=start) rstudents <- vector(length(powers), mode="list") names(rstudents) <- as.character(powers) Data <- na.omit(getModelData(x)) for (power in powers){ Data$.y. <- trans(y, power) m <- update(x, formula = .y. ~ ., data=Data) rstudents[[as.character(power)]] <- rstudent(m) } names <- names(rstudents) names[powers == 0] <- "log" names(rstudents) <- names rstudents <- as.data.frame(scale(do.call(cbind, rstudents))) boxplot(rstudents, xlab=xlab, ylab=ylab, yaxt="n", ...) invisible(rstudents) } car/R/hccm.R0000644000176000001440000000437714140261763012324 0ustar ripleyusers#------------------------------------------------------------------------------- # Revision history: # 2009-09-16: optionally allow models with aliased coefficients J. Fox # 2012-04-04: modified to allow weighted linear models. J. Fox # 2020-06-25: Fix bug in hccm.lm() when model matrix includes just one column # (reported by Justin Yap). J. Fox # 2021-07-29: Report error when any hatvalue = 1 for all but hc0 and hc1 # (following report of problem reported by Peng Ding) J. Fox #------------------------------------------------------------------------------- # Heteroscedasticity-corrected standard errors (Huber/White adjustment) (J. Fox) hccm <- function(model, ...){ UseMethod("hccm") } hccm.lm <-function (model, type = c("hc3", "hc0", "hc1", "hc2", "hc4"), singular.ok = TRUE, ...) { e <- na.omit(residuals(model)) removed <- attr(e, "na.action") wts <- if (is.null(weights(model))) 1 else weights(model) type <- match.arg(type) if (any(aliased <- is.na(coef(model))) && !singular.ok) stop("there are aliased coefficients in the model") sumry <- summary(model, corr = FALSE) s2 <- sumry$sigma^2 V <- sumry$cov.unscaled if (type == FALSE) return(s2 * V) h <- hatvalues(model) if (!is.null(removed)){ wts <- wts[-removed] h <- h[-removed] } X <- model.matrix(model)[, !aliased, drop=FALSE] df.res <- df.residual(model) n <- length(e) e <- wts*e p <- ncol(X) factor <- switch(type, hc0 = 1, hc1 = df.res/n, hc2 = 1 - h, hc3 = (1 - h)^2, hc4 = (1 - h)^pmin(4, n * h/p)) V <- V %*% t(X) %*% apply(X, 2, "*", (e^2)/factor) %*% V bad <- h > 1 - sqrt(.Machine$double.eps) if ((n.bad <- sum(bad)) > 0 && !(type %in% c("hc0", "hc1"))) { nms <- names(e) bads <- if (n.bad <= 10) { paste(nms[bad], collapse=", ") } else { paste0(paste(nms[bad[1:10]], collapse=", "), ", ...") } if (any(is.nan(V))){ stop("cannot proceed because of ", n.bad, if (n.bad == 1) " case " else " cases ", "with hatvalue = 1:\n ", bads) } else { warning("adjusted coefficient covariances may be unstable because of ", n.bad, if (n.bad == 1) " case " else " cases ", "with hatvalue near 1:\n ", bads) } } V } hccm.default<-function(model, ...){ stop("requires an lm object") } car/R/bcnPower.R0000644000176000001440000004575014140261763013171 0ustar ripleyusers# 05-02-2017: bcnPower family, replacing skewPower. S. Weisberg # 2017-05-18: Changed summary.powerTransform; deleted invalid test; added roundlam to output # 2017-12-19: Deleted plot method # 2017-12-19: Improved handling of gamma small case, still not great for the # multivariate extenstion. Works for lm and lmer # 2017-12-25: bug fix with multivariace bcnPower # 2019-03-07: bug fix in estimateTransform.bcnPowerlmer, thanks to wouter@zoology.ubc.ca # 2019-11-14,15: change class(x) == "y" to inherits(x, "y") and likewise for != bcnPower <- function(U, lambda, jacobian.adjusted=FALSE, gamma) { if(is.matrix(U)){ if(dim(U)[2] != length(lambda) | dim(U)[2] != length(gamma)) stop("gamma and lambda must have length equal to number of columns in U") } else { if(length(gamma) != 1 | length(lambda) != 1) stop("gamma and lambda must be length 1") } if(any(gamma < 0)) stop("gamma must be >= 0") hc1 <- function(U, lambda, gamma){ if(abs(gamma) <= 1.e-10 & any(U[!is.na(U)] <= 0)) stop("First argument must be strictly positive if gamma = 0.") s <- sqrt(U^2 + gamma^2) z <- if (abs(lambda) <= 1.e-10) log(.5*(U + s)) else ((.5*(U + s))^lambda - 1)/lambda if (jacobian.adjusted == TRUE) { Jn <- (.5^lambda) * (exp((lambda - 1) * mean(log(U + s), na.rm=TRUE))) * (exp(mean(log(1 + U/s), na.rm=TRUE))) z <- z/Jn} z } out <- U out <- if(is.matrix(out) | is.data.frame(out)){ if(is.null(colnames(out))) colnames(out) <- paste("Z", 1:dim(out)[2], sep="") for (j in 1:ncol(out)) {out[, j] <- hc1(out[, j], lambda[j], gamma[j]) } colnames(out) <- paste(colnames(out), "(", round(lambda, 2), ",",round(gamma, 1),")", sep="") # colnames(out) <- paste(colnames(out), round(lambda, 2), sep="^") out} else hc1(out, lambda, gamma) out} bcnPowerInverse <- function(z, lambda, gamma){ q <- if(abs(lambda) < 1.e-7) 2 * exp(z) else 2 * (lambda*z + 1)^(1/lambda) (q^2 - gamma^2)/(2 * q) } ############################################################################### # estimateTransform and methods # # multivariate box-cox with negatives starting values, given X and Y bcn.sv <- function(X, Y, weights, itmax=100, conv=.0001, verbose=FALSE, start=TRUE, gamma.min=.1){ Y <- as.matrix(Y) d <- dim(Y)[2] if(d > 1) stop("bcn.sv requires a univariate response") lambda.1d <- function(Y, weights, lambda, gamma, xqr){ fn <- function(lam) bcnPowerllik(NULL, Y, weights, lambda=lam, gamma=gamma, xqr=xqr)$llik f <- optimize(f=fn, interval=c(-3, 3), maximum=TRUE) list(lambda=f$maximum, gamma=gamma, llik=f$objective) } gamma.1d <- function(Y, weights, lambda, gamma, xqr){ fn1 <- function(gam) bcnPowerllik(NULL, Y, weights, lambda=lambda, gamma=gam, xqr=xqr)$llik f <- optimize(f=fn1, interval=c(0.01, max(Y)), maximum=TRUE) list(lambda=lambda, gamma=f$maximum, llik=f$objective) } # get qr decomposition w <- if(is.null(weights)) 1 else sqrt(weights) xqr <- qr(w * as.matrix(X)) # get starting value for gamma gamma <- if(min(Y) <= 0) max(min(Y[Y>0]), 5*gamma.min) else 0 res <- lambda.1d(Y, weights, lambda=1, gamma=gamma, xqr) res <- gamma.1d(Y, weights, lambda=res$lambda, gamma=res$gamma, xqr) # set iteration counter i <- 0 crit <- 1 gamma.ok <- TRUE while( (crit > conv) & (i < itmax) & gamma.ok) { i <- i+1 last.value <- res res <- lambda.1d(Y, weights, res$lambda, res$gamma, xqr) res <- gamma.1d(Y, weights, res$lambda, res$gamma, xqr) if(res$gamma < 1.5 * gamma.min){ gamma.ok <- FALSE res <- lambda.1d(Y, weights, res$lambda, gamma.min, xqr) } crit <- (res$llik - last.value$llik)/abs(res$llik) if(verbose) print(data.frame(Iter=i, gamma=res$gamma, lambda=res$gamma, llik=res$llik, crit=crit)) } if(i==itmax & conv > crit) warning(paste("No convergence in", itmax, "iterations, criterion =", crit, collapse=" ")) # if(!gamma.ok) warning(paste("gamma too close to zero, set to", gamma.min, collapse=" ")) if(start == TRUE) return(c(res, gamma.estimated=gamma.ok)) else { # compute the Hessian -- depends on gamma.ok if(gamma.ok){ fn2 <- function(param){ lam <- param[1] gam <- param[2] bcnPowerllik(NULL, Y, weights, lam, gam, xqr=xqr)$llik } hess <- optimHess(c(res$lambda, res$gamma), fn2) res$invHess <- solve(-hess)} else{ # gamma.ok == FALSE fn3 <- function(lam){ lam bcnPowerllik(NULL, Y, weights, lam, gamma.min, xqr=xqr)$llik } hess <- optimHess(res$lambda, fn3) res$invHess <- matrix(c(-1/hess, NA, NA, NA), ncol=2)} # end computing of invHess rownames(res$invHess) <- colnames(res$invHess) <- c("lambda", "gamma") roundlam <- res$lambda stderr <- sqrt(diag(res$invHess[1, 1, drop=FALSE])) stderr.gam <- sqrt(diag(res$invHess[2, 2, drop=FALSE])) lamL <- roundlam - 1.96 * stderr lamU <- roundlam + 1.96 * stderr for (val in rev(c(1, 0, -1, .5, .33, -.5, -.33, 2, -2))) { sel <- lamL <= val & val <= lamU roundlam[sel] <- val } res$roundlam <- roundlam res$ylabs <- if (is.null(colnames(Y))) paste("Y", 1:dim(as.matrix(Y))[2], sep="") else colnames(Y) res$xqr <- xqr res$y <- as.matrix(Y) res$x <- as.matrix(X) res$weights <- weights res$family <- "bcnPowerTransform" res$y res$gamma.estimated <- gamma.ok class(res) <- c("bcnPowerTransform", "powerTransform") res} } estimateTransform.bcnPower <- function(X, Y, weights, itmax=100, conv=.0001, verbose=FALSE, gamma.min=.1){ d <- dim(as.matrix(Y))[2] skf.lambda <- function(Y, weights, lambda, gamma, xqr){ fn3a <- function(lam) bcnPowerllik(NULL, Y, weights, lambda=lam, gamma=gamma, xqr=xqr)$llik f <- optim(par=lambda, fn=fn3a, method="L-BFGS-B", lower=rep(-3, d), upper=rep(3, d), control=list(fnscale=-1)) list(lambda=f$par, gamma=gamma, llik=f$value, conv=f$convergence, message=f$message) } skf.gamma <- function(Y, weights, lambda, gamma, xqr){ fn3b <- function(gam) bcnPowerllik(NULL, Y, weights, lambda=lambda, gamma=gam, xqr=xqr)$llik f <- optim(par=gamma, fn=fn3b, method="L-BFGS-B", lower=rep(gamma.min, d), upper=rep(Inf, d), control=list(fnscale=-1)) list(lambda=lambda, gamma=f$par, llik=f$value, conv=f$convergence, message=f$message) } # get qr decomposition once w <- if(is.null(weights)) 1 else sqrt(weights) xqr <- qr(w * as.matrix(X)) # if d = 1 call bcn.sv and return, else call bcn.sv to get starting values. if(d == 1) bcn.sv(X, Y, weights, start=FALSE) else{ # The rest of this code is for the multivariate case # get starting values for gamma sv <- apply(Y, 2, function(y) unlist(bcn.sv(X, y, weights, start=TRUE))) res <- as.list(as.data.frame(t(sv))) # output to a list # gamma.estimated converted to numeric, so fixup res$gamma.estimated <- ifelse(res$gamma.estimated==1, TRUE, FALSE) res$llik <- -Inf # set iteration counter i <- 0 crit <- 1 # iterate while( (crit > conv) & (i < itmax)) { i <- i+1 last.value <- res res <- skf.gamma (Y, weights, res$lambda, res$gamma, xqr) res <- skf.lambda(Y, weights, res$lambda, res$gamma, xqr) crit <- (res$llik - last.value$llik)/abs(res$llik) if(verbose) print(paste("Iter:", i, "llik=", res$llik, "Crit:", crit, collapse=" ")) } if(itmax == 1) warning("One iteration only, results assume responses are uncorrelated") # if(i==itmax & conv > crit) # warning(paste("No convergence in", itmax, "iterations, criterion =", crit, collapse=" ")) fn4 <- function(param){ lam <- param[1:d] gam <- param[(d+1):(2*d)] bcnPowerllik(NULL, Y, weights, lam, gam, xqr=xqr)$llik } # check gamma gamma.ok <- ifelse(res$gamma > 1.5*gamma.min, TRUE, FALSE) res$gamma[!gamma.ok] <- gamma.min if(all(gamma.ok)){ hess <- try(optimHess(c(res$lambda, res$gamma), fn4)) res$invHess <- if(inherits(hess, "try-error")) NA else solve(-hess) } else { fn4a <- function(lam) fn4(c(lam, res$gamma)) hess <- try(optimHess(res$lambda, fn4a)) # hessian for lambda only res$invHess <- matrix(NA, nrow=2*d, ncol=2*d) res$invHess[1:d, 1:d] <- solve(-hess) } roundlam <- res$lambda stderr <- sqrt(diag(res$invHess[1:d, 1:d, drop=FALSE])) stderr.gam <- sqrt(diag(res$invHess[(d+1):(2*d), (d+1):(2*d), drop=FALSE])) lamL <- roundlam - 1.96 * stderr lamU <- roundlam + 1.96 * stderr for (val in rev(c(1, 0, -1, .5, .33, -.5, -.33, 2, -2))) { sel <- lamL <= val & val <= lamU roundlam[sel] <- val } res$roundlam <- roundlam res$ylabs <- if (is.null(colnames(Y))) paste("Y", 1:d, sep="") else colnames(Y) invHesslabels <- c(paste(res$ylabs, "lambda", sep=":"), paste(res$ylabs, "gamma", sep=":")) if (!inherits(hess, "try-error")) rownames(res$invHess) <- colnames(res$invHess) <- invHesslabels res$xqr <- xqr res$y <- as.matrix(Y) res$x <- as.matrix(X) res$weights <- weights res$family <- "bcnPowerTransform" res$y class(res) <- c("bcnPowerTransform", "powerTransform") res$gamma.estimated <- gamma.ok res }} ############################################################################# ## The log-likelihood function assuming a normal target ## Evaluate bcnPower llik at (lambda, gamma)----------------------------------- bcnPowerllik <- function(X, Y, weights=NULL, lambda, gamma, xqr=NULL) { Y <- as.matrix(Y) # coerces Y to be a matrix. w <- if(is.null(weights)) 1 else sqrt(weights) xqr <- if(is.null(xqr)){qr(w * as.matrix(X))} else xqr nr <- nrow(Y) f <- -(nr/2)*log(((nr - 1)/nr) * det(as.matrix(var(qr.resid(xqr, w * bcnPower(Y, lambda, jacobian.adjusted=TRUE, gamma=gamma)))))) list(lambda=lambda, gamma=gamma, llik=f) } ############################################################################### # testTransform testTransform.bcnPowerTransform <- function(object, lambda=rep(1, dim(object$y)[2])){ d <- length(object$lambda) lam <- if(length(lambda)==1) rep(lambda, d) else lambda skf.gamma <- function(Y, weights, lambda, gamma, xqr){ fn5 <- function(gam) bcnPowerllik(NULL, Y, weights, lambda=lam, gamma=gamma, xqr=xqr)$llik f <- optim(par=gamma, fn=fn5, method="L-BFGS-B", lower=rep(.Machine$double.eps^0.25, d), upper=rep(Inf, d), control=list(fnscale=-1)) list(lambda=lambda, gamma=f$par, llik=f$value, conv=f$convergence, message=f$message) } val <- skf.gamma(object$y, object$weights, lam, gamma=object$gamma, xqr=object$xqr)$llik LR <- max(0, -2 * (val - object$llik)) df <- d pval <- 1-pchisq(LR, df) out <- data.frame(LRT=LR, df=df, pval=pval) rownames(out) <- c(paste("LR test, lambda = (", paste(round(lam, 2), collapse=" "), ")", sep="")) out} print.bcnPowerTransform<-function(x, ...) { cat("Estimated transformation power, lambda\n") print(x$lambda) # temporary code if(is.null(x$gamma.estimated)) x$gamma.estimated=TRUE if(any(x$gamma.estimated)){ cat("\nEstimated location, gamma\n")} else{ cat("\nLocation gamma was fixed at its lower bound\n")} print(x$gamma) invisible(x)} summary.bcnPowerTransform <- function(object, ...){ nc <- length(object$lambda) label <- paste(if(nc==1) "bcnPower transformation to Normality" else "bcnPower transformation to Multinormality", "\n") lambda <- object$lambda roundlam <- round(object$roundlam, 3) gamma <- object$gamma stderr <- sqrt(diag(object$invHess)) stderr.gamma <- stderr[(nc+1):(2*nc)] stderr <- stderr[1:nc] result <- cbind(lambda, roundlam, lambda - 1.96*stderr, lambda + 1.96*stderr) result.gamma <- cbind(gamma, stderr.gamma, pmax(gamma - 1.96*stderr.gamma, 0), gamma + 1.96*stderr.gamma) rownames(result) <- rownames(result.gamma) <- object$ylabs colnames(result) <- c("Est Power", "Rounded Pwr", "Wald Lwr Bnd", "Wald Upr Bnd") colnames(result.gamma) <- c("Est gamma", "Std Err.", "Wald Lower Bound", "Wald Upper Bound") tests <- testTransform(object, 0) tests <- rbind(tests, testTransform(object, 1)) # if ( !(all(object$roundlam==0) | all(object$roundlam==1) | # length(object$roundlam)==1 | all(object$roundlam == object$lambda))) # tests <- rbind(tests, testTransform(object, object$roundlam)) out <- list(label=label, result=result, result.gamma=result.gamma, tests=tests, gamma.estimated=object$gamma.estimated) if(is.null(out$gamma.estimated)) out$gamma.estimated <- TRUE class(out) <- "summary.bcnPowerTransform" out } print.summary.bcnPowerTransform <- function(x,digits=4, ...) { cat(x$label) cat("\nEstimated power, lambda\n") print(round(x$result, digits)) if(any(x$gamma.estimated)){ cat("\nEstimated location, gamma\n")} else{ cat("\nLocation gamma was fixed at its lower bound\n")} print(round(x$result.gamma, digits)) cat("\nLikelihood ratio tests about transformation parameters\n") print(x$tests) if(any(x$result.gamma[,1] < 1.e-5)) warning( "When gamma is zero, transformation family is the Box-Cox Power family") } coef.bcnPowerTransform <- function(object, param=c("both", "lambda", "gamma"), round=FALSE, ...){ param <- match.arg(param) co <- cbind(if(round==TRUE) object$roundlam else object$lambda, object$gamma) dimnames(co) <- list(object$ylabs, c("lambda", "gamma")) switch(param, lambda = co[, 1], gamma=co[, 2], both= co) } vcov.bcnPowerTransform <- function(object, param=c("both", "lambda", "gamma"), ...) { param <- match.arg(param) nc <- length(object$lambda) switch(param, lambda=object$invHess[1:nc, 1:nc], gamma=object$invHess[(nc+1):(2*nc), (nc+1):(2*nc)], both=object$invHess) } ########################################################################################## # bcnPower for lmer models # Modified 12/19/2017 to handle gamma-at-the boundary gracefully estimateTransform.bcnPowerlmer <- function(object, verbose=FALSE, conv=.001, itmax=100, gamma.min=.1, ...) { data <- model.frame(object) y <- (object@resp)$y lambda.1d <- function(lambda, gamma){ fn6 <- function(lam){ data$y1 <- bcnPower(y, lambda=lam, jacobian.adjusted=TRUE, gamma) logLik(update(object, y1 ~ ., data=data))} f <- optimize(f=fn6, interval=c(-3, 3), maximum=TRUE) list(lambda=f$maximum, gamma=gamma, llik=f$objective) } gamma.1d <- function(lambda=lambda, gamma=gamma){ fn7 <- function(gam){ data$y1 <- bcnPower(y, lambda, jacobian.adjusted=TRUE, gamma=gam) logLik(update(object, y1 ~ ., data=data))} f <- optimize(f=fn7, interval=c(.5*gamma.min, max(y)), maximum=TRUE) list(lambda=lambda, gamma=f$maximum, llik=f$objective) } # starting values for lambda, gamma lambda <- gamma <- 1 gamma.ok <- TRUE res <- lambda.1d(lambda, gamma) res <- gamma.1d(res$lambda, res$gamma) if(res$gamma < 1.5 * gamma.min){ gamma.ok <- FALSE res <- lambda.1d(res$lambda, gamma.min) } else{ # iteration is needed only if gamma is not on the boundary # set iteration counter i <- 0 crit <- 1 while( (crit > conv) & (i < itmax) & gamma.ok) { i <- i+1 last.value <- res res <- lambda.1d(res$lambda, res$gamma) res <- gamma.1d(res$lambda, res$gamma) if(res$gamma < 1.5 * gamma.min){ gamma.ok <- FALSE res <- lambda.1d(res$lambda, gamma.min) } crit <- (res$llik - last.value$llik)/abs(res$llik) if(verbose) print(data.frame(Iter=i, gamma=res$gamma, lambda=res$lambda, llik=res$llik, crit=crit)) } if(i==itmax & conv > crit) warning(paste("No convergence in", itmax, "iterations, criterion =", crit, collapse=" ")) } # if(!gamma.ok) warning(paste("gamma too close to zero, set to",gamma.min, collapse=" ")) # optimize does not give the Hessian, so run optimHess if(gamma.ok){ llikfn <- function(par){ data$y1 <- bcnPower(y, par[1], jacobian.adjusted=TRUE, par[2]) mf <- update(object, y1 ~ ., data=data) logLik(mf) } res$invHess <- solve(-optimHess(unlist(res[1:2]), llikfn)) if(any(diag(res$invHess) < 0)) res$invHess <- matrix(NA, nrow=2, ncol=2) } else { llikfn1 <- function(lam){ data$y1 <- bcnPower(y, lambda=lam, jacobian.adjusted=TRUE, gamma=res$gamma) logLik(update(object, y1 ~ ., data=data))} v1 <- -1/optimHess(res$lambda, llikfn1) res$invHess <- matrix(c(v1, NA, NA, NA), ncol=2) } roundlam <- res$lambda stderr <- sqrt(res$invHess[1,1]) lamL <- roundlam - 1.96 * stderr lamU <- roundlam + 1.96 * stderr for (val in rev(c(1, 0, -1, .5, .33, -.5, -.33, 2, -2))) { sel <- lamL <= val & val <= lamU roundlam[sel] <- val } res$model <- object res$roundlam <- roundlam res$family<-family res$gamma.estimated <- gamma.ok class(res) <- c("bcnPowerTransformlmer", "bcnPowerTransform") res } testTransform.bcnPowerTransformlmer <- function(object, lambda=1){ nc <- 1 lam <- lambda mod <- object$model data <- model.frame(mod) data$.y <- mod@resp$y gamma.1d <- function(mod, lambda=lambda, gamma=gamma){ fn <- function(gam){ data$.y1 <- bcnPower(data$.y, lambda, jacobian.adjusted=TRUE, gamma=gam) logLik(update(mod, .y1 ~ ., data=data))} f <- optimize(f=fn, interval=c(1.e-5, max(data$.y)), maximum=TRUE) list(lambda=lambda, gamma=f$maximum, llik=f$objective) } val <- gamma.1d(object$model, lambda, object$gamma)$llik LR <- max(0, -2 * (val - object$llik)) df <- nc pval <- 1-pchisq(LR, df) out <- data.frame(LRT=LR, df=df, pval=pval) rownames(out) <- c(paste("LR test, lambda = (", paste(round(lam, 2), collapse=" "), ")", sep="")) out} summary.bcnPowerTransformlmer<-function(object,...){ nc <- length(object$lambda) label <- "bcn - Box-Cox Power transformation to Normality\nallowing for negative values, lmer fit\n" lambda <- object$lambda gamma <- object$gamma stderr <- sqrt(diag(object$invHess)) stderr.gamma <- stderr[(nc+1):(2*nc)] stderr <- stderr[1:nc] result <- cbind(lambda, stderr, lambda - 1.96*stderr, lambda + 1.96*stderr) result.gamma <- cbind(gamma, stderr.gamma, pmax(gamma - 1.96*stderr.gamma, 0), gamma + 1.96*stderr.gamma) rownames(result) <- rownames(result.gamma) <- object$ylabs colnames(result) <- colnames(result.gamma) <- c("Est.Power", "Std.Err.", "Wald Lower Bound", "Wald Upper Bound") colnames(result.gamma) <- c("Est.gamma", "Std.Err.", "Wald Lower Bound", "Wald Upper Bound") tests <- testTransform(object, 0) tests <- rbind(tests, testTransform(object, 1)) if ( !(all(object$roundlam==0) | all(object$roundlam==1) | length(object$roundlam)==1 )) tests <- rbind(tests, testTransform(object, object$roundlam)) out <- list(label=label, result=result, result.gamma=result.gamma, gamma.estimated=object$gamma.estimated,tests=tests) class(out) <- "summary.bcnPowerTransform" out } car/R/utility-functions.R0000644000176000001440000005056114140261763015117 0ustar ripleyusers # Utility functions (J. Fox) # 16 March 2010 changed 'vars' argument to 'terms' # 28 June 2010 added df.terms.surveg and model.matrix.survreg # 15 November 2010 added squeezeBlanks # 21 January 2011 added functions to support mixed models # 2012-04-08 added exists.method # 2012-06-23: added call to globalVariables(). John # 2012-12-10: added .carEnv to avoid warnings in R > 2.16.0 # 2013-06020: added .merMod methods to df.residual() and has.intercept(). John # 2014-05-16: added .multinom method for has.intercept(). John # 2014-08-19: added package.installed() function, unexported. John # 2014-11-02: termsToMf fixed, Sandy # 2015-01-13: fixed model.matrix.lme() to work with model with formula as object. John # 2015-01-27: .carEnv now lives in the global environment. John # 2015-09-04: added model.matrix.coxme() and alias.coxme(). John # 2015-09-11: added some support for VGAM::vglm objects. John # 2017-02-10: added isFALSE() and applyDefaults() to support plotting functions. John # 2017-04-14: added carPalette to the end of this file. May require further work later. # 2017-11-30: new version of carPalette(). John # 2017-11-30: substitute carPalette() for palette(). J. Fox # 2017-12-28: rewrote termsToMf used by residualPlots. It didn't work right. SW # 2018-01-15: df.terms.multinom() now works with response matrix. JF # 2018-05-23: make model.matrix.lme() more bullet proof, following report by Peter Grossmann. JF # 2018-11-07: added combineLists(). JF # 2019-01-02: added na.action.merMod(), removed df.residual.merMod(). JF # 2019-10-24: include colorblind palette in carPalette(). JF # 2019-11-14: change class(x) == "y" to inherits(x, "y") # 2020-02-17: added matchFun() as a replacement for match.fun # 2020-10-19: added envelope() for plotting confidence/variance envelopes. JF # 2020-12-03: added getVcov to interpret vcov. argument as matrix or function and return an error otherwise # 2020-12-18: getVcov() also able to return objects coercible to a matrix such as Matrix objects. JF # 2021-04-08: added getModelData(), not explorted. JF #if (getRversion() >= "2.15.1") globalVariables(c(".boot.sample", ".boot.indices")) .carEnv <- new.env(parent=globalenv()) # function to find "nice" numbers nice <- function(x, direction=c("round", "down", "up"), lead.digits=1){ direction <- match.arg(direction) if (length(x) > 1) return(sapply(x, nice, direction=direction, lead.digits=lead.digits)) if (x == 0) return(0) power.10 <- floor(log(abs(x),10)) if (lead.digits > 1) power.10 <- power.10 - lead.digits + 1 lead.digit <- switch(direction, round=round(abs(x)/10^power.10), down=floor(abs(x)/10^power.10), up=ceiling(abs(x)/10^power.10)) sign(x)*lead.digit*10^power.10 } has.intercept <- function (model, ...) { UseMethod("has.intercept") } has.intercept.default <- function(model, ...) any(names(coefficients(model))=="(Intercept)") has.intercept.multinom <- function(model, ...) { nms <- names(coef(model)) any(grepl("\\(Intercept\\)", nms)) } term.names <- function (model, ...) { UseMethod("term.names") } term.names.default <- function (model, ...) { term.names <- labels(terms(model)) if (has.intercept(model)) c("(Intercept)", term.names) else term.names } predictor.names <- function(model, ...) { UseMethod("predictor.names") } predictor.names.default <- function(model, ...){ predictors <- attr(terms(model), "variables") as.character(predictors[3:length(predictors)]) } responseName <- function (model, ...) { UseMethod("responseName") } responseName.default <- function (model, ...) deparse(attr(terms(model), "variables")[[2]]) response <- function(model, ...) { UseMethod("response") } response.default <- function (model, ...) model.response(model.frame(model)) is.aliased <- function(model){ !is.null(alias(model)$Complete) } df.terms <- function(model, term, ...){ UseMethod("df.terms") } df.terms.default <- function(model, term, ...){ if (is.aliased(model)) stop("Model has aliased term(s); df ambiguous.") if (!missing(term) && 1 == length(term)){ assign <- attr(model.matrix(model), "assign") which.term <- which(term == labels(terms(model))) if (0 == length(which.term)) stop(paste(term, "is not in the model.")) sum(assign == which.term) } else { terms <- if (missing(term)) labels(terms(model)) else term result <- numeric(0) for (term in terms) result <- c(result, Recall(model, term)) names(result) <- terms result } } df.terms.multinom <- function (model, term, ...){ nlev <- if (is.null(model$lev)) ncol(model.response(model.frame(model))) else length(model$lev) if (!missing(term) && 1 == length(term)) { assign <- attr(model.matrix(model), "assign") which.term <- which(term == labels(terms(model))) if (0 == length(which.term)) stop(paste(term, "is not in the model.")) sum(assign == which.term) * (nlev - 1) } else { terms <- if (missing(term)) labels(terms(model)) else term result <- numeric(0) for (term in terms) result <- c(result, Recall(model, term)) names(result) <- terms result } } df.terms.polr <- function (model, term, ...){ if (!missing(term) && 1 == length(term)) { assign <- attr(model.matrix(model), "assign") which.term <- which(term == labels(terms(model))) if (0 == length(which.term)) stop(paste(term, "is not in the model.")) sum(assign == which.term) } else { terms <- if (missing(term)) labels(terms(model)) else term result <- numeric(0) for (term in terms) result <- c(result, Recall(model, term)) names(result) <- terms result } } df.terms.survreg <- function(model, term, ...){ if (is.aliased(model)) stop("Model has aliased term(s); df ambiguous.") if (!missing(term) && 1 == length(term)){ assign <- attr(model.matrix(model, data=model.frame(model)), "assign") which.term <- which(term == labels(terms(model))) if (0 == length(which.term)) stop(paste(term, "is not in the model.")) sum(assign == which.term) } else { terms <- if (missing(term)) labels(terms(model)) else term result <- numeric(0) for (term in terms) result <- c(result, Recall(model, term)) names(result) <- terms result } } model.matrix.survreg <- function(object, ...) model.matrix.default(object, model.frame(object)) mfrow <- function(n, max.plots=0){ # number of rows and columns for array of n plots if (max.plots != 0 && n > max.plots) stop(paste("number of plots =",n," exceeds maximum =", max.plots)) rows <- round(sqrt(n)) cols <- ceiling(n/rows) c(rows, cols) } inv <- function(x) solve(x) coefnames2bs <- function(g, para.names, parameterPrefix="b"){ metas <- c("(", ")", "[", "]", "{", "}", ".", "*", "+", "^", "$", ":", "|") metas2 <- paste("\\", metas, sep="") metas3 <- paste("\\\\", metas, sep="") for (i in seq(along=metas)) para.names <- gsub(metas2[i], metas3[i], para.names) # fix up metacharacters para.order <- order(nchar(para.names), decreasing=TRUE) para.names <- para.names[para.order] # avoid partial-name substitution std.names <- if ("(Intercept)" %in% para.names) paste(parameterPrefix, 0:(length(para.names) - 1), sep = "") else paste(parameterPrefix, 1:length(para.names), sep = "") std.names.ordered <- std.names[para.order] for (i in seq(along=para.names)){ g <- gsub(para.names[i], std.names.ordered[i], g) } list(g=g, std.names=std.names) } showLabelsScatter <- function(x, y, labels, id.var = NULL, id.method = c("mahal", "identify", "none"), log="", id.cex=.75, id.n=3, id.col=carPalette()[1], range.x=range(.x), show=TRUE) { id.method <- match.arg(id.method) if (id.method == "none" || id.n == 0 || !show) return(invisible(NULL)) if(id.n > 0L) { if (missing(labels)) labels <- if (!is.null(id.var)) names(id.var) else as.character(seq(along=x)) getPoints <- function(z) { names(z) <- labels iid <- seq(length=id.n) zs <- z[order(-z)[iid]] match(names(zs), labels) } logged <- function(axis=c("x", "y")){ axis <- match.arg(axis) 0 != length(grep(axis, log)) } valid <- complete.cases(x, y) x <- x[valid] y <- y[valid] labels <- labels[valid] if (length(id.var) == length(valid)) id.var <- id.var[valid] .x <- if (logged("x")) log(x) else x .y <- if (logged("y")) log(y) else y ind <- if (!is.null(id.var)) { if (length(id.var) == length(x)) order(-abs(id.var))[1L:id.n] else if(is.character(id.var)) match(id.var, labels) else id.var } else switch(id.method, x = getPoints(abs(.x - mean(.x))), y = getPoints(abs(.y - mean(.y))), xy = union(getPoints(abs(.x - mean(.x))), getPoints(abs(.y - mean(.y)))), mahal= getPoints(rowSums(qr.Q(qr(cbind(1, .x, .y))) ^ 2))) ind <- na.omit(ind) if (length(ind) == 0) return(invisible(NULL)) labpos <- c(4, 2)[1 + as.numeric(.x > mean(range.x))] text(x[ind], y[ind], labels[ind], cex = id.cex, xpd = TRUE, pos = labpos[ind], offset = 0.25, col=id.col) return(labels[ind]) } } # outerLegend, written by S. Weisberg Feb 2010 # outerLegend function # puts a legend in the margin, either at the upper left (margin = 3) # the default or upper right side otherwise # all the args from legend are used except for x, y, and xpd which are # set in the function. # offset is a fraction of the plot width or height to locate the legend outerLegend <- function(..., margin=3, offset=0, adjust=FALSE){ lims <- par("usr") if (margin == 3) { x0 <- lims[1] + offset*(lims[2]-lims[1]) y0 <- lims[4] } else { x0 <- lims[2] + offset*(lims[2]-lims[1]) y0 <- lims[4] } leg <- legend(x0, y0, ... , xpd=TRUE, plot=FALSE) if (margin == 3) { y0 <- y0 + leg$rect$h if(adjust == TRUE) x0 <- x0 - leg$text$x[1] } legend(x0, y0, ... , xpd=TRUE) } # added by J. Fox 18 Nov 2010 squeezeBlanks <- function(text){ gsub(" *", "", text) } # added by J. Fox 21 Jan 2011 to support mixed models df.residual.mer <- function(object, ...) NULL # df.residual.merMod <- function(object, ...) NULL # no longer needed, now supplied by lme4 df.residual.lme <- function(object, ...) Inf has.intercept.mer <- function(model){ any(names(fixef(model))=="(Intercept)") } has.intercept.merMod <- function(model){ any(names(fixef(model))=="(Intercept)") } model.matrix.lme <- function(object, ...){ data <- object$data if (is.null(data)){ model.matrix(formula(object), eval(object$call$data)) } else model.matrix(formula(object), data) } # added by J. Fox 2019-01-02: na.action.merMod <- function(object, ...){ nms <- names(attributes(model.frame(object))) if ("na.action" %in% nms) attributes(model.frame(object))$na.action else { na.action <- integer(0) class(na.action) <- options("na.action") na.action } } # added by J. Fox 2012-04-08 to use in deltaMethod.default() exists.method <- function(generic, object, default=TRUE, strict=FALSE){ classes <- class(object) if (default) classes <- c(classes, "default") if (strict) classes <- classes[1] any(paste(generic, ".", classes, sep="") %in% as.character(methods(generic))) } # Used by marginalModelPlots, residualPlots added 2012-09-24 plotArrayLegend <- function( location=c("top", "none", "separate"), items, col.items, lty.items, lwd.items, title="legend", pch=1:length(items)) { if(location== "none") return() n <- length(items) if(location == "top" ) { # add legend usr <- par("usr") coords <-list(x=usr[1], y=usr[3]) leg <- legend( coords, items, col=col.items, pch=pch, bty="n", cex=1, xpd=NA, plot=FALSE) coords <- list(x = usr[1], y=usr[4] + leg$rect$h) legend( coords, items, col=col.items, pch=pch, bty="n", cex=1, xpd=NA) } if(location == "separate") { plot(0:1, 0:1, xaxt="n", yaxt="n", xlab="", ylab="", type="n") bg <- par()$bg legend("center", items, lty=lty.items, lwd=lwd.items, fill=col.items, border=col.items,, col=col.items, box.col=par()$bg, title=title) } } termsToMf <- function(model, terms){ gform <- function(formula) { if (is.null(formula)) return(list(vars=formula, groups=NULL)) # is formula one-sided? if(length(formula) == 3) stop("terms must be a one-sided formula") rhs <- formula[[2]] # is '|' present in the formula? if("|" %in% all.names(rhs)){ if(length(rhs[[3]]) > 1) stop("only one conditional variable permitted") groups <- as.formula(paste("~ ", deparse(rhs[[3]]))) vars <- as.formula(paste("~", deparse(rhs[[2]])))} else{ groups <- NULL vars <- formula } list(vars=vars, groups=groups) } terms <- gform(as.formula(terms)) mf.vars <- try(update(model, terms$vars, method="model.frame"), silent=TRUE) # This second test is used for models like m1 <- lm(longley) which # fail the first test because update doesn't work if(inherits(mf.vars, "try-error")) mf.vars <- try(update(model, terms$vars, method="model.frame", data=model.frame(model)), silent=TRUE) if(inherits(mf.vars, "try-error")) stop("argument 'terms' not interpretable.") if(!is.null(terms$groups)){ mf.groups <- try(update(model, terms$groups, method="model.frame"), silent=TRUE) if(inherits(mf.groups, "try-error")) mf.groups <- try(update(model, terms$groups, method="model.frame", data=model.frame(model)), silent=TRUE) if(inherits(mf.groups, "try-error")) stop("argument 'terms' not interpretable.") } else {mf.groups <- NULL} list(mf.vars=mf.vars, mf.groups=mf.groups) } # the following function isn't exported, tests for existance of a package: package.installed <- function(package){ package <- as.character(substitute(package)) result <- try(find.package(package), silent=TRUE) !inherits(result, "try-error") } # support for coxme objects model.matrix.coxme <- function(object, ...){ if (!requireNamespace("survival")) stop("survival package is missing") class(object) <- "coxph" model.matrix(object) } alias.coxme <- function(model){ if(any(which <- is.na(coef(model)))) return(list(Complete=which)) else list() } # to make linearHypothesis() work again and to make Anova() work with VGAM:"vglm" objects # df.residual.vglm <- function(object, ...) object@df.residual # vcov.vglm <- function(object, ...) vcovvlm(object, ...) # coef.vglm <- function(object, ...) coefvlm(object, ...) has.intercept.vlm <- function(model, ...) any(grepl("^\\(Intercept\\)", names(coef(model)))) # formula.vglm <- function(x, ...) formulavlm(x = x, ...) # model.matrix.vglm <- function(object, ...) model.matrixvlm(object, ...) # for plotting functions, not exported: isFALSE <- function(x) length(x) == 1 && is.logical(x) && !isTRUE(x) applyDefaults <- function(args, defaults, type=""){ if (isFALSE(args)) return(FALSE) names <- names(args) names <- names[names != ""] if (!isTRUE(args) && !is.null(args) && length(names) != length(args)) warning("unnamed ", type, " arguments, will be ignored") if (isTRUE(args) || is.null(names)) defaults else defaults[names] <- args[names] as.list(defaults) } # carPal <- function(){ # car.palette <- default <- c("black", "blue", "magenta", "cyan", "orange", "gray", "green3", "red") # function(palette){ # if (missing(palette)) return(car.palette) # else{ # previous <- car.palette # car.palette <<- if( palette[1] == "default") default else palette # return(invisible(previous)) # } # } # } carPal <- function(){ car.palette <- default <- c("black", "blue", "magenta", "cyan", "orange", "gray", "green3", "red") colorblind <- rgb(red = c(0, 230, 86, 0, 240, 0, 213, 204), green = c(0, 159, 180, 158, 228, 114, 94, 121), blue = c(0, 0, 233, 115, 66, 178, 0, 167), names = c("black", "orange", "sky.blue", "bluish.green", "yellow", "blue", "vermillion", "reddish.purple"), maxColorValue = 255) # colorblind palette from https://jfly.uni-koeln.de/color/ function(palette){ if (missing(palette)) return(car.palette) else{ previous <- car.palette car.palette <<- if (palette[1] %in% c("default", "car")) { default } else if (palette[1] == "colorblind") { colorblind } else if (palette[1] == "R"){ palette() } else { palette } return(invisible(previous)) } } } carPalette <- carPal() # the following function borrowed from stats:::format.perc(), not exported format.perc <- function (probs, digits){ paste(format(100 * probs, trim = TRUE, scientific = FALSE, digits = digits), "%") } # the following unexported function is useful for combining results of parallel computations combineLists <- function(..., fmatrix="list", flist="c", fvector="rbind", fdf="rbind", recurse=FALSE){ # combine lists of the same structure elementwise # ...: a list of lists, or several lists, each of the same structure # fmatrix: name of function to apply to matrix elements # flist: name of function to apply to list elements # fvector: name of function to apply to data frame elements # recurse: process list element recursively frecurse <- function(...){ combineLists(..., fmatrix=fmatrix, fvector=fvector, fdf=fdf, recurse=TRUE) } if (recurse) flist="frecurse" list.of.lists <- list(...) if (length(list.of.lists) == 1){ list.of.lists <- list.of.lists[[1]] list.of.lists[c("fmatrix", "flist", "fvector", "fdf")] <- c(fmatrix, flist, fvector, fdf) return(do.call("combineLists", list.of.lists)) } if (any(!sapply(list.of.lists, is.list))) stop("arguments are not all lists") len <- sapply(list.of.lists, length) if (any(len[1] != len)) stop("lists are not all of the same length") nms <- lapply(list.of.lists, names) if (any(unlist(lapply(nms, "!=", nms[[1]])))) stop("lists do not all have elements of the same names") nms <- nms[[1]] result <- vector(len[1], mode="list") names(result) <- nms for(element in nms){ element.list <- lapply(list.of.lists, "[[", element) # clss <- sapply(element.list, class) clss <- lapply(element.list, class) # if (any(clss[1] != clss)) stop("list elements named '", element, if (!all(vapply(clss, function(e) all(e == clss[[1L]]), NA))) stop("list elements named '", element, "' are not all of the same class") is.df <- is.data.frame(element.list[[1]]) fn <- if (is.matrix(element.list[[1]])) fmatrix else if (is.list(element.list[[1]]) && !is.df) flist else if (is.vector(element.list[[1]])) fvector else if (is.df) fdf else stop("list elements named '", element, "' are not matrices, lists, vectors, or data frames") result[[element]] <- do.call(fn, element.list) } result } matchFun <- function(name){ object <- getFromNamespace(name, ns = "car") if (!is.function(object)) stop("'", name, "' is not a function") object } envelope <- function(x.low, x.up=x.low, lower, upper, col=1, lty=1, lwd=1, alpha=0.15, border=TRUE){ color <- as.vector(col2rgb(col))/255 polygon(c(x.up, rev(x.low)), c(upper, rev(lower)), col=rgb(red=color[1], green=color[2], blue=color[3], alpha=alpha), border=if (border) rgb(red=color[1], green=color[2], blue=color[3]) else NA, lty=lty, lwd=lwd) } getVcov <- function(v, mod, ...){ if(missing(v)) return(vcov(mod, ...)) if(inherits(v, "matrix")) return(v) if(is.function(v)) return(v(mod, ...)) if(is.null(v)) return(vcov(mod, ...)) v <- try(as.matrix(v), silent=TRUE) if (is.matrix(v)) return(v) stop("vcov. must be a matrix or a function") } getModelData <- function(model) { # returns a data frame with the data to which the model was fit # model: a statistical model object that responds to model.frame() and formula() data1 <- data <- model.frame(model) vars <- all.vars(formula(model)) if ("pi" %in% vars) { vars <- setdiff(vars, "pi") message("the symbol 'pi' is treated as a numeric constant in the model formula") } cols <- colnames(data) check <- vars %in% cols if (!(all(check))) { missing.cols <- !check data1 <- expand.model.frame(model, vars[missing.cols]) } missing.cols <- !cols %in% colnames(data1) if (any(missing.cols)) { data1 <- cbind(data1, data[missing.cols]) } cols <- colnames(data1) valid <- make.names(cols) == cols | grepl("^\\(.*\\)$", cols) data1[valid] } car/R/carWeb.R0000644000176000001440000000575314140261763012614 0ustar ripleyusers# March 20, 2017 CarWeb needs revision so that it will # go to website3 if page = website # view errata in browser if page=errata # go to taskviews if page = taskview # download a file if file=filename # download a script file if script = chap-num # Add more to carWeb including cheat sheets # 2/21/2018 deleted "ethics" from the deafulat for page # 2018-04-25: J. Fox. Update website URLs; update setup files # 2018-04-28: J. Fox. Check whether file exists before overwriting carWeb <- function (page = c("webpage", "errata", "taskviews"), script, data, setup) { rstudiocheat <- "https://www.rstudio.com/resources/cheatsheets/" ide.cheat <- "https://www.rstudio.com/wp-content/uploads/2016/01/rstudio-IDE-cheatsheet.pdf" data.page <- "https://socialsciences.mcmaster.ca/jfox/Books/Companion/data/" setup.dir <- "https://socialsciences.mcmaster.ca/jfox/Books/Companion/setup/" files <- c("Duncan.txt", "Duncan.csv", "Duncan.xlsx", "Duncan.Rmd", "Hamlet.txt", "RMarkdownTest.Rmd", "zipmod.R", "zipmodBugged.R", "zipmod-generic.R", paste0("chap-", 1:10, ".R")) script.page <- "https://socialsciences.mcmaster.ca/jfox/Books/Companion/scripts/" ethics <- "http://www.amstat.org/asa/files/pdfs/EthicalGuidelines.pdf" page = match.arg(page) urls = c(webpage = "https://socialsciences.mcmaster.ca/jfox/Books/Companion/", errata = "https://socialsciences.mcmaster.ca/jfox/Books/Companion/errata.html", taskviews = "http://cran.r-project.org/web/views", ethics = ethics) url <- urls[page] if(!missing(data)) { dfile <- unlist(strsplit(data, ".", fixed=TRUE)) if(length(dfile) > 1) dfile <- dfile[1:(length(dfile)-1)] dfile <- paste(c(dfile, "txt"), collapse="." ) url <- paste(data.page, dfile, sep="")} if(!missing(script)) { sfile <- unlist(strsplit(script, ".", fixed=TRUE)) if(length(sfile) > 1) sfile <- sfile[1:(length(sfile)-1)] sfile <- paste(c(sfile, "R"), collapse="." ) url <- paste(script.page, sfile, sep="")} if(!missing(setup) && isTRUE(setup)){ downloaded <- character(0) for(f in files) { if (file.exists(f)){ response <- askYesNo(paste0(f, " exists, replace?"), prompts=c("yes", "no", "cancel"), default=FALSE) if (is.na(response)) { if (length(downloaded) > 0) cat("\nFiles downloaded:", paste(downloaded, collapse=", "), "\n") return(invisible(response)) } } else response <- TRUE if (isTRUE(response)) { download.file(paste(setup.dir, f, sep=""), paste(getwd(), f, sep="/")) downloaded <- c(downloaded, f) } } if (length(downloaded) > 0) cat("\nFiles downloaded:", paste(downloaded, collapse=", "), "\n") return(invisible(NULL)) } browseURL(url) } car/R/adaptiveKernel.R0000644000176000001440000000261314140261763014337 0ustar ripleyusers# 2016-11-25: J. Fox: use pure-R code, removed compiled code. # 2018-08-03: J. Fox: introduce alternative kernel functions adaptiveKernel <- function(x, kernel=dnorm, bw=bw.nrd0, adjust=1.0, n=500, from, to, cut=3, na.rm=TRUE){ varname <- deparse(substitute(x)) if (na.rm) x <- na.omit(x) if (bw.is.fun <- is.function(bw)) bw <- bw(x) if (bw.is.fun && !is.null(scale <- attr(kernel, "scale"))){ bw <- bw/scale } bw <- adjust*bw if (missing(from)) from <- min(x) - cut*bw if (missing(to)) to <- max(x) + cut*bw x0 <- seq(from, to, length=n) n.1 <- length(x) p <- rep(0, n) initialp.x0 <- rep(0, n) fac <- 1/(n.1*bw) for (i in 1:n) initialp.x0[i] <- fac * sum(kernel((x - x0[i])/bw)) initialp <- rep(0, n.1) for (i in 1:n.1) initialp[i] <- initialp.x0[which.min(abs(x[i] - x0))] pbar <- exp((1/n.1)*sum(log(initialp))) f <- (initialp/pbar)^-0.5 for (i in 1:n) p[i] <- fac * sum((1/f)*kernel((x - x0[i])/(f*bw))) result <- list(x=x0, y=p, n=n, bw=bw*adjust, call=match.call(), data.name=varname, has.na=FALSE, initial=list(x=x0, y=initialp.x0)) class(result) <- "density" result } depan <- function(x){ ifelse (abs(x) > 1, 0, 0.75*(1 - x^2)) } attr(depan, "scale") <- sqrt(0.2) dbiwt <- function(x){ ifelse (abs(x) > 1, 0, (15/16)*(1 - x^2)^2) } attr(dbiwt, "scale") <- sqrt(1/7) car/R/marginalModelPlot.R0000644000176000001440000003415214140261763015016 0ustar ripleyusers############################################# # marginal model plots Rev 12/30/09 # 15 March 2010 changed to make # mmps(lm(longley)) work without specifying data or response # fixed bug when only one plot is requested --- suppress call to par() # added 'outerLegend' to label lines # modified to work correctly with # 28 May 2010 S. Weisberg, fixed bugs in logistic models # changed line thickness of mean smooths # excluded SD smooth from bernoulli models # added grid lines # 15 August 2010 fixed colors of points to work properly # 16 January 2011 improved handling of splines and polynomials in mmps to # allow plots against base variables (e.g., bs(x, 3) could be # replaced by just x in the 'terms' argument to mmps. # 16 June 2011 allow layout=NA, in which case the layout is not set in this # function, so it is the responsibility of the user # 14 September 2012 improved the smoothers # 22 September 2012 added conditioning on one categorical regressor # 2017-02-13: consolidated smooth and id arguments. J. Fox # 2017-10-29: Changed line type of smooth of the data to 1 as advertised # 2017-10-29: Changed default color palette from palette() to carPalette() # 2019-05-17: in mmp.glm, default horizontal variable when fitted=TRUE is now the # fitted values for lm and the linear predictor for glm # 2019-05-17: added ylab arg to mmp() methods. J. Fox # 2019-11-14: change class(x) == "y" to inherits(x, "y") ############################################# marginalModelPlot <- function(...){ mmp(...) } mmp <- function(model, ...){ UseMethod("mmp") } mmp.lm <- function (model, variable, sd = FALSE, xlab = deparse(substitute(variable)), smooth=TRUE, key=TRUE, pch, groups=NULL, ...){ smooth <- applyDefaults(smooth, defaults=list(smoother=loessLine, span=2/3), type="smooth") mmp.default(model, variable, sd, xlab, smooth=smooth, key, pch=pch, groups=groups, ...) } mmp.default <- function (model, variable, sd = FALSE, xlab = deparse(substitute(variable)), ylab, smooth=TRUE, key=TRUE, pch, groups=NULL, col.line = carPalette()[c(2, 8)], col=carPalette()[1], id=FALSE, grid=TRUE, ...){ id <- applyDefaults(id, defaults=list(method="y", n=2, cex=1, col=carPalette()[1], location="lr"), type="id") if (isFALSE(id)){ id.n <- 0 id.method <- "none" labels <- id.cex <- id.col <- id.location <- NULL } else{ labels <- id$labels if (is.null(labels)) labels <- names((residuals(model))) id.method <- id$method id.n <- if ("identify" %in% id.method) Inf else id$n id.cex <- id$cex id.col <- id$col id.location <- id$location } smoother.args <- applyDefaults(smooth, defaults=list(smoother=loessLine, span=2/3), type="smooth") if (!isFALSE(smoother.args)) { smoother <- smoother.args$smoother smoother.args$smoother <- NULL } else smoother <- "none" lwd <- match.call(expand.dots=TRUE)$lwd if(missing(pch)) pch <- 1 groups.col <- col if (!is.null(groups)){ if(is.data.frame(groups)) { groups.label <- colnames(groups)[1] groups <- groups[,1] } else { groups.label <- deparse(substitute(groups)) } groups.levels <- unique(na.omit(groups)) for (j in 1:(length(groups.levels))) { pch[groups==groups.levels[j]] <- j groups.col[groups==groups.levels[j]] <- carPalette()[j]} } if (!is.null(attr(model$model, "na.action"))) { if (attr(attr(model$model, "na.action"), "class") == "exclude") model <- update(model, na.action=na.omit)} if (missing(variable)) { xlab <- "Fitted values" u <- fitted(model) } else { u <- variable} resp <- model.response(model.frame(model)) if (missing(ylab)) ylab <- colnames(model$model[1]) plot(u, resp, xlab = xlab, ylab = ylab, type="n", ...) if(grid){ grid(lty=1, equilogs=FALSE) box()} points(u, model$model[ , 1], col=groups.col, pch=pch, ...) if (!(is.character(smoother) && smoother == "none")){ ow <- options(warn=-1) on.exit(options(ow)) smoother.args$lty.spread <- 1 smoother.args$lwd <- smoother.args$lwd.spread <- if(is.null(lwd)) 2 else lwd if(is.null(groups)) { smoother.args$lty.smooth <- 1 smoother(u, resp, col.line[1], log.x=FALSE, log.y=FALSE, spread=sd, smoother.args=smoother.args) smoother.args$lty.smooth <- smoother.args$lty.spread <- 2 # 11/21/14: SD smooth under the model corrected by adding the 'offset' smoother(u, predict(model), col.line[2], log.x=FALSE, log.y=FALSE, spread=sd, smoother.args=smoother.args, offset=sigmaHat(model)) # smoother.args=smoother.args) if(key){ outerLegend(c("Data", "Model"), lty=1:2, col=col.line, bty="n", cex=0.75, fill=col.line, border=col.line, horiz=TRUE, offset=0) } } else { for (j in 1:length(groups.levels)) { smoother.args$lwd <- if(is.null(lwd)) 1.75 else lwd smoother.args$lty.smooth <- 1 sel <- groups == groups.levels[j] smoother(u[sel], resp[sel], carPalette()[j], log.x=FALSE, log.y=FALSE, spread=FALSE, smoother.args=smoother.args) smoother.args$lty.smooth <- 2 smoother(u[sel], predict(model)[sel], carPalette()[j], log.x=FALSE, log.y=FALSE, spread=FALSE, smoother.args=smoother.args) } items <- paste(groups.label, groups.levels, sep= " = ") col.items <- carPalette()[1:length(groups.levels)] lty.items <- 1 if(key) plotArrayLegend(location="top", items=items, col.items=col.items, lty.items=lty.items , lwd.items=2, title="Legend") } } showLabels(u, resp, labels=labels, method=id.method, n=id.n, cex=id.cex, col=id.col, location=id.location) } mmp.glm <- function (model, variable, sd = FALSE, xlab = deparse(substitute(variable)), ylab, smooth=TRUE, key=TRUE, pch, groups=NULL, col.line = carPalette()[c(2, 8)], col=carPalette()[1], id=FALSE, grid=TRUE, ...){ id <- applyDefaults(id, defaults=list(method="y", n=2, cex=1, col=carPalette()[1], location="lr"), type="id") if (isFALSE(id)){ id.n <- 0 id.method <- "none" labels <- id.cex <- id.col <- id.location <- NULL } else{ labels <- id$labels if (is.null(labels)) labels <- names((residuals(model))) id.method <- id$method id.n <- if ("identify" %in% id.method) Inf else id$n id.cex <- id$cex id.col <- id$col id.location <- id$location } smoother.args <- applyDefaults(smooth, defaults=list(smoother=gamLine, k=3), type="smooth") if (!isFALSE(smoother.args)) { smoother <- smoother.args$smoother smoother.args$smoother <- NULL } else smoother <- "none" lwd <- match.call(expand.dots=TRUE)$lwd if(missing(pch)) pch <- 1 groups.col <- col groups.pch <- match.call(expand.dots=TRUE)$pch if(is.null(groups.pch)) groups.pch <- 1 if (!is.null(groups)){ if(is.data.frame(groups)) { groups.label <- colnames(groups)[1] groups <- groups[,1] } else { groups.label <- deparse(substitute(groups)) } groups.levels <- unique(na.omit(groups)) for (j in 1:(length(groups.levels))) { pch[groups==groups.levels[j]] <- j groups.col[groups==groups.levels[j]] <- carPalette()[j]} } if (missing(variable)) { xlab <- "Linear Predictor" u <- predict(update(model, na.action=na.omit), type="link") # u <- fitted(update(model, na.action=na.omit)) #deleted 5/17/2019 } else { u <- variable } response <- model.response(model.frame(model)) fam <- model$family$family lin <- model$family$link pw <- model$prior.weights # relevant only for binomial bernoulli <- FALSE if(fam == "binomial") { if(!any(pw > 1.1)) bernoulli <- TRUE if (is.factor(response)) {response <- as.numeric(response) - 1} if (is.matrix(response)){response <- response[, 1]/pw} } if (missing(ylab)) ylab <- colnames(model$model[1]) plot(u, response, type="n", xlab = xlab, ylab = ylab) if(grid){ grid(lty=1, equilogs=FALSE) box()} points(u, response, col=col, pch=pch, ...) if (!(is.character(smoother) && smoother == "none")){ ow <- options(warn=-1) on.exit(options(ow)) smoother.args$lty.smooth <- 1 smoother.args$family <- fam smoother.args$link <- lin smoother.args$weights <- pw model.fit <- if(fam=="binomial") predict(model, type="response")/pw else predict(model, type="response") if(is.null(groups)) { smoother(u, response, col.line[1], log.x=FALSE, log.y=FALSE, spread=FALSE, smoother.args=smoother.args) smoother.args$lty.smooth <- 2 smoother(u, model.fit, col.line[2], log.x=FALSE, log.y=FALSE, spread=FALSE, smoother.args=smoother.args) if(key){ outerLegend(c("Data", "Model"), lty=1:2, col=col.line, bty="n", cex=0.75, fill=col.line, border=col.line, horiz=TRUE, offset=0) } } else { for (j in 1:length(groups.levels)) { smoother.args$lwd <- if(is.null(lwd)) 1.75 else lwd smoother.args$lty.smooth <- 1 sel <- groups == groups.levels[j] smoother(u[sel], response[sel], carPalette()[j], log.x=FALSE, log.y=FALSE, spread=FALSE, smoother.args=smoother.args) smoother.args$lty.smooth <- 2 smoother(u[sel], model.fit[sel], carPalette()[j], log.x=FALSE, log.y=FALSE, spread=FALSE, smoother.args=smoother.args) } items <- paste(groups.label, groups.levels, sep= " = ") col.items <- carPalette()[1:length(groups.levels)] lty.items <- 1 if(key) plotArrayLegend(location="top", items=items, col.items=col.items, lty.items=lty.items , lwd.items=2, title="Legend") } } showLabels(u, as.numeric(model$model[, 1]), labels=labels, method=id.method, n=id.n, cex=id.cex, col=id.col, location=id.location) } marginalModelPlots <- function(...) mmps(...) mmps <- function(model, terms= ~ ., fitted=TRUE, layout=NULL, ask, main, groups, key=TRUE, ...){ mf <- if(!is.null(terms)) termsToMf(model, terms) else NULL labels2 <- attr(attr(mf$mf.vars, "terms"), "term.labels") order2 <- attr(attr(mf$mf.vars, "terms"), "order") type2 <- rep("good", length(labels2)) if(length(labels2) > 0) { for (j in 1:length(labels2)){ if(order2[j] > 1) type2[j] <- NA #exclude interatctions if(inherits(mf$mf.vars[[labels2[j]]], "factor")) type2[j] <- NA #no factors if(inherits(mf$mf.vars[[labels2[j]]], "matrix")) type2[j] <- "original" } if (any( type2=="original", na.rm=TRUE )){ p1 <- try(predict(model, type="terms"), silent=TRUE) if(inherits(p1, "try-error")) {type2[type2=="original"] <- NA} else warning("Splines and/or polynomials replaced by a fitted linear combination") } } groups <- if (!missing(groups)) { termsToMf(model, as.formula(paste("~",deparse(substitute(groups)))))$mf.vars[, 2, drop=FALSE] } else { if(is.null(mf$mf.groups)) NULL else mf$mf.groups[, 2, drop=FALSE] } # If key=TRUE, determine the coordinates of the key: oma3 <- 1.5 # room for title in the outer margin ALWAYS mar3 <- if (is.null(groups)) 1.5 else .2 + if(is.data.frame(groups)) length(unique(groups[, 1])) else length(unique(groups)) nt <- sum(!is.na(type2)) + fitted if (missing(main)) main <- if (nt == 1) "Marginal Model Plot" else "Marginal Model Plots" if (nt == 0) stop("No plots specified") if (nt > 1 & (is.null(layout) || is.numeric(layout))) { if(is.null(layout)){ layout <- switch(min(nt, 9), c(1, 1), c(1, 2), c(2, 2), c(2, 2), c(3, 2), c(3, 2), c(3, 3), c(3, 3), c(3, 3)) } ask <- if(missing(ask) || is.null(ask)) prod(layout) 1) par(mfrow=layout, ask=ask, no.readonly=TRUE, oma=c(0, 0, oma3 , 0), mar=c(5.1, 4.1, mar3, 2.1)) else par(oma=c(0, 0, oma3 , 0), mar=c(5.1, 4.1, mar3, 2.1)) on.exit(par(op)) legend2 <- function(){ usr <- par("usr") coords <-list(x=usr[1], y=usr[3]) leg <- legend( coords, c("Data", "Model"), lty=1:2, lwd=2, bty="n", cex=0.9, plot=FALSE) coords <- list(x = usr[2] - leg$rect$w, y=usr[4] + leg$rect$h) legend( coords, c("Data", "Model"), lty=1:2, lwd=2, bty="n", xpd=NA, cex=0.9) } if (length(labels2) > 0) { for (j in 1:length(labels2)) { if(!is.na(type2[j])) { horiz <- if(type2[j] == "original"){p1[, labels2[j]]} else { if(type2[j] == "good") mf$mf.vars[ , labels2[j]] else NULL} lab <- labels2[j] mmp(model, horiz, xlab=lab, groups=groups, key=key, ...) if(!is.null(groups)) legend2()} } } if(fitted==TRUE) mmp(model, groups=groups, key=key, ...) if(!is.null(groups)) legend2() mtext(side=3, outer=TRUE, main, line=0.1, cex=1.2) if(any(is.na(type2))) warning("Interactions and/or factors skipped") invisible() } car/R/spreadLevelPlot.R0000644000176000001440000001353214140261763014510 0ustar ripleyusers# spread-level plots (J. Fox) # 16 March 2010 by J. Fox: spreadLevelPlot.lm now deletes observations with negative fitted values # 25 May 2010 by J. Fox: corrected errors due to introduction of grid() # 2015-11-24: added smoother and related args to lm method. John # 2017-02-16: replace rlm() with MASS::rlm(). J. Fox # 2017-10-27: reformat warnings. J. Fox # 2017-11-30: substitute carPalette() for palette(). J. Fox slp <- function(...) spreadLevelPlot(...) spreadLevelPlot <- function(x, ...) { UseMethod("spreadLevelPlot") } spreadLevelPlot.default <- function(x, by, robust.line=TRUE, start=0, xlab="Median", ylab="Hinge-Spread", point.labels=TRUE, las=par("las"), main=paste("Spread-Level Plot for", deparse(substitute(x)), "by", deparse(substitute(by))), col=carPalette()[1], col.lines=carPalette()[2], pch=1, lwd=2, grid=TRUE, ...){ good <- complete.cases(x, by) if (sum(good) != length(x)) { warning("NAs ignored") x <- x[good] by <- by[good] } min.x <- min(x) if (min.x <= -start){ start <- nice(-min.x + 0.05*diff(quantile(x, c(.25, .75))), direction="up") warning(paste("\nStart =", start," added to avoid 0 or negative values.")) } if (start != 0) { xlab <- paste(xlab, "+", signif(start, getOption("digits"))) x <- x + start } values <- unique(as.character(by)) result <- matrix(0, length(values), 4) dimnames(result) <-list(values, c("LowerHinge", "Median", "UpperHinge", "Hinge-Spread")) for (i in seq(along=values)){ five <- fivenum(x[by == values[i]]) result[i, ] <- c(five[2:4], five[4] - five[2]) } medians<-result[ ,2] spreads<-result[ ,4] plot(medians, spreads, type="n", log="xy", main=main, xlab=xlab, ylab=ylab, las=las, pch=pch, col=col, ...) if(grid){ grid(lty=1, equilogs=FALSE) box()} points(medians, spreads, col=col, pch=pch) pos <- ifelse(medians > median(medians), 2, 4) if (point.labels) text(medians, spreads, as.character(values), pos=pos, ...) mod <- if (robust.line) MASS::rlm(log(spreads) ~ log(medians)) else lm(log(spreads) ~ log(medians), ...) ord <- order(medians) first <- ord[1] last <- ord[length(ord)] lines(start + medians[c(first, last)], exp(fitted.values(mod)[c(first, last)]), col=col.lines, lwd=lwd, ...) p <- 1 - (coefficients(mod))[2] names(p) <- NULL result <- list(Statistics=as.data.frame(result[ord,]), PowerTransformation=p) class(result) <- "spreadLevelPlot" result } spreadLevelPlot.lm <- function(x, robust.line=TRUE, xlab="Fitted Values", ylab="Absolute Studentized Residuals", las=par("las"), main=paste("Spread-Level Plot for\n", deparse(substitute(x))), pch=1, col=carPalette()[1], col.lines=carPalette()[2:3], lwd=2, grid=TRUE, id=FALSE, smooth=TRUE, ...){ id <- applyDefaults(id, defaults=list(method=list("x", "y"), n=2, cex=1, col=carPalette()[1], location="lr"), type="id") if (isFALSE(id)){ id.n <- 0 id.method <- "none" labels <- id.cex <- id.col <- id.location <- NULL } else{ labels <- id$labels if (is.null(labels)) labels <- names(na.omit(residuals(x))) id.method <- id$method id.n <- if ("identify" %in% id.method) Inf else id$n id.cex <- id$cex id.col <- id$col id.location <- id$location } smoother.args <- applyDefaults(smooth, defaults=list(smoother=loessLine), type="smooth") if (!isFALSE(smoother.args)) { smoother <- smoother.args$smoother smoother.args$smoother <- NULL } else { smoother <- "none" smoother.args <- list() } resid <- na.omit(abs(rstudent(x))) fitval <- na.omit(fitted.values(x)) non.pos <- fitval <= 0 if (any(non.pos)){ fitval <- fitval[!non.pos] resid <- resid[!non.pos] n.non.pos <- sum(non.pos) warning("\n", n.non.pos, " negative", if(n.non.pos > 1) " fitted values" else " fitted value", " removed") } min <- min(fitval) plot(fitval, resid, log="xy", main=main, xlab=xlab, ylab=ylab, las=las, col=col, pch=pch, type="n", ...) if(grid){ grid(lty=1, equilogs=FALSE) box()} points(fitval, resid, col=col, pch=pch) mod <- if (robust.line) MASS::rlm(log(resid) ~ log(fitval)) else lm(log(resid) ~ log(fitval), ...) first <- which.min(fitval) last <- which.max(fitval) lines((fitval)[c(first, last)], exp(fitted.values(mod)[c(first, last)]), lwd=lwd, lty=2, col=col.lines[1], ...) if (is.null(smoother.args$lwd.smooth)) smoother.args$lwd.smooth <- lwd if (is.null(smoother.args$lty.smooth)) smoother.args$lty.smooth <- 1 if (is.function(smoother)) smoother(fitval, resid, col=col.lines[2], log.x=TRUE, log.y=TRUE, smoother.args=smoother.args) p <- 1 - (coefficients(mod))[2] names(p) <- NULL # point identification, added 11/20/2016 labels <- labels[!non.pos] showLabels(fitval, resid, labels=labels, method=id.method, n=id.n, cex=id.cex, col=id.col, location=id.location) # end addition result <- list(PowerTransformation=p) class(result) <- "spreadLevelPlot" result } spreadLevelPlot.formula <- function (x, data=NULL, subset, na.action, main=paste("Spread-Level Plot for", varnames[response], "by", varnames[-response]), ...) { if (missing(na.action)) na.action <- getOption("na.action") m <- match.call(expand.dots = FALSE) m$formula <- x if (is.matrix(eval(m$data, sys.frame(sys.parent())))) m$data <- as.data.frame(data) m$... <- m$main <- m$x <- NULL m[[1]] <- as.name("model.frame") mf <- eval(m, sys.frame(sys.parent())) response <- attr(attr(mf, "terms"), "response") varnames <- names(mf) if (!response) stop ("no response variable specified") if (length(varnames) > 2) stop("right-hand side of model has more than one variable") x <- mf[[response]] by <- mf[[varnames[-response]]] spreadLevelPlot(x, by, main=main, ...) } print.spreadLevelPlot <- function(x, ...){ if (!is.null(x$Statistics)) print(x$Statistics, ...) cat('\nSuggested power transformation: ', x$PowerTransformation,'\n') invisible(x) } car/R/powerTransformlmer.R0000644000176000001440000000612014140261763015306 0ustar ripleyusers# 2016-07-20: Added support for power transformations in lmerMod objects, S. Weisberg # 2016-05-02: Moved (working) cosde for bncPower family to bcnPower.R # 2017-12-19: Modified estimateTransform to handle gamma \approx 0 gracefully. # 2017-12-19: added error for 'I' terms in formulas # 2020-02-17: replaced match.fun by matchFun in utility-functions.R # 2020-03-10: fixed typos (matachFun rather than matchFun), John. # generic functions in powerTransform.R powerTransform.lmerMod <- function(object, family="bcPower", ...) { if(family=="bcnPower") estimateTransform.bcnPowerlmer(object, ...) else estimateTransform.lmerMod(object, family=family, ...) } ################################################################################# ### estimate transformation methods ################################################################################# # lmerMod estimateTransform.lmerMod <- function(object, family="bcPower", lambda=c(-3, 3), start=NULL, method="L-BFGS-B", ...) { data <- model.frame(object) if(any(unlist(lapply(as.list(data), class)) == "AsIs")) stop( "powerTransform for lmer models don't work with the 'I' function; rewrite your formula" ) y <- (object@resp)$y fam <- matchFun(family) llik <- function(lambda){ data$y.lambda <- fam(y, lambda, jacobian.adjusted=TRUE) m.lambda <- update(object, y.lambda ~ ., data=data) logLik(m.lambda) } if (is.null(start)) start <- 1 res<- optimize(f = function(lambda1) llik(lambda1), lower=lambda[1], upper=lambda[2], maximum=TRUE) # optimize does not give the Hessian, so run optimHess res$hessian <- optimHess(res$maximum, llik, ...) res$invHess <- solve(-res$hessian) res$lambda <- res$maximum res$value <- c(res$objective) roundlam <- res$lambda stderr <- sqrt(diag(res$invHess)) lamL <- roundlam - 1.96 * stderr lamU <- roundlam + 1.96 * stderr for (val in rev(c(1, 0, -1, .5, .33, -.5, -.33, 2, -2))) { sel <- lamL <= val & val <= lamU roundlam[sel] <- val } res$model <- object res$roundlam <- roundlam res$family<-family class(res) <- c("lmerModpowerTransform", "powerTransform") res } ################################################################################# # Test Transformation # in testTransform: 'object' is of class lmerModpowerTransform # 'model' will be the lmerMod object ################################################################################# # lmerMod testTransform.lmerModpowerTransform <- function(object, lambda=1){ fam <- matchFun(object$family) model <- object$model y <- (model@resp)$y local.data <- model.frame(model) local.data$y.lambda <- fam(y, lambda, jacobian.adjusted=TRUE) m.lambda <- update(model, y.lambda ~ ., data=local.data) llik <- logLik(m.lambda) LR <- c(2 * (object$value - llik)) df <- 1 pval <- 1-pchisq(LR, df) out <- data.frame(LRT=LR, df=df, pval=format.pval(pval)) rownames(out) <- c(paste("LR test, lambda = (", paste(round(lambda, 2), collapse=" "), ")", sep="")) out} car/R/invTranPlot.R0000644000176000001440000001356114140261763013665 0ustar ripleyusers# Modified 25 Nov 2009 for point marking # 20 Jan 2010: changed line types. J. Fox # 15 August 2010: fixed colors of points # 18 January 2011; added robust M estimation # 2017-02-13: consolidated id argument. John # 2017-02-16: replace rlm() calls with MASS::rlm() # 2017-11-30: substitute carPalette() for palette(). J. Fox # 2020-02-17: replaced match.fun by matchFun in utility-functions.R invTranPlot <- function(x,...) UseMethod("invTranPlot") invTranPlot.formula <- function(x, data, subset, na.action, id=FALSE, ...) { mf <- call <- match.call() m <- match(c("x", "data", "subset", "na.action"), names(mf), 0L) mf <- mf[c(1L,m)] mf$drop.unused.levels <- TRUE mf[[1L]] <- as.name("model.frame") names(mf)[which(names(mf)=="x")] <- "formula" mf <- eval(mf, parent.frame()) if(dim(mf)[2] != 2) stop("Formula must be of the form y ~ x") id <- applyDefaults(id, defaults=list(method="x", n=2, cex=1, col=carPalette()[1], location="lr"), type="id") if (isFALSE(id)){ id.n <- 0 id.method <- "none" labels <- id.cex <- id.col <- id.location <- NULL } else{ labels <- id$labels if (is.null(labels)) labels <- rownames(mf) id.method <- id$method id.n <- if ("identify" %in% id.method) Inf else id$n id.cex <- id$cex id.col <- id$col id.location <- id$location } vx <- mf[,2] vy <- mf[,1] if( is.null(call$xlab) & is.null(call$ylab)) invTranPlot(vx, vy, xlab=colnames(mf)[2], ylab=colnames(mf)[1], id=list(n=id.n, method=id.method, labels=labels, cex=id.cex, col=id.col, location=id.location), ...) else if(is.null(call$xlab) & !is.null(call$ylab)) invTranPlot(vx, vy, xlab=colnames(mf)[2], id=list(n=id.n, method=id.method, labels=labels, cex=id.cex, col=id.col, location=id.location), ...) else if(!is.null(call$xlab) & is.null(call$ylab)) invTranPlot(vx ,vy ,ylab=colnames(mf)[1], id=list(n=id.n, method=id.method, labels=labels, cex=id.cex, col=id.col, location=id.location), ...) else invTranPlot(vx, vy, id=list(n=id.n, method=id.method, labels=labels, cex=id.cex, col=id.col, location=id.location), ...) } invTranPlot.default<- function(x, y, lambda=c(-1, 0, 1), robust=FALSE, lty.lines=rep(c("solid", "dashed", "dotdash", "longdash", "twodash"), length=1 + length(lambda)), lwd.lines=2, col=carPalette()[1], col.lines=carPalette(), xlab=deparse(substitute(x)), ylab=deparse(substitute(y)), family="bcPower", optimal=TRUE, key="auto", id=FALSE, grid=TRUE, ...){ id <- applyDefaults(id, defaults=list(method="x", n=2, cex=1, col=carPalette()[1], location="lr"), type="id") if (isFALSE(id)){ id.n <- 0 id.method <- "none" labels <- id.cex <- id.col <- id.location <- NULL } else{ labels <- id$labels if (is.null(labels)) labels <- seq(along=x) id.method <- id$method id.n <- if ("identify" %in% id.method) Inf else id$n id.cex <- id$cex id.col <- id$col id.location <- id$location } if (is.factor(x)) stop("Predictor variable may not be a factor") if (is.factor(y)) stop("Response variable may not be a factor") if (optimal){ opt <- invTranEstimate(x, y, family=family, confidence=FALSE, robust=robust) lam <- c(opt$lambda, lambda)} else lam <- lambda fam <- matchFun(family) plot(x, y, xlab=xlab, ylab=ylab, type="n", col=col, ...) if(grid){ grid(lty=1, equilogs=FALSE) box()} points(x, y, col=col, ...) rss <- NULL new <- seq(min(x, na.rm=TRUE), max(x,na.rm=TRUE), length=100) for (j in 1:length(lam)){ m1 <- if(robust) MASS::rlm(y ~ fam(x, lam[j])) else lm(y~fam(x, lam[j])) rss <- c(rss, sum(residuals(m1)^2)) lines(new,predict(m1, data.frame(x=new)), lty=lty.lines[j], col=col.lines[j], lwd=lwd.lines)} showLabels(x, y, labels=labels, method=id.method, n=id.n, cex=id.cex, col=id.col, location = id.location) if (!is.null(key)) { loc <- key if(length(lam) <= 4) { lims <- par("usr")[c(1,4)] llam <- expression(paste(hat(lambda), ":")) text(lims[1],lims[2], llam, xpd=TRUE, pos=3) outerLegend( as.character(round(lam,2)), lwd=lwd.lines, lty=lty.lines, col=col.lines, bty="n", cex=0.85, fill=col.lines, border=col.lines, horiz=TRUE, adjust=FALSE)} else { legend(ifelse(cor(x, y)>0,"bottomright","topright"), legend = c(expression(hat(lambda)),as.character(round(lam,2))), lwd=lwd.lines, lty=c("blank", lty.lines), col=c("#00000000",col.lines), inset=0.02, cex=0.75, fill=c("#00000000",col.lines), border=c("#00000000",col.lines)) }} data.frame(lambda=lam, RSS=rss) } invTranEstimate <- function(x, y, family="bcPower", confidence=0.95, robust=FALSE){ if (is.factor(x)) stop("Predictor variable may not be a factor") if (is.factor(y)) stop("Response variable may not be a factor") if (robust) confidence <- FALSE fam <- matchFun(family) f <- if(robust==FALSE) function(lambda,x,y,family){deviance(lm(y~fam(x,lambda)))} else function(lambda,x,y,family){sum(residuals(MASS::rlm(y ~ fam(x,lambda)))^2)} lhat <- optimize(f = function(lambda) f(lambda, x, y, family), interval=c(-10,10)) if (confidence==FALSE){ return(list(lambda=lhat$minimum)) } else { g <- lm(y~fam(x,lhat$minimum)) n = length(residuals(g)) dev0 <- -n*log(deviance(g)) cutoff <- qchisq(confidence,1)/2 f1 <- function(lam) abs(dev0 + n*log(deviance(lm(y~fam(x,lam)))) -cutoff) lowlim <- optimize(f1, interval=c(-10,lhat$minimum)) hilim <- optimize(f1, interval=c(lhat$minimum,10)) return(list(lambda=lhat$minimum,lowerCI=lowlim$minimum,upperCI=hilim$minimum))} } car/R/powerTransform.R0000644000176000001440000002505714140261763014440 0ustar ripleyusers# 2009-09-16: added ... argument to print.summary.powerTransform. J. Fox # 2015-02-02: added 'gamma' argument to get transformation of (U + gamma) # 2015-08-10: added estimateTransform as a generic function # 2015-08-24: made 'family' an explicit argument to powerTransformation to clairfy man page. # 2017-01-28: bug-fix in yjPower # 2017-05-02: function updates to accomodate bcnPower family. S. Weisberg # 2017-05-19: Changed summary.powerTransform; deleted invalid test; added roundlam to output # 2017-07-17: Added family object in return of estimateTransform.default; changed print function of summary.powerTransform B. Price # 2017-10-25: modified print.powerTransform() and print.summary.powerTransform() # so that singular words are used for 1 parameter (e.g., "is" vs "are"). J. Fox # 2017-12-01: removed plot.powerTransform # 2020-02-17: replaced match.fun by matchFun (in utility-functions.R) for consistency # 2020-04-03: in estimateTransform.lm, changed # model.matrix(mt, mf, contrasts) to model.matrix(mt, mf) to avoid a # warning since R 3.5.0 S. Weisberg ### Power families: basicPower <- function(U,lambda, gamma=NULL) { if(!is.null(gamma)) basicPower(t(t(as.matrix(U) + gamma)), lambda) else{ bp1 <- function(U,lambda){ if(any(U[!is.na(U)] <= 0)) stop("First argument must be strictly positive.") if (abs(lambda) <= 1.e-6) log(U) else (U^lambda) } out <- U out <- if(is.matrix(out) | is.data.frame(out)){ if(is.null(colnames(out))) colnames(out) <- paste("Z", 1:dim(out)[2],sep="") for (j in 1:ncol(out)) {out[, j] <- bp1(out[, j],lambda[j]) colnames(out)[j] <- if(abs(lambda[j]) <= 1.e-6) paste("log(", colnames(out)[j],")", sep="") else paste(colnames(out)[j], round(lambda[j], 2), sep="^")} out} else bp1(out, lambda) out}} bcPower <- function(U, lambda, jacobian.adjusted=FALSE, gamma=NULL) { if(!is.null(gamma)) bcPower(t(t(as.matrix(U) + gamma)), lambda, jacobian.adjusted) else{ bc1 <- function(U, lambda){ if(any(U[!is.na(U)] <= 0)) stop("First argument must be strictly positive.") z <- if (abs(lambda) <= 1.e-6) log(U) else ((U^lambda) - 1)/lambda if (jacobian.adjusted == TRUE) { z * (exp(mean(log(U), na.rm=TRUE)))^(1-lambda)} else z } out <- U out <- if(is.matrix(out) | is.data.frame(out)){ if(is.null(colnames(out))) colnames(out) <- paste("Z", 1:dim(out)[2], sep="") for (j in 1:ncol(out)) {out[, j] <- bc1(out[, j], lambda[j]) } colnames(out) <- paste(colnames(out), round(lambda, 2), sep="^") out} else bc1(out, lambda) out}} yjPower <- function(U, lambda, jacobian.adjusted=FALSE) { yj1 <- function(U, lambda){ nonnegs <- U >= 0 z <- rep(NA, length(U)) z[which(nonnegs)] <- bcPower(U[which(nonnegs)]+1, lambda, jacobian.adjusted=FALSE) z[which(!nonnegs)] <- -bcPower(-U[which(!nonnegs)]+1, 2-lambda, jacobian.adjusted=FALSE) if (jacobian.adjusted == TRUE) z * (exp(mean(log((1 + abs(U))^(2 * nonnegs - 1)), na.rm=TRUE)))^(1 - lambda) else z } out <- U out <- if(is.matrix(out) | is.data.frame(out)){ if(is.null(colnames(out))) colnames(out) <- paste("Z", 1:dim(out)[2], sep="") for (j in 1:ncol(out)) {out[, j] <- yj1(out[, j], lambda[j]) } colnames(out) <- paste(colnames(out), round(lambda, 2), sep="^") out} else yj1(out, lambda) out} powerTransform <- function(object, ...) UseMethod("powerTransform") powerTransform.default <- function(object, family="bcPower", ...) { y <- object if(!inherits(y, "matrix") & !inherits(y, "data.frame")) { y <- matrix(y,ncol=1) colnames(y) <- c(paste(deparse(substitute(object))))} y <- na.omit(y) x <- rep(1, dim(y)[1]) estimateTransform(x, y, NULL, family=family, ...) } powerTransform.lm <- function(object, family="bcPower", ...) { mf <- if(is.null(object$model)) update(object, model=TRUE, method="model.frame")$model else object$model mt <- attr(mf, "terms") y <- model.response(mf, "numeric") w <- as.vector(model.weights(mf)) if (is.null(w)) w <- rep(1, dim(mf)[1]) if (is.empty.model(mt)) { x <- matrix(rep(1,dim(mf)[1]), ncol=1) } else { x <- model.matrix(mt, mf) } estimateTransform(x, y, w, family=family, ...) } powerTransform.formula <- function(object, data, subset, weights, na.action, family="bcPower", ...) { mf <- match.call(expand.dots = FALSE) m <- match(c("object", "data", "subset", "weights", "na.action"), names(mf), 0L) mf <- mf[c(1L, m)] mf$drop.unused.levels <- TRUE mf[[1L]] <- as.name("model.frame") names(mf)[which(names(mf)=="object")] <- "formula" mf <- eval(mf, parent.frame()) mt <- attr(mf, "terms") y <- model.response(mf, "numeric") w <- as.vector(model.weights(mf)) if (is.null(w)) w <- rep(1, dim(mf)[1]) if (is.empty.model(mt)) { x <- matrix(rep(1, dim(mf)[1]), ncol=1) } else { x <- model.matrix(mt, mf) } estimateTransform(x, y, w, family=family, ...) } estimateTransform <- function(X, Y, weights=NULL, family="bcPower", ...) { Y <- as.matrix(Y) switch(family, bcnPower = estimateTransform.bcnPower(X, Y, weights, ...), estimateTransform.default(X, Y, weights, family, ...) ) } # estimateTransform.default is renamed 'estimateTransform estimateTransform.default <- function(X, Y, weights=NULL, family="bcPower", start=NULL, method="L-BFGS-B", ...) { fam <- matchFun(family) Y <- as.matrix(Y) # coerces Y to be a matrix. X <- as.matrix(X) # coerces X to be a matrix. w <- if(is.null(weights)) 1 else sqrt(weights) nc <- dim(Y)[2] nr <- nrow(Y) xqr <- qr(w * X) llik <- function(lambda){ (nr/2)*log(((nr - 1)/nr) * det(var(qr.resid(xqr, w*fam(Y, lambda, j=TRUE, ...))))) } llik1d <- function(lambda,Y){ (nr/2)*log(((nr - 1)/nr) * var(qr.resid(xqr, w*fam(Y, lambda, j=TRUE, ...)))) } if (is.null(start)) { start <- rep(1, nc) for (j in 1:nc){ res<- suppressWarnings(optimize( f = function(lambda) llik1d(lambda,Y[ , j, drop=FALSE]), lower=-3, upper=+3)) start[j] <- res$minimum } } res <- optim(start, llik, hessian=TRUE, method=method, ...) if(res$convergence != 0) warning(paste("Convergence failure: return code =", res$convergence)) res$start<-start res$lambda <- res$par names(res$lambda) <- if (is.null(colnames(Y))) paste("Y", 1:dim(Y)[2], sep="") else colnames(Y) roundlam <- res$lambda stderr <- sqrt(diag(solve(res$hessian))) lamL <- roundlam - 1.96 * stderr lamU <- roundlam + 1.96 * stderr for (val in rev(c(1, 0, -1, .5, .33, -.5, -.33, 2, -2))) { sel <- lamL <= val & val <= lamU roundlam[sel] <- val } res$roundlam <- roundlam res$invHess <- solve(res$hessian) res$llik <- res$value res$par <- NULL res$family<-family res$xqr <- xqr res$y <- Y res$x <- as.matrix(X) res$weights <- weights res$family<-family class(res) <- "powerTransform" res } testTransform <- function(object, lambda) UseMethod("testTransform") testTransform.powerTransform <- function(object, lambda=rep(1, dim(object$y)[2])){ fam <- matchFun(object$family) Y <- cbind(object$y) # coerces Y to be a matrix. nc <- dim(Y)[2] nr <- nrow(Y) lam <- if(length(lambda)==1) rep(lambda, nc) else lambda xqr <- object$xqr w <- if(is.null(object$weights)) 1 else sqrt(object$weights) llik <- function(lambda){ (nr/2) * log(((nr - 1)/nr) * det(var(qr.resid(xqr, w * fam(Y, lam, jacobian.adjusted=TRUE))))) } LR <- 2 * (llik(lambda) - object$value) df <- length(object$lambda) pval <- 1-pchisq(LR, df) out <- data.frame(LRT=LR, df=df, pval=format.pval(pval)) rownames(out) <- c(paste("LR test, lambda = (", paste(round(lam, 2), collapse=" "), ")", sep="")) out} print.powerTransform<-function(x, ...) { lambda <- x$lambda if (length(lambda) > 1) cat("Estimated transformation parameters \n") else cat("Estimated transformation parameter \n") print(x$lambda) invisible(x)} summary.powerTransform<-function(object,...){ one <- 1==length(object$lambda) label <- paste(object$family, (if(one) "Transformation to Normality" else "Transformations to Multinormality"), "\n") lambda<-object$lambda roundlam <- round(object$roundlam, 2) stderr<-sqrt(diag(object$invHess)) df<-length(lambda) # result <- cbind(lambda, roundlam, stderr, lambda - 1.96*stderr, lambda + 1.96*stderr) result <- cbind(lambda, roundlam, lambda - 1.96*stderr, lambda + 1.96*stderr) rownames(result)<-names(object$lambda) # colnames(result)<-c("Est Power", "Rnd Pwr", "Std Err", "Lwr bnd", "Upr Bnd") colnames(result)<-c("Est Power", "Rounded Pwr", "Wald Lwr Bnd", "Wald Upr Bnd") tests <- testTransform(object, 0) tests <- rbind(tests, testTransform(object, 1)) # if ( !(all(object$roundlam==0) | all(object$roundlam==1) | # length(object$roundlam)==1 )) # tests <- rbind(tests, testTransform(object, object$roundlam)) family<-object$family out <- list(label=label, result=result, tests=tests,family=family) class(out) <- "summary.powerTransform" out } print.summary.powerTransform <- function(x, digits=4, ...) { n.trans <- nrow(x$result) cat(x$label) print(round(x$result, digits)) if(!is.null(x$family)){ if(x$family=="bcPower" || x$family=="bcnPower"){ if (n.trans > 1) cat("\nLikelihood ratio test that transformation parameters are equal to 0\n (all log transformations)\n") else cat("\nLikelihood ratio test that transformation parameter is equal to 0\n (log transformation)\n") print(x$tests[1,]) if (n.trans > 1) cat("\nLikelihood ratio test that no transformations are needed\n") else cat("\nLikelihood ratio test that no transformation is needed\n") print(x$tests[2,]) } if(x$family=="yjPower"){ if (n.trans > 1) cat("\n Likelihood ratio test that all transformation parameters are equal to 0\n") else cat("\n Likelihood ratio test that transformation parameter is equal to 0\n") print(x$tests[1,]) } }else{ if (n.trans > 1) cat("\nLikelihood ratio tests about transformation parameters \n") else cat("\nLikelihood ratio test about transformation parameter \n") print(x$tests) } } coef.powerTransform <- function(object, round=FALSE, ...) if(round==TRUE) object$roundlam else object$lambda vcov.powerTransform <- function(object,...) { ans <- object$invHess rownames(ans) <- names(coef(object)) colnames(ans) <- names(coef(object)) ans} car/R/linearHypothesis.R0000644000176000001440000006751214140261763014744 0ustar ripleyusers#--------------------------------------------------------------------------------------- # Revision history: # 2009-01-16: replaced unlist(options("foo")) with getOption("foo") # 2009-09-16: optionally allow models with aliased coefficients. J. Fox # 2009-12-10: modification by A. Zeileis to allow wider range of coef. names. # 2009-12-22: small changes to linearHypothesis.mlm() to handle user-specified # within-subjects designs in Anova() # 2010-05-21: linearHypothesis.default() and .lm() changed so that differences # in df, etc. will be postive. # 2010-06-12: linearHypothesis.mlm() changed to allow observation weights # 2010-06-22: fixed bug in linearHypothesis.lm caused by 2010-05-21 revision # 2010-01-21: added methods for mixed models; added matchCoefs() and methods. J. Fox # 2011-05-03: fixed bug in displaying numbers starting with "-1" or "+1" in printed representation. J. Fox # 2011-06-09: added matchCoefs.mlm(). J. Fox # 2011-11-27: added linearHypothesis.svyglm(). John # 2011-12-27: fixed printing bug in linearHypothesis(). John # 2012-02-28: added F-test to linearHypothesis.mer(). John # 2012-03-07: singular.ok argument added to linearHypothesis.mlm(). J. Fox # 2012-08-20: Fixed p-value bug for chisq test in .mer method. John # 2012-09-17: updated linearHypothesis.mer for pkrtest 0.3-2. John # 2012-11-21: test for NULL rhs to avoid warning in R 2.16.0. John # 2013-01-28: hypotheses can now contain newlines and tabs # 2013-02-14: fixed bug in printing constants of the form 1.x*. John # 2013-06-20: added .merMod() method. John # 2013-06-22: tweaks for lme4. John # 2013-06-22: test argument uniformly uses "Chisq" rather than "chisq". J. Fox # 2013-08-19: removed calls to unexported functions in stats. J. Fox # 2014-08-17: added call to requireNamespace() and :: as needed (doesn't work for pbkrtest). J. Fox # 2014-08-18: fixed bug in linearHypothesis.survreg(). J. Fox # 2014-09-23: added linearHypothesis.rlm. J. Fox # 2014-12-18: check that residual df nonzero in Anova.lm() and Anova.default # and residual SS nonzero in Anova.lm(). John # 2015-01-27: KRmodcomp() and methods now imported from pbkrtest. John # 2015-02-03: Check for NULL df before 0 df in default method. John # 2016-06-29: added "value" and "vcov" attributes to returned object, print vcov when verbose. John # 2017-02-16: replaced KRmodcomp() with pbkrtest::KRmodcomp(). John # 2017-11-07: added complete=FALSE to vcov() calls. John # 2019-06-06: remove vcov.default(), which is no longer needed, suggestion of Pavel Krivitsky. John # 2020-05-27: tweak to linearHypothesis.survreg(). John # 2020-12-21: regularize handling of vcov. arg. Sandy and John # 2020-12-21: new matchCoefs.lmList() method, which covers nlsList objects. John # 2020-12-21: added linearHypothesis.lmList(). John #---------------------------------------------------------------------------------------------------- # vcov.default <- function(object, ...){ # stop(paste("there is no vcov() method for models of class", # paste(class(object), collapse=", "))) # } has.intercept.matrix <- function (model, ...) { "(Intercept)" %in% colnames(model) } makeHypothesis <- function(cnames, hypothesis, rhs = NULL){ parseTerms <- function(terms){ component <- gsub("^[-\\ 0-9\\.]+", "", terms) component <- gsub(" ", "", component, fixed=TRUE) component } stripchars <- function(x) { x <- gsub("\\n", " ", x) x <- gsub("\\t", " ", x) x <- gsub(" ", "", x, fixed = TRUE) x <- gsub("*", "", x, fixed = TRUE) x <- gsub("-", "+-", x, fixed = TRUE) x <- strsplit(x, "+", fixed = TRUE)[[1]] x <- x[x!=""] x } char2num <- function(x) { x[x == ""] <- "1" x[x == "-"] <- "-1" as.numeric(x) } constants <- function(x, y) { with.coef <- unique(unlist(sapply(y, function(z) which(z == parseTerms(x))))) if (length(with.coef) > 0) x <- x[-with.coef] x <- if (is.null(x)) 0 else sum(as.numeric(x)) if (any(is.na(x))) stop('The hypothesis "', hypothesis, '" is not well formed: contains bad coefficient/variable names.') x } coefvector <- function(x, y) { rv <- gsub(" ", "", x, fixed=TRUE) == parseTerms(y) if (!any(rv)) return(0) if (sum(rv) > 1) stop('The hypothesis "', hypothesis, '" is not well formed.') rv <- sum(char2num(unlist(strsplit(y[rv], x, fixed=TRUE)))) if (is.na(rv)) stop('The hypothesis "', hypothesis, '" is not well formed: contains non-numeric coefficients.') rv } if (!is.null(rhs)) rhs <- rep(rhs, length.out = length(hypothesis)) if (length(hypothesis) > 1) return(rbind(Recall(cnames, hypothesis[1], rhs[1]), Recall(cnames, hypothesis[-1], rhs[-1]))) cnames_symb <- sapply(c("@", "#", "~"), function(x) length(grep(x, cnames)) < 1) if(any(cnames_symb)) { cnames_symb <- head(c("@", "#", "~")[cnames_symb], 1) cnames_symb <- paste(cnames_symb, seq_along(cnames), cnames_symb, sep = "") hypothesis_symb <- hypothesis for(i in order(nchar(cnames), decreasing = TRUE)) hypothesis_symb <- gsub(cnames[i], cnames_symb[i], hypothesis_symb, fixed = TRUE) } else { stop('The hypothesis "', hypothesis, '" is not well formed: contains non-standard coefficient names.') } lhs <- strsplit(hypothesis_symb, "=", fixed=TRUE)[[1]] if (is.null(rhs)) { if (length(lhs) < 2) rhs <- "0" else if (length(lhs) == 2) { rhs <- lhs[2] lhs <- lhs[1] } else stop('The hypothesis "', hypothesis, '" is not well formed: contains more than one = sign.') } else { if (length(lhs) < 2) as.character(rhs) else stop('The hypothesis "', hypothesis, '" is not well formed: contains a = sign although rhs was specified.') } lhs <- stripchars(lhs) rhs <- stripchars(rhs) rval <- sapply(cnames_symb, coefvector, y = lhs) - sapply(cnames_symb, coefvector, y = rhs) rval <- c(rval, constants(rhs, cnames_symb) - constants(lhs, cnames_symb)) names(rval) <- c(cnames, "*rhs*") rval } printHypothesis <- function(L, rhs, cnames){ hyp <- rep("", nrow(L)) for (i in 1:nrow(L)){ sel <- L[i,] != 0 h <- L[i, sel] h <- ifelse(h < 0, as.character(h), paste("+", h, sep="")) nms <- cnames[sel] h <- paste(h, nms) h <- gsub("-", " - ", h) h <- gsub("+", " + ", h, fixed=TRUE) h <- paste(h, collapse="") h <- gsub(" ", " ", h, fixed=TRUE) h <- sub("^\\ \\+", "", h) h <- sub("^\\ ", "", h) h <- sub("^-\\ ", "-", h) h <- paste(" ", h, sep="") h <- paste(h, "=", rhs[i]) h <- gsub(" 1([^[:alnum:]_.]+)[ *]*", "", gsub("-1([^[:alnum:]_.]+)[ *]*", "-", gsub("- +1 +", "-1 ", h))) h <- sub("Intercept)", "(Intercept)", h) h <- gsub("-", " - ", h) h <- gsub("+", " + ", h, fixed=TRUE) h <- gsub(" ", " ", h, fixed=TRUE) h <- sub("^ *", "", h) hyp[i] <- h } hyp } linearHypothesis <- function (model, ...) UseMethod("linearHypothesis") lht <- function (model, ...) UseMethod("linearHypothesis") linearHypothesis.lmList <- function(model, ..., vcov.=vcov, coef.=coef){ vcov.List <- function(object, ...) { vlist <- lapply(object, vcov) ng <- length(vlist) nv <- dim(vlist[[1]])[1] v <- matrix(0, nrow=ng*nv, ncol=ng*nv) for (j in 1:ng){ cells <- ((j-1)*nv + 1):(j*nv) v[cells, cells] <- vlist[[j]] } v } suppress.vcov.msg <- missing(vcov.) if (!is.function(vcov.)) stop("vcov. must be a function") if (!is.function(coef.)) stop("coef. must be a function") linearHypothesis.default(model, vcov.=vcov.List(model), coef.=unlist(lapply(model, coef.)), suppress.vcov.msg = suppress.vcov.msg, ...) } linearHypothesis.nlsList <- function(model, ..., vcov.=vcov, coef.=coef){ NextMethod() } linearHypothesis.default <- function(model, hypothesis.matrix, rhs=NULL, test=c("Chisq", "F"), vcov.=NULL, singular.ok=FALSE, verbose=FALSE, coef. = coef(model), suppress.vcov.msg=FALSE, ...){ df <- df.residual(model) if (is.null(df)) df <- Inf ## if no residual df available if (df == 0) stop("residual df = 0") V <- if (is.null(vcov.)) vcov(model, complete=FALSE) else if (is.function(vcov.)) vcov.(model) else vcov. b <- coef. if (any(aliased <- is.na(b)) && !singular.ok) stop("there are aliased coefficients in the model") b <- b[!aliased] if (is.null(b)) stop(paste("there is no coef() method for models of class", paste(class(model), collapse=", "))) if (is.character(hypothesis.matrix)) { L <- makeHypothesis(names(b), hypothesis.matrix, rhs) if (is.null(dim(L))) L <- t(L) rhs <- L[, NCOL(L)] L <- L[, -NCOL(L), drop = FALSE] rownames(L) <- hypothesis.matrix } else { L <- if (is.null(dim(hypothesis.matrix))) t(hypothesis.matrix) else hypothesis.matrix if (is.null(rhs)) rhs <- rep(0, nrow(L)) } q <- NROW(L) value.hyp <- L %*% b - rhs vcov.hyp <- L %*% V %*% t(L) if (verbose){ cat("\nHypothesis matrix:\n") print(L) cat("\nRight-hand-side vector:\n") print(rhs) cat("\nEstimated linear function (hypothesis.matrix %*% coef - rhs)\n") print(drop(value.hyp)) cat("\n") if (length(vcov.hyp) == 1) cat("\nEstimated variance of linear function\n") else cat("\nEstimated variance/covariance matrix for linear function\n") print(drop(vcov.hyp)) cat("\n") } SSH <- as.vector(t(value.hyp) %*% solve(vcov.hyp) %*% value.hyp) test <- match.arg(test) if (!(is.finite(df) && df > 0)) test <- "Chisq" name <- try(formula(model), silent = TRUE) if (inherits(name, "try-error")) name <- substitute(model) title <- "Linear hypothesis test\n\nHypothesis:" topnote <- paste("Model 1: restricted model","\n", "Model 2: ", paste(deparse(name), collapse = "\n"), sep = "") note <- if (is.null(vcov.) || suppress.vcov.msg) "" else "\nNote: Coefficient covariance matrix supplied.\n" rval <- matrix(rep(NA, 8), ncol = 4) colnames(rval) <- c("Res.Df", "Df", test, paste("Pr(>", test, ")", sep = "")) rownames(rval) <- 1:2 rval[,1] <- c(df+q, df) if (test == "F") { f <- SSH/q p <- pf(f, q, df, lower.tail = FALSE) rval[2, 2:4] <- c(q, f, p) } else { p <- pchisq(SSH, q, lower.tail = FALSE) rval[2, 2:4] <- c(q, SSH, p) } if (!(is.finite(df) && df > 0)) rval <- rval[,-1] result <- structure(as.data.frame(rval), heading = c(title, printHypothesis(L, rhs, names(b)), "", topnote, note), class = c("anova", "data.frame")) attr(result, "value") <- value.hyp attr(result, "vcov") <- vcov.hyp result } linearHypothesis.glm <- function(model, ...) linearHypothesis.default(model, ...) linearHypothesis.lm <- function(model, hypothesis.matrix, rhs=NULL, test=c("F", "Chisq"), vcov.=NULL, white.adjust=c(FALSE, TRUE, "hc3", "hc0", "hc1", "hc2", "hc4"), singular.ok=FALSE, ...){ if (df.residual(model) == 0) stop("residual df = 0") if (deviance(model) < sqrt(.Machine$double.eps)) stop("residual sum of squares is 0 (within rounding error)") if (!singular.ok && is.aliased(model)) stop("there are aliased coefficients in the model.") test <- match.arg(test) white.adjust <- as.character(white.adjust) white.adjust <- match.arg(white.adjust) if (white.adjust != "FALSE"){ if (white.adjust == "TRUE") white.adjust <- "hc3" vcov. <- hccm(model, type=white.adjust) } rval <- linearHypothesis.default(model, hypothesis.matrix, rhs = rhs, test = test, vcov. = vcov., singular.ok=singular.ok, ...) if (is.null(vcov.)) { rval2 <- matrix(rep(NA, 4), ncol = 2) colnames(rval2) <- c("RSS", "Sum of Sq") SSH <- rval[2,test] if (test == "F") SSH <- SSH * abs(rval[2, "Df"]) df <- rval[2, "Res.Df"] error.SS <- deviance(model) rval2[,1] <- c(error.SS + SSH * error.SS/df, error.SS) rval2[2,2] <- abs(diff(rval2[,1])) rval2 <- cbind(rval, rval2)[,c(1, 5, 2, 6, 3, 4)] class(rval2) <- c("anova", "data.frame") attr(rval2, "heading") <- attr(rval, "heading") attr(rval2, "value") <- attr(rval, "value") attr(rval2, "vcov") <- attr(rval, "vcov") rval <- rval2 } rval } check.imatrix <- function(X, terms){ # check block orthogonality of within-subjects model matrix XX <- crossprod(X) if (missing(terms)) terms <- attr(X, "assign") for (term in unique(terms)){ subs <- term == terms XX[subs, subs] <- 0 } if (any(abs(XX) > sqrt(.Machine$double.eps))) stop("Terms in the intra-subject model matrix are not orthogonal.") } linearHypothesis.mlm <- function(model, hypothesis.matrix, rhs=NULL, SSPE, V, test, idata, icontrasts=c("contr.sum", "contr.poly"), idesign, iterms, check.imatrix=TRUE, P=NULL, title="", singular.ok=FALSE, verbose=FALSE, ...){ if (missing(test)) test <- c("Pillai", "Wilks", "Hotelling-Lawley", "Roy") test <- match.arg(test, c("Pillai", "Wilks", "Hotelling-Lawley", "Roy"), several.ok=TRUE) df.residual <- df.residual(model) wts <- if (!is.null(model$weights)) model$weights else rep(1,nrow(model.matrix(model))) # V = (X'WX)^{-1} if (missing (V)) V <- solve(wcrossprod(model.matrix(model), w=wts)) B <- coef(model) if (is.character(hypothesis.matrix)) { L <- makeHypothesis(rownames(B), hypothesis.matrix, rhs) if (is.null(dim(L))) L <- t(L) L <- L[, -NCOL(L), drop = FALSE] rownames(L) <- hypothesis.matrix } else { L <- if (is.null(dim(hypothesis.matrix))) t(hypothesis.matrix) else hypothesis.matrix } # SSPE = E'WE if (missing(SSPE)) SSPE <- wcrossprod(residuals(model),w=wts) if (missing(idata)) idata <- NULL if (missing(idesign)) idesign <- NULL if (!is.null(idata)){ for (i in 1:length(idata)){ if (is.null(attr(idata[,i], "contrasts"))){ contrasts(idata[,i]) <- if (is.ordered(idata[,i])) icontrasts[2] else icontrasts[1] } } if (is.null(idesign)) stop("idesign (intra-subject design) missing.") X.design <- model.matrix(idesign, data=idata) if (check.imatrix) check.imatrix(X.design) intercept <- has.intercept(X.design) term.names <- term.names(idesign) if (intercept) term.names <- c("(Intercept)", term.names) which.terms <- match(iterms, term.names) if (any(nas <- is.na(which.terms))){ if (sum(nas) == 1) stop('The term "', iterms[nas],'" is not in the intrasubject design.') else stop("The following terms are not in the intrasubject design: ", paste(iterms[nas], collapse=", "), ".") } select <- apply(outer(which.terms, attr(X.design, "assign") + intercept, "=="), 2, any) P <- X.design[, select, drop=FALSE] } if (!is.null(P)){ rownames(P) <- colnames(B) SSPE <- t(P) %*% SSPE %*% P B <- B %*% P } rank <- sum(eigen(SSPE, only.values=TRUE)$values >= sqrt(.Machine$double.eps)) if (!singular.ok && rank < ncol(SSPE)) stop("The error SSP matrix is apparently of deficient rank = ", rank, " < ", ncol(SSPE)) r <- ncol(B) if (is.null(rhs)) rhs <- matrix(0, nrow(L), r) rownames(rhs) <- rownames(L) colnames(rhs) <- colnames(B) q <- NROW(L) if (verbose){ cat("\nHypothesis matrix:\n") print(L) cat("\nRight-hand-side matrix:\n") print(rhs) cat("\nEstimated linear function (hypothesis.matrix %*% coef - rhs):\n") print(drop(L %*% B - rhs)) cat("\n") } SSPH <- t(L %*% B - rhs) %*% solve(L %*% V %*% t(L)) %*% (L %*% B - rhs) rval <- list(SSPH=SSPH, SSPE=SSPE, df=q, r=r, df.residual=df.residual, P=P, title=title, test=test, singular=rank < ncol(SSPE)) class(rval) <- "linearHypothesis.mlm" rval } #linearHypothesis.mlm <- function(model, hypothesis.matrix, rhs=NULL, SSPE, V, # test, idata, icontrasts=c("contr.sum", "contr.poly"), idesign, iterms, # check.imatrix=TRUE, P=NULL, title="", verbose=FALSE, ...){ # if (missing(test)) test <- c("Pillai", "Wilks", "Hotelling-Lawley", "Roy") # test <- match.arg(test, c("Pillai", "Wilks", "Hotelling-Lawley", "Roy"), # several.ok=TRUE) # df.residual <- df.residual(model) # if (missing (V)) V <- solve(crossprod(model.matrix(model))) # B <- coef(model) # if (is.character(hypothesis.matrix)) { # L <- makeHypothesis(rownames(B), hypothesis.matrix, rhs) # if (is.null(dim(L))) L <- t(L) # L <- L[, -NCOL(L), drop = FALSE] # rownames(L) <- hypothesis.matrix # } # else { # L <- if (is.null(dim(hypothesis.matrix))) t(hypothesis.matrix) # else hypothesis.matrix # } # if (missing(SSPE)) SSPE <- crossprod(residuals(model)) # if (missing(idata)) idata <- NULL # if (missing(idesign)) idesign <- NULL # if (!is.null(idata)){ # for (i in 1:length(idata)){ # if (is.null(attr(idata[,i], "contrasts"))){ # contrasts(idata[,i]) <- if (is.ordered(idata[,i])) icontrasts[2] # else icontrasts[1] # } # } # if (is.null(idesign)) stop("idesign (intra-subject design) missing.") # X.design <- model.matrix(idesign, data=idata) # if (check.imatrix) check.imatrix(X.design) # intercept <- has.intercept(X.design) # term.names <- term.names(idesign) # if (intercept) term.names <- c("(Intercept)", term.names) # which.terms <- match(iterms, term.names) # if (any(nas <- is.na(which.terms))){ # if (sum(nas) == 1) # stop('The term "', iterms[nas],'" is not in the intrasubject design.') # else stop("The following terms are not in the intrasubject design: ", # paste(iterms[nas], collapse=", "), ".") # } # select <- apply(outer(which.terms, attr(X.design, "assign") + intercept, "=="), # 2, any) # P <- X.design[, select, drop=FALSE] # } # if (!is.null(P)){ # rownames(P) <- colnames(B) # SSPE <- t(P) %*% SSPE %*% P # B <- B %*% P # } # rank <- sum(eigen(SSPE, only.values=TRUE)$values >= sqrt(.Machine$double.eps)) # if (rank < ncol(SSPE)) # stop("The error SSP matrix is apparently of deficient rank = ", # rank, " < ", ncol(SSPE)) # r <- ncol(B) # if (is.null(rhs)) rhs <- matrix(0, nrow(L), r) # rownames(rhs) <- rownames(L) # colnames(rhs) <- colnames(B) # q <- NROW(L) # if (verbose){ # cat("\nHypothesis matrix:\n") # print(L) # cat("\nRight-hand-side matrix:\n") # print(rhs) # cat("\nEstimated linear function (hypothesis.matrix %*% coef - rhs):\n") # print(drop(L %*% B - rhs)) # cat("\n") # } # SSPH <- t(L %*% B - rhs) %*% solve(L %*% V %*% t(L)) %*% (L %*% B - rhs) # rval <- list(SSPH=SSPH, SSPE=SSPE, df=q, r=r, df.residual=df.residual, P=P, # title=title, test=test) # class(rval) <- "linearHypothesis.mlm" # rval #} print.linearHypothesis.mlm <- function(x, SSP=TRUE, SSPE=SSP, digits=getOption("digits"), ...){ test <- x$test if (!is.null(x$P) && SSP){ P <- x$P cat("\n Response transformation matrix:\n") attr(P, "assign") <- NULL attr(P, "contrasts") <- NULL print(P, digits=digits) } if (SSP){ cat("\nSum of squares and products for the hypothesis:\n") print(x$SSPH, digits=digits) } if (SSPE){ cat("\nSum of squares and products for error:\n") print(x$SSPE, digits=digits) } if ((!is.null(x$singular)) && x$singular){ warning("the error SSP matrix is singular; multivariate tests are unavailable") return(invisible(x)) } SSPE.qr <- qr(x$SSPE) # the following code is adapted from summary.manova eigs <- Re(eigen(qr.coef(SSPE.qr, x$SSPH), symmetric = FALSE)$values) tests <- matrix(NA, 4, 4) rownames(tests) <- c("Pillai", "Wilks", "Hotelling-Lawley", "Roy") if ("Pillai" %in% test) tests[1, 1:4] <- Pillai(eigs, x$df, x$df.residual) if ("Wilks" %in% test) tests[2, 1:4] <- Wilks(eigs, x$df, x$df.residual) if ("Hotelling-Lawley" %in% test) tests[3, 1:4] <- HL(eigs, x$df, x$df.residual) if ("Roy" %in% test) tests[4, 1:4] <- Roy(eigs, x$df, x$df.residual) tests <- na.omit(tests) ok <- tests[, 2] >= 0 & tests[, 3] > 0 & tests[, 4] > 0 ok <- !is.na(ok) & ok tests <- cbind(x$df, tests, pf(tests[ok, 2], tests[ok, 3], tests[ok, 4], lower.tail = FALSE)) colnames(tests) <- c("Df", "test stat", "approx F", "num Df", "den Df", "Pr(>F)") tests <- structure(as.data.frame(tests), heading = paste("\nMultivariate Test", if (nrow(tests) > 1) "s", ": ", x$title, sep=""), class = c("anova", "data.frame")) print(tests, digits=digits) invisible(x) } linearHypothesis.survreg <- function(model, hypothesis.matrix, rhs=NULL, test=c("Chisq", "F"), vcov., verbose=FALSE, ...){ suppress.vcov.msg <- missing(vcov.) if (missing(vcov.)) { vcov. <- vcov(model, complete=FALSE) b <- coef(model) if (length(b) != nrow(vcov.)){ p <- which(rownames(vcov.) == "Log(scale)") if (length(p) > 0) vcov. <- vcov.[-p, -p] } } linearHypothesis.default(model, hypothesis.matrix, rhs, test, vcov., verbose=verbose, suppress.vcov.msg = suppress.vcov.msg, ...) } linearHypothesis.polr <- function (model, hypothesis.matrix, rhs=NULL, vcov., verbose=FALSE, ...){ suppress.vcov.msg <- missing(vcov.) k <- length(coef(model)) # V <- vcov(model, complete=FALSE)[1:k, 1:k] V <- getVcov(vcov., model, complete=FALSE)[1:k, 1:k] linearHypothesis.default(model, hypothesis.matrix, rhs, vcov.=V, verbose=verbose, suppress.vcov.msg = suppress.vcov.msg, ...) } coef.multinom <- function(object, ...){ # the following local function is copied from nnet:::coef.multinom coef.m <- function (object, ...) { r <- length(object$vcoefnames) if (length(object$lev) == 2L) { coef <- object$wts[1L + (1L:r)] names(coef) <- object$vcoefnames } else { coef <- matrix(object$wts, nrow = object$n[3L], byrow = TRUE)[, 1L + (1L:r), drop = FALSE] if (length(object$lev)) dimnames(coef) <- list(object$lev, object$vcoefnames) if (length(object$lab)) dimnames(coef) <- list(object$lab, object$vcoefnames) coef <- coef[-1L, , drop = FALSE] } coef } b <- coef.m(object, ...) cn <- colnames(b) rn <- rownames(b) b <- as.vector(t(b)) names(b) <- as.vector(outer(cn, rn, function(c, r) paste(r, c, sep=":"))) b } ## functions for mixed models linearHypothesis.merMod <- function(model, hypothesis.matrix, rhs=NULL, vcov.=NULL, test=c("Chisq", "F"), singular.ok=FALSE, verbose=FALSE, ...){ linearHypothesis.mer(model=model, hypothesis.matrix=hypothesis.matrix, vcov.=vcov., test=test, singular.ok=singular.ok, verbose=verbose, ...) } linearHypothesis.mer <- function(model, hypothesis.matrix, rhs=NULL, vcov.=NULL, test=c("Chisq", "F"), singular.ok=FALSE, verbose=FALSE, ...){ test <- match.arg(test) V <- as.matrix(if (is.null(vcov.))vcov(model, complete=FALSE) else if (is.function(vcov.)) vcov.(model) else vcov.) b <- fixef(model) if (any(aliased <- is.na(b)) && !singular.ok) stop("there are aliased coefficients in the model") b <- b[!aliased] if (is.character(hypothesis.matrix)) { L <- makeHypothesis(names(b), hypothesis.matrix, rhs) if (is.null(dim(L))) L <- t(L) rhs <- L[, NCOL(L)] L <- L[, -NCOL(L), drop = FALSE] rownames(L) <- hypothesis.matrix } else { L <- if (is.null(dim(hypothesis.matrix))) t(hypothesis.matrix) else hypothesis.matrix if (is.null(rhs)) rhs <- rep(0, nrow(L)) } q <- NROW(L) if (verbose){ cat("\nHypothesis matrix:\n") print(L) cat("\nRight-hand-side vector:\n") print(rhs) cat("\nEstimated linear function (hypothesis.matrix %*% coef - rhs)\n") print(drop(L %*% b - rhs)) cat("\n") } if (test == "Chisq"){ df <- Inf SSH <- as.vector(t(L %*% b - rhs) %*% solve(L %*% V %*% t(L)) %*% (L %*% b - rhs)) } else { if (!requireNamespace("lme4")) stop("lme4 package is missing") if (!lme4::isREML(model)) stop("F test available only for linear mixed model fit by REML") if (!all(rhs == 0)) warning("rhs of hypothesis ignored, set to 0") res <- pbkrtest::KRmodcomp(model, L)$test df <- res["Ftest", "ddf"] F <- res["Ftest", "stat"] p <- res["Ftest", "p.value"] } name <- try(formula(model), silent = TRUE) if (inherits(name, "try-error")) name <- substitute(model) title <- "Linear hypothesis test\n\nHypothesis:" topnote <- paste("Model 1: restricted model","\n", "Model 2: ", paste(deparse(name), collapse = "\n"), sep = "") note <- if (is.null(vcov.)) "" else "\nNote: Coefficient covariance matrix supplied.\n" rval <- matrix(rep(NA, 8), ncol = 4) if (test == "Chisq"){ colnames(rval) <- c("Res.Df", "Df", "Chisq", paste("Pr(>Chisq)", sep = "")) rownames(rval) <- 1:2 rval[,1] <- c(df+q, df) p <- pchisq(SSH, q, lower.tail = FALSE) rval[2, 2:4] <- c(q, SSH, p) rval <- rval[,-1] } else{ colnames(rval) <- c("Res.Df", "Df", "F", paste("Pr(>F)", sep = "")) rownames(rval) <- 1:2 rval[,1] <- c(df+q, df) rval[2, 2:4] <- c(q, F, p) } structure(as.data.frame(rval), heading = c(title, printHypothesis(L, rhs, names(b)), "", topnote, note), class = c("anova", "data.frame")) } linearHypothesis.lme <- function(model, hypothesis.matrix, rhs=NULL, vcov.=NULL, singular.ok=FALSE, verbose=FALSE, ...){ V <- as.matrix(if (is.null(vcov.))vcov(model, complete=FALSE) else if (is.function(vcov.)) vcov.(model) else vcov.) b <- fixef(model) if (any(aliased <- is.na(b)) && !singular.ok) stop("there are aliased coefficients in the model") b <- b[!aliased] if (is.character(hypothesis.matrix)) { L <- makeHypothesis(names(b), hypothesis.matrix, rhs) if (is.null(dim(L))) L <- t(L) rhs <- L[, NCOL(L)] L <- L[, -NCOL(L), drop = FALSE] rownames(L) <- hypothesis.matrix } else { L <- if (is.null(dim(hypothesis.matrix))) t(hypothesis.matrix) else hypothesis.matrix if (is.null(rhs)) rhs <- rep(0, nrow(L)) } q <- NROW(L) if (verbose){ cat("\nHypothesis matrix:\n") print(L) cat("\nRight-hand-side vector:\n") print(rhs) cat("\nEstimated linear function (hypothesis.matrix %*% coef - rhs)\n") print(drop(L %*% b - rhs)) cat("\n") } df <- Inf SSH <- as.vector(t(L %*% b - rhs) %*% solve(L %*% V %*% t(L)) %*% (L %*% b - rhs)) name <- try(formula(model), silent = TRUE) if (inherits(name, "try-error")) name <- substitute(model) title <- "Linear hypothesis test\n\nHypothesis:" topnote <- paste("Model 1: restricted model","\n", "Model 2: ", paste(deparse(name), collapse = "\n"), sep = "") note <- if (is.null(vcov.)) "" else "\nNote: Coefficient covariance matrix supplied.\n" rval <- matrix(rep(NA, 8), ncol = 4) colnames(rval) <- c("Res.Df", "Df", "Chisq", paste("Pr(>Chisq)", sep = "")) rownames(rval) <- 1:2 rval[,1] <- c(df+q, df) p <- pchisq(SSH, q, lower.tail = FALSE) rval[2, 2:4] <- c(q, SSH, p) rval <- rval[,-1] structure(as.data.frame(rval), heading = c(title, printHypothesis(L, rhs, names(b)), "", topnote, note), class = c("anova", "data.frame")) } ## for svyglm linearHypothesis.svyglm <- function(model, ...) linearHypothesis.default(model, ...) ## for rlm df.residual.rlm <- function(object, ...){ p <- length(coef(object)) wt.method <- object$call$wt.method if (!is.null(wt.method) && wt.method == "case") { sum(object$weights) - p } else length(object$wresid) - p } linearHypothesis.rlm <- function(model, ...) linearHypothesis.default(model, test="F", ...) ## matchCoefs matchCoefs <- function(model, pattern, ...) UseMethod("matchCoefs") matchCoefs.default <- function(model, pattern, coef.=coef, ...){ names <- names(coef.(model)) grep(pattern, names, value=TRUE) } matchCoefs.mer <- function(model, pattern, ...) NextMethod(coef.=fixef) matchCoefs.merMod <- function(model, pattern, ...) NextMethod(coef.=fixef) matchCoefs.lme <- function(model, pattern, ...) NextMethod(coef.=fixef) matchCoefs.mlm <- function(model, pattern, ...){ names <- rownames(coef(model)) grep(pattern, names, value=TRUE) } matchCoefs.lmList <- function(model, pattern, ...){ names <- names(unlist(lapply(model, coef))) grep(pattern, names, value=TRUE) } car/R/Boxplot.R0000644000176000001440000002122114140261763013024 0ustar ripleyusers# checked in 26 December 2009 by J. Fox # 2012-12-12: Fixed Boxplot.default() so that it works properly when g is numeric. J. Fox # 2013-04-10: handles at argument properly, contribution of Steve Ellison. J. Fox # 2013-08-19: removed loading of stats package. J. Fox # 2016-09-30: added list, data.frame, and matrix methods, suggestion of Michael Friendly. J. Fox # 2016-10-01: tweaked data.frame and list methods. J. Fox # 2017-01-11: consolidate id argument # 2017-10-03: add col and cex to id argument Boxplot <- function(y, ...){ arg.list <- list(...) if (!is.null(arg.list$horizontal) && isTRUE(arg.list$horizontal)) stop("Boxplot does not support horizontal=TRUE") UseMethod("Boxplot") } Boxplot.default <- function(y, g, id=TRUE, xlab, ylab, ...){ if (isFALSE(id)) { id.method="none" labels <- NULL id.n <- 0 id.cex <- NULL id.col <- NULL } else{ id <- applyDefaults(id, defaults=list(method="y", n=10, location="lr", cex=1, col=carPalette()[1]), type="id") id.method <- match.arg(id$method, c("y", "identify", "none")) id.n <- id$n id.location <- id$location labels <- if (is.null(id$labels)) seq(along = y) else id$labels id.cex <- id$cex id.col <- id$col } if (missing(ylab)) ylab <- deparse(substitute(y)) pars <- list(...) if (missing(g)) { valid <- complete.cases(y, labels) y <- y[valid] labels <- labels[valid] b <- boxplot(y, ylab = ylab, ...) if (id.method == "none" | id.n == 0) return(invisible(NULL)) else if (id.method == "identify") { res <- identify(rep(1, length(y)), y, labels, cex=id.cex, col=id.col) return(if (length(res) == 0) invisible(NULL) else labels[res]) } else if (length(b$out) > 0) { sel <- y %in% b$out yy <- y[sel] labs <- labels[sel] which.low <- yy < b$stats[1, 1] y.low <- yy[which.low] labs.low <- labs[which.low] if (length(y.low) > id.n) { ord.low <- order(y.low)[1:id.n] y.low <- y.low[ord.low] labs.low <- labs.low[ord.low] } which.high <- yy > b$stats[5, 1] y.high <- yy[which.high] labs.high <- labs[which.high] if (length(y.high) > id.n) { ord.high <- order(y.high, decreasing = TRUE)[1:id.n] y.high <- y.high[ord.high] labs.high <- labs.high[ord.high] } labs <- c(labs.low, labs.high) at <- if(!is.null(pars$at)) pars$at else 1 if (id.location == "lr") text(at, c(y.low, y.high), labs, pos = 2, xpd=TRUE, cex=id.cex, col=id.col) else maptools::pointLabel(c(at, at), c(y.low, y.high, y.low, y.high), c(paste0(" ", labs, " "), rep(" ", length(labs))), xpd=TRUE, col=id.col, cex=id.cex) return(if (length(labs) == 0) invisible(NULL) else labs) } else return(invisible(NULL)) } else { if (missing(xlab)) xlab = deparse(substitute(g)) valid <- complete.cases(y, labels, g) y <- y[valid] labels <- labels[valid] g <- g[valid] b <- boxplot(split(y, g), ylab = ylab, xlab = xlab, ...) levels <- if (is.factor(g)) levels(g) else sort(unique(g)) gg <- as.numeric(g) if (id.method == "none" | id.n == 0) return(invisible(NULL)) else if (id.method == "identify") { res <- identify(gg, y, labels) return(if (length(res) == 0) invisible(NULL) else labels[res]) } else { midx <- mean(par("usr")[1:2]) identified <- character(0) if (length(b$out) > 0) { groups <- unique(b$group) for (group in groups) { grp <- g == levels[group] yy <- y[grp] labs <- labels[grp] sel <- yy %in% b$out[b$group == group] yy <- yy[sel] glabs <- labs[sel] which.low <- yy < b$stats[1, group] y.low <- yy[which.low] labs.low <- glabs[which.low] if (length(y.low) > id.n) { ord.low <- order(y.low)[1:id.n] y.low <- y.low[ord.low] labs.low <- labs.low[ord.low] } which.high <- yy > b$stats[5, group] y.high <- yy[which.high] labs.high <- glabs[which.high] if (length(y.high) > id.n) { ord.high <- order(y.high, decreasing = TRUE)[1:id.n] y.high <- y.high[ord.high] labs.high <- labs.high[ord.high] } pos <- if (group < midx) 4 else 2 at <- if(!is.null(pars$at)) pars$at[group] else group labs <- c(labs.low, labs.high) if (id.location == "lr") text(at, c(y.low, y.high), labs, pos = pos, xpd=TRUE, col=id.col, cex=id.cex) else maptools::pointLabel(c(at, at), c(y.low, y.high, y.low, y.high), c(paste0(" ", labs, " "), rep(" ", length(labs))), xpd=TRUE, col=id.col, cex=id.cex) identified <- c(identified, c(labs.low, labs.high)) } } return(if (length(identified) == 0) invisible(NULL) else identified) } } } Boxplot.formula <- function(formula, data=NULL, subset, na.action=NULL, id=TRUE, xlab, ylab, ...){ # much of this function adapted from graphics:boxplot.formula if (isFALSE(id)) { id.method="none" id.n <- 0 labels <- NULL id.location <- "y" id.col <- NULL id.cex <- NULL } else{ id <- applyDefaults(id, defaults=list(method="y", n=10, location="lr", cex=1, col=carPalette()[1]), type="id") id.method <- match.arg(id$method, c("y", "identify", "none")) id.n <- id$n id.location <- id$location labels <- id$labels id.col <- id$col id.cex <- id$cex } m <- match.call(expand.dots = FALSE) if (is.matrix(eval(m$data, parent.frame()))) m$data <- as.data.frame(data) m$xlab <- m$ylab <- m$id <- m$... <- NULL m$na.action <- na.action m[[1]] <- as.name("model.frame") mf <- eval(m, parent.frame()) mf$"(labels.)" <- if (is.null(labels)) rownames(mf) else labels lab.var <- which(names(mf) == "(labels.)") if (length(formula) == 3){ response <- attr(attr(mf, "terms"), "response") if (missing(ylab)) ylab <- names(mf)[response] if (missing(xlab)) xlab <- names(mf)[-c(response, lab.var)] x <- mf[, -c(response, lab.var)] if (is.data.frame(x)) x <- do.call("interaction", as.list(x)) if (length(xlab) > 1) xlab <- paste(xlab, collapse="*") Boxplot(mf[[response]], x, id=list(method=id.method, labels=mf[[lab.var]], n=id.n, location=id.location, col=id.col, cex=id.cex), xlab=xlab, ylab=ylab, ...) } else if (length(formula) == 2){ if (missing(ylab)) ylab <- names(mf)[-lab.var] Boxplot(mf[, -lab.var], id=list(method=id.method, labels=mf[[lab.var]], n=id.n, location=id.location, col=id.col, cex=id.cex), ylab=ylab, ...) } else stop("improper Boxplot formula") } Boxplot.list <- function(y, xlab="", ylab="", ...){ if (is.null(names(y))) names(y) <- 1:length(y) g <- factor(rep(names(y), sapply(y, length)), levels=names(y)) y <- do.call(c, y) Boxplot(y, g, xlab=xlab, ylab=ylab, ...) } Boxplot.data.frame <- function(y, id=TRUE, ...){ if (isFALSE(id)) { id.method="none" id.n <- 0 labels <- NULL id.location <- "y" id.col <- NULL id.cex <- NULL } else{ id <- applyDefaults(id, defaults=list(method="y", n=10, location="lr", labels=rownames(y), cex=1, col=carPalette()[1]), type="id") id.method <- match.arg(id$method, c("y", "identify", "none")) id.n <- id$n id.location <- id$location labels <- rep(id$labels, ncol(y)) id.col <- id$col id.cex <- id$cex } Boxplot(as.list(y), id=list(method=id.method, n=id.n, location=id.location, labels=labels, cex=id.cex, col=id.col), ...) } Boxplot.matrix <- function(y, ...){ Boxplot(as.data.frame(y), ...) } car/R/sigmaHat.R0000644000176000001440000000064614140261763013142 0ustar ripleyusers#------------------------------------------------------------------------------- # Revision history: # 2010-07-01: moved from alr3 and renamed. S. Weisberg ## method to return sigmaHat sigmaHat <- function(object){UseMethod("sigmaHat")} sigmaHat.default <- function(object){summary(object)$sigma} sigmaHat.lm <- function(object) sigmaHat.default(object) sigmaHat.glm <- function(object){sqrt(summary(object)$dispersion)}car/R/densityPlot.R0000644000176000001440000001420614140261763013720 0ustar ripleyusers# checked in 2013-06-05 by J. Fox # 2014-09-04: J. Fox: empty groups produce warning rather than error # 2016-10-16: J. Fox: add option for adaptive kernel. # 2016-11-26: J. Fox: rejig for pure-R adaptive kernel # 2017-02-12: J. Fox: make adaptive kernel the default, consolidate legend args. # 2017-11-30: substitute carPalette() for palette(). J. Fox densityPlot <- function(x, ...){ UseMethod("densityPlot") } densityPlot.default <- function (x, g, method=c("adaptive", "kernel"), bw=if (method == "adaptive") bw.nrd0 else "SJ", adjust=1, kernel, xlim, ylim, normalize=FALSE, xlab=deparse(substitute(x)), ylab="Density", main="", col=carPalette(), lty=seq_along(col), lwd=2, grid=TRUE, legend=TRUE, show.bw=FALSE, rug=TRUE, ...) { norm <- function(x, y){ n <- length(x) x0 <- diff(range(x))/(n - 1) y0 <- (y[1:(n-1)] + y[2:n])/2 exp(log(y) - log(sum(y0*x0))) } legend <- applyDefaults(legend, defaults=list(location="topright", title=deparse(substitute(g))), type="legend") if (isFALSE(legend)){ legend.title <- "" legend.location <- "topleft" } else{ legend.title <- legend$title legend.location <- legend$location } method <- match.arg(method) if (method == "kernel"){ kernel <- if (missing(kernel)) "gaussian" else match.arg(kernel, c("gaussian", "epanechnikov", "rectangular", "triangular", "biweight", "cosine", "optcosine")) } else{ if(missing(kernel)) kernel <- dnorm if (!is.function(kernel)) stop("for the adaptive kernel estimator, the kernel argument must be a function") } force(ylab) force(xlab) if (!is.numeric(x)) stop("argument x must be numeric") if (missing(g)) { density <- if (method == "adaptive") adaptiveKernel(x, bw=bw, adjust=adjust, ...) else density(x, bw=bw, adjust=adjust, kernel=kernel, ...) if (normalize) density$y <- norm(density$x, density$y) if (missing(xlim)) xlim <- range(density$x) if (missing(ylim)) ylim <- c(0, max(density$y)) if (show.bw) xlab <- paste(xlab, " (bandwidth = ", format(density$bw), ")", sep="") plot(xlim, ylim, xlab=xlab, ylab=ylab, main=main, type="n") if (rug) rug(x) if (grid) grid() lines(density, col=col[1], lwd=lwd, lty=lty[1], xlim=xlim, ylim=ylim) } else { if (!is.factor(g)) stop("argument g must be a factor") counts <- table(g) if (any(counts == 0)){ levels <- levels(g) warning("the following groups are empty: ", paste(levels[counts == 0], collapse=", ")) g <- factor(g, levels=levels[counts != 0]) } valid <- complete.cases(x, g) x <- x[valid] g <- g[valid] levels <- levels(g) if (is.numeric(bw) && length(bw) == 1) bw <- rep(bw, length(levels)) if (length(adjust) == 1) adjust <- rep(adjust, length(levels)) if (is.numeric(bw) && length(bw) != length(levels)) stop("number of entries in bw be 1 or must equal number of groups") if (length(adjust) != length(levels)) stop("number of entries in adjust must be 1 or must equal number of groups") densities <- vector(length(levels), mode="list") names(adjust) <- names(densities) <- levels if (is.numeric(bw)) names(bw) <- levels for (group in levels){ densities[[group]] <- if (method == "adaptive") adaptiveKernel(x[g == group], bw=if (is.numeric(bw)) bw[group] else bw, adjust=adjust[group], ...) else density(x[g == group], bw=if (is.numeric(bw)) bw[group] else bw, adjust=adjust[group], kernel=kernel, ...) if (normalize) densities[[group]]$y <- norm(densities[[group]]$x, densities[[group]]$y) } if (missing(xlim)){ xlim <- range(unlist(lapply(densities, function(den) range(den$x)))) } if (missing(ylim)){ ylim <- c(0, max(sapply(densities, function(den) max(den$y)))) } plot(xlim, ylim, xlab=xlab, ylab=ylab, main=main, type="n") if (grid) grid() for (i in 1:length(levels)){ lines(densities[[i]]$x, densities[[i]]$y, lty=lty[i], col=col[i], lwd=lwd) } if (show.bw){ bws <- sapply(densities, function(den) den$bw) legend.values <- paste(levels, " (bw = ", format(bws), ")", sep="") } else legend.values <- levels if (!isFALSE(legend)) legend(legend.location, legend=legend.values, col=col[1:length(levels)], lty=lty, title=legend.title, inset=0.02) abline(h=0, col="gray") if (rug){ for (i in 1:length(levels)) rug(x[g == levels[i]], col=col[i]) } } return(invisible(if (missing(g)) density else densities)) } densityPlot.formula <- function(formula, data=NULL, subset, na.action=NULL, xlab, ylab, main="", legend=TRUE, ...){ m <- match.call(expand.dots = FALSE) if (is.matrix(eval(m$data, parent.frame()))) m$data <- as.data.frame(data) m$legend <- m$xlab <- m$ylab <-m$main <- m$... <- NULL m$na.action <- na.action m[[1]] <- as.name("model.frame") mf <- eval(m, parent.frame()) if (missing(ylab)) ylab <- "Density" response <- attr(attr(mf, "terms"), "response") if (length(formula) == 3){ legend <- applyDefaults(legend, defaults=list(location="topright", title=names(mf)[-response]), type="legend") if (isFALSE(legend)){ legend.title <- "" legend.location <- "topleft" } else{ legend.title <- legend$title legend.location <- legend$location } if (missing(xlab)) xlab <- names(mf)[response] g <- mf[, -response] densityPlot(mf[[response]], g, xlab=xlab, ylab=ylab, main=main, legend=if (isFALSE(legend)) FALSE else list(title=legend.title, location=legend.location), ...) } else if (length(formula) == 2){ if (missing(xlab)) xlab <- names(mf) densityPlot(mf[[1]], xlab=xlab, ylab=ylab, main=main, ...) } else stop("improper densityPlot formula") } car/R/Contrasts.R0000644000176000001440000000605514140261763013365 0ustar ripleyusers# last modified 2 Dec 2002 by J. Fox # all of these functions are adapted from functions in the R base package contr.Treatment <- function (n, base = 1, contrasts = TRUE) { if (is.numeric(n) && length(n) == 1) levs <- 1:n else { levs <- n n <- length(n) } lev.opt <- getOption("decorate.contrasts") pre <- if (is.null(lev.opt)) "[" else lev.opt[1] suf <- if (is.null(lev.opt)) "]" else lev.opt[2] dec <- getOption("decorate.contr.Treatment") dec <- if (!contrasts) "" else if (is.null(dec)) "T." else dec contr.names <- paste(pre, dec, levs, suf, sep="") contr <- array(0, c(n, n), list(levs, contr.names)) diag(contr) <- 1 if (contrasts) { if (n < 2) stop(paste("Contrasts not defined for", n - 1, "degrees of freedom")) if (base < 1 | base > n) stop("Baseline group number out of range") contr <- contr[, -base, drop = FALSE] } contr } contr.Sum <- function (n, contrasts = TRUE) { if (length(n) <= 1) { if (is.numeric(n) && length(n) == 1 && n > 1) levels <- 1:n else stop("Not enough degrees of freedom to define contrasts") } else levels <- n lenglev <- length(levels) lev.opt <- getOption("decorate.contrasts") pre <- if (is.null(lev.opt)) "[" else lev.opt[1] suf <- if (is.null(lev.opt)) "]" else lev.opt[2] dec <- getOption("decorate.contr.Sum") dec <- if (!contrasts) "" else if (is.null(dec)) "S." else dec show.lev <- getOption("contr.Sum.show.levels") contr.names <- if ((is.null(show.lev)) || show.lev) paste(pre, dec, levels, suf, sep="") if (contrasts) { cont <- array(0, c(lenglev, lenglev - 1), list(levels, contr.names[-lenglev])) cont[col(cont) == row(cont)] <- 1 cont[lenglev, ] <- -1 } else { cont <- array(0, c(lenglev, lenglev), list(levels, contr.names)) cont[col(cont) == row(cont)] <- 1 } cont } contr.Helmert <- function (n, contrasts = TRUE) { if (length(n) <= 1) { if (is.numeric(n) && length(n) == 1 && n > 1) levels <- 1:n else stop("contrasts are not defined for 0 degrees of freedom") } else levels <- n lenglev <- length(levels) lev.opt <- getOption("decorate.contrasts") pre <- if (is.null(lev.opt)) "[" else lev.opt[1] suf <- if (is.null(lev.opt)) "]" else lev.opt[2] dec <- getOption("decorate.contr.Helmert") dec <- if (!contrasts) "" else if (is.null(dec)) "H." else dec nms <- if (contrasts) 1:lenglev else levels contr.names <- paste(pre, dec, nms, suf, sep="") if (contrasts) { cont <- array(-1, c(lenglev, lenglev - 1), list(levels, contr.names[-lenglev])) cont[col(cont) <= row(cont) - 2] <- 0 cont[col(cont) == row(cont) - 1] <- 1:(lenglev - 1) } else { cont <- array(0, c(lenglev, lenglev), list(levels, contr.names)) cont[col(cont) == row(cont)] <- 1 } cont } car/R/influencePlot.R0000644000176000001440000000547714140261763014223 0ustar ripleyusers# changed point marking, 25 November 2009 by S. Weisberg # deleted the cutoff for Cook's D, and the coloring of the circles # inserted default labeling of the id.n largest Cook D. # 13 January 2009: changed to label points by all of hatvalues, # studentized residuals, and Cook's Ds. J. Fox # 14 April 2010: set id.n = 0. J. Fox # 23 April 2010: rewrote point marking, S. Weisberg # 10 May 2010: fixed computation of n # 2014-04-19: use labels for returned table rownames. J. Fox # 2015-11-06: now returns Cook's distance, not its square root. S. Weisberg # 2017-02-12: consolidated id argument. J. Fox # 2017-11-30: substitute carPalette() for palette(). J. Fox # 2019-01-02: added lmerMod method. J. Fox # moved from Rcmdr 5 December 2006 influencePlot <- function(model, ...){ UseMethod("influencePlot") } influencePlot.lm <- function(model, scale=10, xlab="Hat-Values", ylab="Studentized Residuals", id=TRUE, ...){ id <- applyDefaults(id, defaults=list(method="noteworthy", n=2, cex=1, col=carPalette()[1], location="lr"), type="id") if (isFALSE(id)){ id.n <- 0 id.method <- "none" labels <- id.cex <- id.col <- id.location <- NULL } else{ labels <- id$labels if (is.null(labels)) labels <- names(na.omit(residuals(model))) id.method <- id$method id.n <- if ("identify" %in% id.method) Inf else id$n id.cex <- id$cex id.col <- id$col id.location <- id$location } hatval <- hatvalues(model) rstud <- rstudent(model) if (missing(labels)) labels <- names(rstud) cook <- sqrt(cooks.distance(model)) scale <- scale/max(cook, na.rm=TRUE) p <- length(coef(model)) n <- sum(!is.na(rstud)) plot(hatval, rstud, xlab=xlab, ylab=ylab, type='n', ...) abline(v=c(2, 3)*p/n, lty=2) abline(h=c(-2, 0, 2), lty=2) points(hatval, rstud, cex=scale*cook, ...) if(id.method == "noteworthy"){ which.rstud <- order(abs(rstud), decreasing=TRUE)[1:id.n] which.cook <- order(cook, decreasing=TRUE)[1:id.n] which.hatval <- order(hatval, decreasing=TRUE)[1:id.n] which.all <- union(which.rstud, union(which.cook, which.hatval)) id.method <- which.all } noteworthy <- if (!isFALSE(id)) showLabels(hatval, rstud, labels=labels, method=id.method, n=id.n, cex=id.cex, col=id.col, location = id.location) else NULL if (length(noteworthy > 0)){ result <- data.frame(StudRes=rstud[noteworthy], Hat=hatval[noteworthy], CookD=cook[noteworthy]^2) if (is.numeric(noteworthy)) rownames(result) <- labels[noteworthy] return(result) } else return(invisible(NULL)) } influencePlot.lmerMod <- function(model, ...){ influencePlot.lm(model, ...) } car/R/boxCoxVariable.R0000644000176000001440000000057214140261763014313 0ustar ripleyusers#------------------------------------------------------------------------------- # Revision history: # 2009-09-29 by J. Fox (renamed) #------------------------------------------------------------------------------- # constructed variable for Box-Cox transformation (J. Fox) boxCoxVariable <- function(y) { geo.mean <- exp(mean(log(y), na.rm=TRUE)) y*(log(y/geo.mean) - 1) } car/R/some.R0000644000176000001440000000141014140261763012336 0ustar ripleyusers# adapted from head() and tail() # 3/10/2017: S. Weisberg modified to add an argument 'cols' # cols = num will display only the first num cols some <- function(x, ...) UseMethod("some") some.default <- function(x, n=10, ...){ len <- length(x) ans <- x[sort(sample(len, min(n, len)))] if (length(dim(x)) == 1) array(ans, n, list(names(ans))) else ans } some.matrix <- function(x, n=10, cols=NULL, ...){ nr <- nrow(x) nc <- ncol(x) cols <- if(is.null(cols)) 1:nc else cols x[sort(sample(nr, min(n, nr))), cols, drop = FALSE] } some.data.frame <- function(x, n=10, cols=NULL, ...){ nr <- nrow(x) nc <- ncol(x) cols <- if(is.null(cols)) 1:nc else cols x[sort(sample(nr, min(n, nr))), cols, drop=FALSE] } car/R/Anova.R0000644000176000001440000024273514140261763012460 0ustar ripleyusers#------------------------------------------------------------------------------- # Revision history: # 2009-01-05: bug fix in Anova.II.lm(). J. Fox # 2009-01-16: Cox models with clusters now handled. J. Fox # 2009-09-16: reworked glm and lm methods to handle aliased parameters. J. Fox # 2009-09-30: renamed "Anova" to "Analysis of Deviance" in output for some methods. J. Fox # 2009-12-22: modified Anova.mlm() to handle a user-supplied within-subject model matrix. J. Fox # 2009-12-28: named the components of P in Anova.III.mlm(). John # 2010-01-01: Anova.II.mlm() now hands off (again) to Anova.III.mlm() when there # is only an intercept in the between-subjects model # 2010-02-17: Fixed bug that caused some models with aliased coefficients to fail. J. Fox # 2010-06-14: added wcrossprod and allow use of observation weights in Anova.mlm() # 2010-06-28: Fixed Anova() tables for coxph and survreg models # (failed because of changes in survival package. # 2011-01-21: Added functions for mixed models. J. Fox # 2011-01-25: Fixed Anova.polr() and Anova.multinom() to work with models with only one term. J. Fox # 2011-05-19: local fixef() to avoid nlme/lme4 issues. J. Fox # 2011-05-11: changed order of columns in ANOVA tables for mixed models. J. Fox # 2011-11-27: added Anova.svyglm(). J. Fox # 2011-12-31: fixed bug in Anova.II(and III).F.glm() when na.exclude used. J. Fox # 2012-02-28: added test.statistic argument to Anova.mer(). J.Fox # 2012-03-02: fixed test abbreviation of test.statistic argument to Anova.default() # called by other Anova() methods. J. Fox # 2013-06-17: modified summary.Anova.mlm(), introduced print.summary.Anova.mlm(), # adapting code contributed by Gabriel Baud-Bovy. J. Fox # 2013-06-20: added Anova.merMod() method. J. Fox # 2013-06-22: tweaks to local fixef(). J. Fox # 2013-06-22: test argument uniformly uses "Chisq" rather than "chisq". J. Fox # 2013-08-19: replaced calls to print.anova(). J. Fox # 2014-08-17: added calls to requireNamespace() and :: where needed (doesn't work for pbkrtest). J. Fox # 2014-08-18: fixed bugs in Anova.survreg() for types II, III LR tests and Wald tests. J. Fox # 2014-09-23: added Anova.rlm(). J. Fox # 2014-10-10: removed MASS:: from calls to polr(). John # 2014-12-18: check that residual df and SS are nonzero in Anova.lm(). John # 2015-01-27: vcovAdj() and methods now imported from pbkrtest. John # 2015-02-18: force evaluation of vcov. when it's a function. John # 2015-04-30: don't allow error.estimate="dispersion" for F-tests in binomial # and Poission GLMs. John # 2015-08-29: fixed Anova() for coxph models with clusters. John # 2015-09-04: added support for coxme models. John # 2015-09-11: modified Anova.default() to work with vglm objects from VGAM. John # 2015-09-15: fixed Anova.default() so that F-tests work again. John # 2015-11-13: modify Anova.coxph() to take account of method/ties argument. John # 2016-06-03: added SSP and SSPE args to print.summary.Anova.mlm(). John # 2016-06-25: added code to optionally print univariate ANOVAs for a mlm. John # 2017-02-16: replace polr() calls with MASS::polr(), multinom() with nnet::multinom(), # vcovAdj() with pbkrtest::vcovAdj(). John # 2017-03-08: fixed bug in print.summary.Anova.mlm(). John # 2017-11-07: added complete=FALSE to vcov() and vcov.() calls. John # 2017-11-24: small improvements to output. John # 2017-11-29: further fixed to vcov() and vcov.() calls. John # 2018-01-15: Anova.multinom() now works with response matrix. JF # 2018-02-11: If there are aliased coefs in lm object, treat as GLM. JF # 2018-04-04: pass ... arguments through print() methods. Follows comments by Egor Katkov. JF # 2019-10-16: modify Anova.coxph() and Anova.default() for coxph() models with strata (or clusters) # (following problem reported by Susan Galloway Hilsenbeck). JF # 2019-02-17: fix Anova.lme() to work with models without intercepts (to fix bug reported by Benjamin Tyner). JF # 2020-04-01: fix Anova.coxph() to work with weights (to fix bug reported by Daniel Morillo Cuadrado) # 2020-05-27: tweak to handling of Anova.coxph Wald tests. JF # 2020-12-07: Standardize handling of vcov. arg # 2020-12-18: fix Anova.lme() so that it handles missing factor levels. JF # 2020-12-18: make assignVector() generic; add default and svyolr methods; # add unexported svyolr methods for coef() and vcov(); # all this to make Anova() and linearHypothesis() work with svyolr. JF # 2021-04-07: fix Anova.lm() so that SSs are computed when vcov. not specified. JF # 2021-06-12: vcov. arg. now works for mer models. # 2021-06-14: further fixes to vcov. arg for Anova.mer(). JF # introduced vcov. arg to Anova.glm(). JF # 2021-06-16: Fix imatrix arg to Anova.mlm() (contribution of Benedikt Langenberg).JF # 2021-06-19: make sure that calls to anova() for survival::survreg() models return "anova" objects. JF #------------------------------------------------------------------------------- # Type II and III tests for linear, generalized linear, and other models (J. Fox) ConjComp <- function(X, Z = diag( nrow(X)), ip = diag(nrow(X))) { # This function by Georges Monette # finds the conjugate complement of the proj of X in span(Z) wrt # inner product ip # - assumes Z is of full column rank # - projects X conjugately wrt ip into span Z xq <- qr(t(Z) %*% ip %*% X) if (xq$rank == 0) return(Z) Z %*% qr.Q(xq, complete = TRUE) [ ,-(1:xq$rank)] } relatives <- function(term, names, factors){ is.relative <- function(term1, term2) { all(!(factors[,term1]&(!factors[,term2]))) } if(length(names) == 1) return(NULL) which.term <- which(term==names) (1:length(names))[-which.term][sapply(names[-which.term], function(term2) is.relative(term, term2))] } lm2glm <- function(mod){ class(mod) <- c("glm", "lm") wts <- mod$weights mod$prior.weights <- if (is.null(wts)) rep(1, length(mod$residuals)) else wts mod$y <- model.response(model.frame(mod)) mod$linear.predictors <- mod$fitted.values mod$control <- list(epsilon=1e-8, maxit=25, trace=FALSE) mod$family <- gaussian() mod$deviance <- sum(residuals(mod)^2, na.rm=TRUE) mod } Anova <- function(mod, ...){ UseMethod("Anova", mod) } # linear models Anova.lm <- function(mod, error, type=c("II","III", 2, 3), white.adjust=c(FALSE, TRUE, "hc3", "hc0", "hc1", "hc2", "hc4"), vcov.=NULL, singular.ok, ...){ if (!is.null(vcov.)) message("Coefficient covariances computed by ", deparse(substitute(vcov.))) if (!missing(white.adjust)) message("Coefficient covariances computed by hccm()") # vcov. <- getVcov(vcov., mod) if (df.residual(mod) == 0) stop("residual df = 0") if (deviance(mod) < sqrt(.Machine$double.eps)) stop("residual sum of squares is 0 (within rounding error)") type <- as.character(type) white.adjust <- as.character(white.adjust) type <- match.arg(type) white.adjust <- match.arg(white.adjust) if (missing(singular.ok)){ singular.ok <- type == "2" || type == "II" } if (has.intercept(mod) && length(coef(mod)) == 1 && (type == "2" || type == "II")) { type <- "III" warning("the model contains only an intercept: Type III test substituted") } if (any(is.na(coef(mod))) && singular.ok){ if ((white.adjust != "FALSE") || (!is.null(vcov.))) stop("non-standard coefficient covariance matrix\n may not be used for model with aliased coefficients") message("Note: model has aliased coefficients\n sums of squares computed by model comparison") result <- Anova(lm2glm(mod), type=type, singular.ok=TRUE, test.statistic="F", ...) heading <- attributes(result)$heading if (type == "2") type <- "II" if (type == "3") type <- "III" attr(result, "heading") <- c(paste("Anova Table (Type", type, "tests)"), "", heading[2]) return(result) } if (white.adjust != "FALSE"){ if (white.adjust == "TRUE") white.adjust <- "hc3" return(Anova.default(mod, type=type, vcov.=hccm(mod, type=white.adjust), test.statistic="F", singular.ok=singular.ok, ...)) } else if (!is.null(vcov.)) return(Anova.default(mod, type=type, vcov.=vcov., test.statistic="F", singular.ok=singular.ok, ...)) switch(type, II=Anova.II.lm(mod, error, singular.ok=singular.ok, ...), III=Anova.III.lm(mod, error, singular.ok=singular.ok, ...), "2"=Anova.II.lm(mod, error, singular.ok=singular.ok, ...), "3"=Anova.III.lm(mod, error, singular.ok=singular.ok,...)) } Anova.aov <- function(mod, ...){ class(mod) <- "lm" Anova.lm(mod, ...) } Anova.II.lm <- function(mod, error, singular.ok=TRUE, ...){ if (!missing(error)){ sumry <- summary(error, corr=FALSE) s2 <- sumry$sigma^2 error.df <- error$df.residual error.SS <- s2*error.df } SS.term <- function(term){ which.term <- which(term == names) subs.term <- which(assign == which.term) relatives <- relatives(term, names, fac) subs.relatives <- NULL for (relative in relatives) subs.relatives <- c(subs.relatives, which(assign == relative)) hyp.matrix.1 <- I.p[subs.relatives,,drop=FALSE] hyp.matrix.1 <- hyp.matrix.1[, not.aliased, drop=FALSE] hyp.matrix.2 <- I.p[c(subs.relatives,subs.term),,drop=FALSE] hyp.matrix.2 <- hyp.matrix.2[, not.aliased, drop=FALSE] hyp.matrix.term <- if (nrow(hyp.matrix.1) == 0) hyp.matrix.2 else t(ConjComp(t(hyp.matrix.1), t(hyp.matrix.2), vcov(mod, complete=FALSE))) hyp.matrix.term <- hyp.matrix.term[!apply(hyp.matrix.term, 1, function(x) all(x == 0)), , drop=FALSE] if (nrow(hyp.matrix.term) == 0) return(c(SS=NA, df=0)) lh <- linearHypothesis(mod, hyp.matrix.term, singular.ok=singular.ok, ...) abs(c(SS=lh$"Sum of Sq"[2], df=lh$Df[2])) } not.aliased <- !is.na(coef(mod)) if (!singular.ok && !all(not.aliased)) stop("there are aliased coefficients in the model") fac <- attr(terms(mod), "factors") intercept <- has.intercept(mod) I.p <- diag(length(coefficients(mod))) assign <- mod$assign assign[!not.aliased] <- NA names <- term.names(mod) if (intercept) names <-names[-1] n.terms <- length(names) p <- df <- f <- SS <- rep(0, n.terms + 1) sumry <- summary(mod, corr = FALSE) SS[n.terms + 1] <- if (missing(error)) sumry$sigma^2*mod$df.residual else error.SS df[n.terms + 1] <- if (missing(error)) mod$df.residual else error.df p[n.terms + 1] <- f[n.terms + 1] <- NA for (i in 1:n.terms){ ss <- SS.term(names[i]) SS[i] <- ss["SS"] df[i] <- ss["df"] f[i] <- df[n.terms+1]*SS[i]/(df[i]*SS[n.terms + 1]) p[i] <- pf(f[i], df[i], df[n.terms + 1], lower.tail = FALSE) } result <- data.frame(SS, df, f, p) row.names(result) <- c(names,"Residuals") names(result) <- c("Sum Sq", "Df", "F value", "Pr(>F)") class(result) <- c("anova", "data.frame") attr(result, "heading") <- c("Anova Table (Type II tests)\n", paste("Response:", responseName(mod))) result } # type III Anova.III.lm <- function(mod, error, singular.ok=FALSE, ...){ if (!missing(error)){ error.df <- df.residual(error) error.SS <- deviance(error) } else { error.df <- df.residual(mod) error.SS <- deviance(mod) } intercept <- has.intercept(mod) I.p <- diag(length(coefficients(mod))) Source <- term.names(mod) n.terms <- length(Source) p <- df <- f <- SS <- rep(0, n.terms + 1) assign <- mod$assign not.aliased <- !is.na(coef(mod)) if (!singular.ok && !all(not.aliased)) stop("there are aliased coefficients in the model") indices <- 1:n.terms for (term in indices){ subs <- which(assign == term - intercept) hyp.matrix <- I.p[subs,,drop=FALSE] hyp.matrix <- hyp.matrix[, not.aliased, drop=FALSE] hyp.matrix <- hyp.matrix[!apply(hyp.matrix, 1, function(x) all(x == 0)), , drop=FALSE] if (nrow(hyp.matrix) == 0){ SS[term] <- NA df[term] <- 0 f[term] <- NA p[term] <- NA } else { test <- linearHypothesis(mod, hyp.matrix, singular.ok=singular.ok, ...) SS[term] <- test$"Sum of Sq"[2] df[term] <- test$"Df"[2] } } index.error <- n.terms + 1 Source[index.error] <- "Residuals" SS[index.error] <- error.SS df[index.error] <- error.df f[indices] <- (SS[indices]/df[indices])/(error.SS/error.df) p[indices] <- pf(f[indices], df[indices], error.df, lower.tail=FALSE) p[index.error] <- f[index.error] <- NA result <- data.frame(SS, df, f, p) row.names(result) <- Source names(result) <- c("Sum Sq", "Df", "F value", "Pr(>F)") class(result) <- c("anova", "data.frame") attr(result, "heading") <- c("Anova Table (Type III tests)\n", paste("Response:", responseName(mod))) result } # generalized linear models Anova.glm <- function(mod, type=c("II","III", 2, 3), test.statistic=c("LR", "Wald", "F"), error, error.estimate=c("pearson", "dispersion", "deviance"), vcov.=vcov(mod, complete=TRUE), singular.ok, ...){ type <- as.character(type) type <- match.arg(type) test.statistic <- match.arg(test.statistic) error.estimate <- match.arg(error.estimate) if (!missing(vcov.)) { if (test.statistic != "Wald"){ warning(paste0('test.statistic="', test.statistic, '"; vcov. argument ignored')) } else { message("Coefficient covariances computed by ", deparse(substitute(vcov.))) } } vcov. <- getVcov(vcov., mod) if (has.intercept(mod) && length(coef(mod)) == 1 && (type == "2" || type == "II")) { type <- "III" warning("the model contains only an intercept: Type III test substituted") } if (missing(singular.ok)){ singular.ok <- type == "2" || type == "II" } switch(type, II=switch(test.statistic, LR=Anova.II.LR.glm(mod, singular.ok=singular.ok), Wald=Anova.default(mod, type="II", singular.ok=singular.ok, vcov.=vcov.), F=Anova.II.F.glm(mod, error, error.estimate, singular.ok=singular.ok)), III=switch(test.statistic, LR=Anova.III.LR.glm(mod, singular.ok=singular.ok), Wald=Anova.default(mod, type="III", singular.ok=singular.ok, vcov.=vcov.), F=Anova.III.F.glm(mod, error, error.estimate, singular.ok=singular.ok)), "2"=switch(test.statistic, LR=Anova.II.LR.glm(mod, singular.ok=singular.ok), Wald=Anova.default(mod, type="II", singular.ok=singular.ok, vcov.=vcov.), F=Anova.II.F.glm(mod, error, error.estimate, singular.ok=singular.ok)), "3"=switch(test.statistic, LR=Anova.III.LR.glm(mod, singular.ok=singular.ok), Wald=Anova.default(mod, type="III", singular.ok=singular.ok, vcov.=vcov.), F=Anova.III.F.glm(mod, error, error.estimate, singular.ok=singular.ok))) } # type III # LR test Anova.III.LR.glm <- function(mod, singular.ok=FALSE, ...){ if (!singular.ok && any(is.na(coef(mod)))) stop("there are aliased coefficients in the model") Source <- if (has.intercept(mod)) term.names(mod)[-1] else term.names(mod) n.terms <- length(Source) p <- df <- LR <- rep(0, n.terms) dispersion <- summary(mod, corr = FALSE)$dispersion deviance <- deviance(mod)/dispersion for (term in 1:n.terms){ mod.1 <- drop1(mod, scope=eval(parse(text=paste("~",Source[term])))) df[term] <- mod.1$Df[2] LR[term] <- if (df[term] == 0) NA else (mod.1$Deviance[2]/dispersion)-deviance p[term] <- pchisq(LR[term], df[term], lower.tail = FALSE) } result <- data.frame(LR, df, p) row.names(result) <- Source names(result) <- c("LR Chisq", "Df", "Pr(>Chisq)") class(result) <- c("anova","data.frame") attr(result, "heading") <- c("Analysis of Deviance Table (Type III tests)\n", paste("Response:", responseName(mod))) result } # F test Anova.III.F.glm <- function(mod, error, error.estimate, singular.ok=FALSE, ...){ if (!singular.ok && any(is.na(coef(mod)))) stop("there are aliased coefficients in the model") fam <- family(mod)$family if ((fam == "binomial" || fam == "poisson") && error.estimate == "dispersion"){ warning("dispersion parameter estimated from the Pearson residuals, not taken as 1") error.estimate <- "pearson" } if (missing(error)) error <- mod df.res <- df.residual(error) error.SS <- switch(error.estimate, pearson=sum(residuals(error, "pearson")^2, na.rm=TRUE), dispersion=df.res*summary(error, corr = FALSE)$dispersion, deviance=deviance(error)) Source <- if (has.intercept(mod)) term.names(mod)[-1] else term.names(mod) n.terms <- length(Source) p <- df <- f <- SS <-rep(0, n.terms+1) f[n.terms+1] <- p[n.terms+1] <- NA df[n.terms+1] <- df.res SS[n.terms+1] <- error.SS dispersion <- error.SS/df.res deviance <- deviance(mod) for (term in 1:n.terms){ mod.1 <- drop1(mod, scope=eval(parse(text=paste("~",Source[term])))) df[term] <- mod.1$Df[2] SS[term] <- mod.1$Deviance[2] - deviance f[term] <- if (df[term] == 0) NA else (SS[term]/df[term])/dispersion p[term] <- pf(f[term], df[term], df.res, lower.tail = FALSE) } result <- data.frame(SS, df, f, p) row.names(result) <- c(Source, "Residuals") names(result) <- c("Sum Sq", "Df", "F values", "Pr(>F)") class(result) <- c("anova","data.frame") attr(result, "heading") <- c("Analysis of Deviance Table (Type III tests)\n", paste("Response:", responseName(mod)), paste("Error estimate based on", switch(error.estimate, pearson="Pearson residuals", dispersion="estimated dispersion", deviance="deviance"), "\n")) result } # type II # LR test Anova.II.LR.glm <- function(mod, singular.ok=TRUE, ...){ if (!singular.ok && any(is.na(coef(mod)))) stop("there are aliased coefficients in the model") # (some code adapted from drop1.glm) which.nms <- function(name) which(asgn == which(names == name)) fac <- attr(terms(mod), "factors") names <- if (has.intercept(mod)) term.names(mod)[-1] else term.names(mod) n.terms <- length(names) X <- model.matrix(mod) y <- mod$y if (is.null(y)) y <- model.response(model.frame(mod), "numeric") wt <- mod$prior.weights if (is.null(wt)) wt <- rep(1, length(y)) asgn <- attr(X, 'assign') df <- p <- LR <- rep(0, n.terms) dispersion <- summary(mod, corr = FALSE)$dispersion for (term in 1:n.terms){ rels <- names[relatives(names[term], names, fac)] exclude.1 <- as.vector(unlist(sapply(c(names[term], rels), which.nms))) mod.1 <- glm.fit(X[, -exclude.1, drop = FALSE], y, wt, offset = mod$offset, family = mod$family, control = mod$control) dev.1 <- deviance(mod.1) mod.2 <- if (length(rels) == 0) mod else { exclude.2 <- as.vector(unlist(sapply(rels, which.nms))) glm.fit(X[, -exclude.2, drop = FALSE], y, wt, offset = mod$offset, family = mod$family, control = mod$control) } dev.2 <- deviance(mod.2) df[term] <- df.residual(mod.1) - df.residual(mod.2) if (df[term] == 0) LR[term] <- p[term] <- NA else { LR[term] <- (dev.1 - dev.2)/dispersion p[term] <- pchisq(LR[term], df[term], lower.tail=FALSE) } } result <- data.frame(LR, df, p) row.names(result) <- names names(result) <- c("LR Chisq", "Df", "Pr(>Chisq)") class(result) <- c("anova", "data.frame") attr(result, "heading") <- c("Analysis of Deviance Table (Type II tests)\n", paste("Response:", responseName(mod))) result } # F test Anova.II.F.glm <- function(mod, error, error.estimate, singular.ok=TRUE, ...){ # (some code adapted from drop1.glm) if (!singular.ok && any(is.na(coef(mod)))) stop("there are aliased coefficients in the model") fam <- family(mod)$family if ((fam == "binomial" || fam == "poisson") && error.estimate == "dispersion"){ warning("dispersion parameter estimated from the Pearson residuals, not taken as 1") error.estimate <- "pearson" } which.nms <- function(name) which(asgn == which(names == name)) if (missing(error)) error <- mod df.res <- df.residual(error) error.SS <- switch(error.estimate, pearson = sum(residuals(error, "pearson")^2, na.rm=TRUE), dispersion = df.res*summary(error, corr = FALSE)$dispersion, deviance = deviance(error)) fac <- attr(terms(mod), "factors") names <- if (has.intercept(mod)) term.names(mod)[-1] else term.names(mod) n.terms <- length(names) X <- model.matrix(mod) y <- mod$y if (is.null(y)) y <- model.response(model.frame(mod), "numeric") wt <- mod$prior.weights if (is.null(wt)) wt <- rep(1, length(y)) asgn <- attr(X, 'assign') p <- df <- f <- SS <- rep(0, n.terms+1) f[n.terms+1] <- p[n.terms+1] <- NA df[n.terms+1] <- df.res SS[n.terms+1] <- error.SS dispersion <- error.SS/df.res for (term in 1:n.terms){ rels <- names[relatives(names[term], names, fac)] exclude.1 <- as.vector(unlist(sapply(c(names[term], rels), which.nms))) mod.1 <- glm.fit(X[, -exclude.1, drop = FALSE], y, wt, offset = mod$offset, family = mod$family, control = mod$control) dev.1 <- deviance(mod.1) mod.2 <- if (length(rels) == 0) mod else { exclude.2 <- as.vector(unlist(sapply(rels, which.nms))) glm.fit(X[, -exclude.2, drop = FALSE], y, wt, offset = mod$offset, family = mod$family, control = mod$control) } dev.2 <- deviance(mod.2) df[term] <- df.residual(mod.1) - df.residual(mod.2) if (df[term] == 0) SS[term] <- f[term] <- p[term] <- NA else { SS[term] <- dev.1 - dev.2 f[term] <- SS[term]/(dispersion*df[term]) p[term] <- pf(f[term], df[term], df.res, lower.tail=FALSE) } } result <- data.frame(SS, df, f, p) row.names(result) <- c(names, "Residuals") names(result) <- c("Sum Sq", "Df", "F value", "Pr(>F)") class(result) <- c("anova", "data.frame") attr(result, "heading") <- c("Analysis of Deviance Table (Type II tests)\n", paste("Response:", responseName(mod)), paste("Error estimate based on", switch(error.estimate, pearson="Pearson residuals", dispersion="estimated dispersion", deviance="deviance"), "\n")) result } # multinomial logit models (via multinom in the nnet package) Anova.multinom <- function (mod, type = c("II", "III", 2, 3), ...) { type <- as.character(type) type <- match.arg(type) if (has.intercept(mod) && length(coef(mod)) == 1 && (type == "2" || type == "II")) { type <- "III" warning("the model contains only an intercept: Type III test substituted") } switch(type, II = Anova.II.multinom(mod, ...), III = Anova.III.multinom(mod, ...), "2" = Anova.II.multinom(mod, ...), "3" = Anova.III.multinom(mod, ...)) } Anova.II.multinom <- function (mod, ...) { which.nms <- function(name) which(asgn == which(names == name)) fac <- attr(terms(mod), "factors") names <- if (has.intercept(mod)) term.names(mod)[-1] else term.names(mod) n.terms <- length(names) X <- model.matrix(mod) y <- model.response(model.frame(mod)) wt <- if (is.matrix(y)) rep(1, nrow(y)) else mod$weights asgn <- attr(X, "assign") p <- LR <- rep(0, n.terms) df <- df.terms(mod) for (term in 1:n.terms) { rels <- names[relatives(names[term], names, fac)] exclude.1 <- as.vector(unlist(sapply(c(names[term], rels), which.nms))) mod.1 <-if (n.terms > 1) nnet::multinom(y ~ X[, -c(1, exclude.1)], weights=wt, trace=FALSE) else nnet::multinom(y ~ 1, weights=wt, race=FALSE) dev.1 <- deviance(mod.1) mod.2 <- if (length(rels) == 0) mod else { exclude.2 <- as.vector(unlist(sapply(rels, which.nms))) nnet::multinom(y ~ X[, -c(1, exclude.2)], weights=wt, trace=FALSE) } dev.2 <- deviance(mod.2) LR[term] <- dev.1 - dev.2 p[term] <- pchisq(LR[term], df[term], lower.tail=FALSE) } result <- data.frame(LR, df, p) row.names(result) <- names names(result) <- c("LR Chisq", "Df", "Pr(>Chisq)") class(result) <- c("anova", "data.frame") attr(result, "heading") <- c("Analysis of Deviance Table (Type II tests)\n", paste("Response:", responseName(mod))) result } Anova.III.multinom <- function (mod, ...) { names <- if (has.intercept(mod)) term.names(mod)[-1] else term.names(mod) n.terms <- length(names) X <- model.matrix(mod) y <- model.response(model.frame(mod)) wt <- if (is.matrix(y)) rep(1, nrow(y)) else mod$weights asgn <- attr(X, "assign") p <- LR <- rep(0, n.terms) df <- df.terms(mod) deviance <- deviance(mod) for (term in 1:n.terms) { mod.1 <- if (n.terms > 1) nnet::multinom(y ~ X[, term != asgn][, -1], weights=wt, trace=FALSE) else nnet::multinom(y ~ 1, weights=wt, trace=FALSE) LR[term] <- deviance(mod.1) - deviance p[term] <- pchisq(LR[term], df[term], lower.tail=FALSE) } result <- data.frame(LR, df, p) row.names(result) <- names names(result) <- c("LR Chisq", "Df", "Pr(>Chisq)") class(result) <- c("anova", "data.frame") attr(result, "heading") <- c("Analysis of Deviance Table (Type III tests)\n", paste("Response:", responseName(mod))) result } # proportional-odds logit models (via polr in the MASS package) Anova.polr <- function (mod, type = c("II", "III", 2, 3), ...) { type <- as.character(type) type <- match.arg(type) if (has.intercept(mod) && length(coef(mod)) == 1 && (type == "2" || type == "II")) { type <- "III" warning("the model contains only an intercept: Type III test substituted") } switch(type, II = Anova.II.polr(mod, ...), III = Anova.III.polr(mod, ...), "2" = Anova.II.polr(mod, ...), "3" = Anova.III.polr(mod, ...)) } Anova.II.polr <- function (mod, ...) { if (!requireNamespace("MASS")) stop("MASS package is missing") which.nms <- function(name) which(asgn == which(names == name)) fac <- attr(terms(mod), "factors") names <- term.names(mod) n.terms <- length(names) X <- model.matrix(mod) y <- model.response(model.frame(mod)) wt <- model.weights(model.frame(mod)) asgn <- attr(X, "assign") p <- LR <- rep(0, n.terms) df <- df.terms(mod) for (term in 1:n.terms) { rels <- names[relatives(names[term], names, fac)] exclude.1 <- as.vector(unlist(sapply(c(names[term], rels), which.nms))) mod.1 <- if (n.terms > 1) MASS::polr(y ~ X[, -c(1, exclude.1)], weights=wt) else MASS::polr(y ~ 1, weights=wt) dev.1 <- deviance(mod.1) mod.2 <- if (length(rels) == 0) mod else { exclude.2 <- as.vector(unlist(sapply(rels, which.nms))) MASS::polr(y ~ X[, -c(1, exclude.2)], weights=wt) } dev.2 <- deviance(mod.2) LR[term] <- dev.1 - dev.2 p[term] <- pchisq(LR[term], df[term], lower.tail=FALSE) } result <- data.frame(LR, df, p) row.names(result) <- names names(result) <- c("LR Chisq", "Df", "Pr(>Chisq)") class(result) <- c("anova", "data.frame") attr(result, "heading") <- c("Analysis of Deviance Table (Type II tests)\n", paste("Response:", responseName(mod))) result } Anova.III.polr <- function (mod, ...) { if (!requireNamespace("MASS")) stop("MASS package is missing") names <- term.names(mod) n.terms <- length(names) X <- model.matrix(mod) y <- model.response(model.frame(mod)) wt <- model.weights(model.frame(mod)) asgn <- attr(X, "assign") p <- LR <- rep(0, n.terms) df <- df.terms(mod) deviance <- deviance(mod) for (term in 1:n.terms) { mod.1 <- if (n.terms > 1) MASS::polr(y ~ X[, term != asgn][, -1], weights=wt) else MASS::polr(y ~ 1, weights=wt) LR[term] <- deviance(mod.1) - deviance p[term] <- pchisq(LR[term], df[term], lower.tail=FALSE) } result <- data.frame(LR, df, p) row.names(result) <- names names(result) <- c("LR Chisq", "Df", "Pr(>Chisq)") class(result) <- c("anova", "data.frame") attr(result, "heading") <- c("Analysis of Deviance Table (Type III tests)\n", paste("Response:", responseName(mod))) result } # multivariate linear models # the following 3 functions copied from the stats package (not exported from stats) Pillai <- function (eig, q, df.res) { test <- sum(eig/(1 + eig)) p <- length(eig) s <- min(p, q) n <- 0.5 * (df.res - p - 1) m <- 0.5 * (abs(p - q) - 1) tmp1 <- 2 * m + s + 1 tmp2 <- 2 * n + s + 1 c(test, (tmp2/tmp1 * test)/(s - test), s * tmp1, s * tmp2) } Wilks <- function (eig, q, df.res) { test <- prod(1/(1 + eig)) p <- length(eig) tmp1 <- df.res - 0.5 * (p - q + 1) tmp2 <- (p * q - 2)/4 tmp3 <- p^2 + q^2 - 5 tmp3 <- if (tmp3 > 0) sqrt(((p * q)^2 - 4)/tmp3) else 1 c(test, ((test^(-1/tmp3) - 1) * (tmp1 * tmp3 - 2 * tmp2))/p/q, p * q, tmp1 * tmp3 - 2 * tmp2) } HL <- function (eig, q, df.res) { test <- sum(eig) p <- length(eig) m <- 0.5 * (abs(p - q) - 1) n <- 0.5 * (df.res - p - 1) s <- min(p, q) tmp1 <- 2 * m + s + 1 tmp2 <- 2 * (s * n + 1) c(test, (tmp2 * test)/s/s/tmp1, s * tmp1, tmp2) } Roy <- function (eig, q, df.res) { p <- length(eig) test <- max(eig) tmp1 <- max(p, q) tmp2 <- df.res - tmp1 + q c(test, (tmp2 * test)/tmp1, tmp1, tmp2) } has.intercept.mlm <- function (model, ...) any(row.names(coefficients(model)) == "(Intercept)") Anova.mlm <- function(mod, type=c("II","III", 2, 3), SSPE, error.df, idata, idesign, icontrasts=c("contr.sum", "contr.poly"), imatrix, test.statistic=c("Pillai", "Wilks", "Hotelling-Lawley", "Roy"),...){ wts <- if (!is.null(mod$weights)) mod$weights else rep(1, nrow(model.matrix(mod))) type <- as.character(type) type <- match.arg(type) test.statistic <- match.arg(test.statistic) if (missing(SSPE)) SSPE <- wcrossprod(residuals(mod), w=wts) if (missing(idata)) { idata <- NULL idesign <- NULL } if (missing(imatrix)) imatrix <- NULL error.df <- if (missing(error.df)) df.residual(mod) else error.df switch(type, II=Anova.II.mlm(mod, SSPE, error.df, idata, idesign, icontrasts, imatrix, test.statistic, ...), III=Anova.III.mlm(mod, SSPE, error.df, idata, idesign, icontrasts, imatrix, test.statistic, ...), "2"=Anova.II.mlm(mod, SSPE, error.df, idata, idesign, icontrasts, imatrix, test.statistic, ...), "3"=Anova.III.mlm(mod, SSPE, error.df, idata, idesign, icontrasts, imatrix, test.statistic, ...)) } Anova.III.mlm <- function(mod, SSPE, error.df, idata, idesign, icontrasts, imatrix, test, ...){ intercept <- has.intercept(mod) V <- solve(crossprod(model.matrix(mod))) p <- nrow(coefficients(mod)) I.p <- diag(p) terms <- term.names(mod) n.terms <- length(terms) assign <- mod$assign if (is.null(idata) && is.null(imatrix)){ if ((n.terms == 0) && intercept) { Test <- linearHypothesis(mod, 1, SSPE=SSPE, ...) result <- list(SSP=Test$SSPH, SSPE=SSPE, df=1, error.df=error.df, terms="(Intercept)", repeated=FALSE, type="III", test=test) class(result) <- "Anova.mlm" return(result) } SSP <- as.list(rep(0, n.terms)) df <- rep(0, n.terms) names(df) <- names(SSP) <- terms for (term in 1:n.terms){ subs <- which(assign == term - intercept) hyp.matrix <- I.p[subs,,drop=FALSE] Test <- linearHypothesis(mod, hyp.matrix, SSPE=SSPE, ...) SSP[[term]] <- Test$SSPH df[term]<- length(subs) } result <- list(SSP=SSP, SSPE=SSPE, df=df, error.df=error.df, terms=terms, repeated=FALSE, type="III", test=test) } else { if (!is.null(imatrix)){ X.design <- do.call(cbind, imatrix) ncols <- sapply(imatrix, ncol) end <- cumsum(ncols) start <- c(1, (end + 1))[-(length(end) + 1)] cols <- mapply(seq, from=start, to=end) iterms <- names(end) names(cols) <- iterms itrms <- unlist(sapply(1:length(imatrix), function(x) replicate(ncol(imatrix[[x]]), x-1))) check.imatrix(X.design, itrms) } else { if (is.null(idesign)) stop("idesign (intra-subject design) missing.") for (i in 1:length(idata)){ if (is.null(attr(idata[,i], "contrasts"))){ contrasts(idata[,i]) <- if (is.ordered(idata[,i])) icontrasts[2] else icontrasts[1] } } X.design <- model.matrix(idesign, data=idata) i.intercept <- has.intercept(X.design) iterms <- term.names(idesign) if (i.intercept) iterms <- c("(Intercept)", iterms) check.imatrix(X.design) } df <- rep(0, n.terms*length(iterms)) hnames <- rep("", length(df)) P <- SSPEH <- SSP <- as.list(df) i <- 0 for (iterm in iterms){ for (term in 1:n.terms){ subs <- which(assign == term - intercept) hyp.matrix <- I.p[subs,,drop=FALSE] i <- i + 1 Test <- linearHypothesis(mod, hyp.matrix, SSPE=SSPE, idata=idata, idesign=idesign, icontrasts=icontrasts, iterms=iterm, check.imatrix=FALSE, P=imatrix[[iterm]], singular.ok=TRUE, ...) SSP[[i]] <- Test$SSPH SSPEH[[i]] <- Test$SSPE P[[i]] <- Test$P df[i] <- length(subs) hnames[i] <- if (iterm == "(Intercept)") terms[term] else if (terms[term] == "(Intercept)") iterm else paste(terms[term], ":", iterm, sep="") } } names(df) <- names(SSP) <- names(SSPEH) <- names(P) <- hnames result <- list(SSP=SSP, SSPE=SSPEH, P=P, df=df, error.df=error.df, terms=hnames, repeated=TRUE, type="III", test=test, idata=idata, idesign=idesign, icontrasts=icontrasts, imatrix=imatrix, singular=Test$singular) } class(result) <- "Anova.mlm" result } Anova.II.mlm <- function(mod, SSPE, error.df, idata, idesign, icontrasts, imatrix, test, ...){ wts <- if (!is.null(mod$weights)) mod$weights else rep(1, nrow(model.matrix(mod))) V <- solve(wcrossprod(model.matrix(mod), w=wts)) SSP.term <- function(term, iterm){ which.term <- which(term == terms) subs.term <- which(assign == which.term) relatives <- relatives(term, terms, fac) subs.relatives <- NULL for (relative in relatives) subs.relatives <- c(subs.relatives, which(assign==relative)) hyp.matrix.1 <- I.p[subs.relatives,,drop=FALSE] hyp.matrix.2 <- I.p[c(subs.relatives, subs.term),,drop=FALSE] if (missing(iterm)){ SSP1 <- if (length(subs.relatives) == 0) 0 else linearHypothesis(mod, hyp.matrix.1, SSPE=SSPE, V=V, singular.ok=TRUE, ...)$SSPH SSP2 <- linearHypothesis(mod, hyp.matrix.2, SSPE=SSPE, V=V, singular.ok=TRUE, ...)$SSPH return(SSP2 - SSP1) } else { SSP1 <- if (length(subs.relatives) == 0) 0 else linearHypothesis(mod, hyp.matrix.1, SSPE=SSPE, V=V, idata=idata, idesign=idesign, iterms=iterm, icontrasts=icontrasts, P=imatrix[[iterm]], singular.ok=TRUE, ...)$SSPH lh2 <- linearHypothesis(mod, hyp.matrix.2, SSPE=SSPE, V=V, idata=idata, idesign=idesign, iterms=iterm, icontrasts=icontrasts, P=imatrix[[iterm]], singular.ok=TRUE, ...) return(list(SSP = lh2$SSPH - SSP1, SSPE=lh2$SSPE, P=lh2$P, singular=lh2$singular)) } } fac <- attr(terms(mod), "factors") intercept <- has.intercept(mod) p <- nrow(coefficients(mod)) I.p <- diag(p) assign <- mod$assign terms <- term.names(mod) if (intercept) terms <- terms[-1] n.terms <- length(terms) if (n.terms == 0){ message("Note: model has only an intercept; equivalent type-III tests substituted.") return(Anova.III.mlm(mod, SSPE, error.df, idata, idesign, icontrasts, imatrix, test, ...)) } if (is.null(idata) && is.null(imatrix)){ SSP <- as.list(rep(0, n.terms)) df <- rep(0, n.terms) names(df) <- names(SSP) <- terms for (i in 1:n.terms){ SSP[[i]] <- SSP.term(terms[i]) df[i]<- df.terms(mod, terms[i]) } result <- list(SSP=SSP, SSPE=SSPE, df=df, error.df=error.df, terms=terms, repeated=FALSE, type="II", test=test) } else { if (!is.null(imatrix)){ X.design <- do.call(cbind, imatrix) ncols <- sapply(imatrix, ncol) end <- cumsum(ncols) start <- c(1, (end + 1))[-(length(end) + 1)] cols <- mapply(seq, from=start, to=end) iterms <- names(end) names(cols) <- iterms itrms <- unlist(sapply(1:length(imatrix), function(x) replicate(ncol(imatrix[[x]]), x-1))) check.imatrix(X.design, itrms) } else { if (is.null(idesign)) stop("idesign (intra-subject design) missing.") for (i in 1:length(idata)){ if (is.null(attr(idata[,i], "contrasts"))){ contrasts(idata[,i]) <- if (is.ordered(idata[,i])) icontrasts[2] else icontrasts[1] } } X.design <- model.matrix(idesign, data=idata) iintercept <- has.intercept(X.design) iterms <- term.names(idesign) if (iintercept) iterms <- c("(Intercept)", iterms) check.imatrix(X.design) } df <- rep(0, (n.terms + intercept)*length(iterms)) hnames <- rep("", length(df)) P <- SSPEH <- SSP <- as.list(df) i <- 0 for (iterm in iterms){ if (intercept){ i <- i + 1 hyp.matrix.1 <- I.p[-1,,drop=FALSE] SSP1 <- linearHypothesis(mod, hyp.matrix.1, SSPE=SSPE, V=V, idata=idata, idesign=idesign, iterms=iterm, icontrasts=icontrasts, check.imatrix=FALSE, P=imatrix[[iterm]], singular.ok=TRUE, ...)$SSPH lh2 <- linearHypothesis(mod, I.p, SSPE=SSPE, V=V, idata=idata, idesign=idesign, iterms=iterm, icontrasts=icontrasts, check.imatrix=FALSE, P=imatrix[[iterm]], singular.ok=TRUE, ...) SSP[[i]] <- lh2$SSPH - SSP1 SSPEH[[i]] <- lh2$SSPE P[[i]] <- lh2$P df[i] <- 1 hnames[i] <- iterm } for (term in 1:n.terms){ subs <- which(assign == term) i <- i + 1 Test <- SSP.term(terms[term], iterm) SSP[[i]] <- Test$SSP SSPEH[[i]] <- Test$SSPE P[[i]] <- Test$P df[i]<- length(subs) hnames[i] <- if (iterm == "(Intercept)") terms[term] else paste(terms[term], ":", iterm, sep="") } } names(df) <- names(P) <- names(SSP) <- names(SSPEH) <- hnames result <- list(SSP=SSP, SSPE=SSPEH, P=P, df=df, error.df=error.df, terms=hnames, repeated=TRUE, type="II", test=test, idata=idata, idesign=idesign, icontrasts=icontrasts, imatrix=imatrix, singular=Test$singular) } class(result) <- "Anova.mlm" result } print.Anova.mlm <- function(x, ...){ if ((!is.null(x$singular)) && x$singular) stop("singular error SSP matrix; multivariate tests unavailable\ntry summary(object, multivariate=FALSE)") test <- x$test repeated <- x$repeated ntests <- length(x$terms) tests <- matrix(NA, ntests, 4) if (!repeated) SSPE.qr <- qr(x$SSPE) for (term in 1:ntests){ # some of the code here adapted from stats:::summary.manova eigs <- Re(eigen(qr.coef(if (repeated) qr(x$SSPE[[term]]) else SSPE.qr, x$SSP[[term]]), symmetric = FALSE)$values) tests[term, 1:4] <- switch(test, Pillai = Pillai(eigs, x$df[term], x$error.df), Wilks = Wilks(eigs, x$df[term], x$error.df), "Hotelling-Lawley" = HL(eigs, x$df[term], x$error.df), Roy = Roy(eigs, x$df[term], x$error.df)) } ok <- tests[, 2] >= 0 & tests[, 3] > 0 & tests[, 4] > 0 ok <- !is.na(ok) & ok tests <- cbind(x$df, tests, pf(tests[ok, 2], tests[ok, 3], tests[ok, 4], lower.tail = FALSE)) rownames(tests) <- x$terms colnames(tests) <- c("Df", "test stat", "approx F", "num Df", "den Df", "Pr(>F)") tests <- structure(as.data.frame(tests), heading = paste("\nType ", x$type, if (repeated) " Repeated Measures", " MANOVA Tests: ", test, " test statistic", sep=""), class = c("anova", "data.frame")) print(tests, ...) invisible(x) } # summary.Anova.mlm and print.summary.Anova.mlm methods # with contributions from Gabriel Baud-Bovy summary.Anova.mlm <- function (object, test.statistic, univariate=object$repeated, multivariate=TRUE, p.adjust.method, ...) { GG <- function(SSPE, P) { # Greenhouse-Geisser correction p <- nrow(SSPE) if (p < 2) return(NA) lambda <- eigen(SSPE %*% solve(t(P) %*% P))$values lambda <- lambda[lambda > 0] ((sum(lambda)/p)^2)/(sum(lambda^2)/p) } HF <- function(gg, error.df, p) { # Huynh-Feldt correction ((error.df + 1) * p * gg - 2)/(p * (error.df - p * gg)) } mauchly <- function(SSD, P, df) { # most of this function borrowed from stats:::mauchly.test.SSD if (nrow(SSD) < 2) return(c(NA, NA)) Tr <- function(X) sum(diag(X)) p <- nrow(P) I <- diag(p) Psi <- t(P) %*% I %*% P B <- SSD pp <- nrow(SSD) U <- solve(Psi, B) n <- df logW <- log(det(U)) - pp * log(Tr(U/pp)) rho <- 1 - (2 * pp^2 + pp + 2)/(6 * pp * n) w2 <- (pp + 2) * (pp - 1) * (pp - 2) * (2 * pp^3 + 6 * pp^2 + 3 * p + 2)/(288 * (n * pp * rho)^2) z <- -n * rho * logW f <- pp * (pp + 1)/2 - 1 Pr1 <- pchisq(z, f, lower.tail = FALSE) Pr2 <- pchisq(z, f + 4, lower.tail = FALSE) pval <- Pr1 + w2 * (Pr2 - Pr1) c(statistic = c(W = exp(logW)), p.value = pval) } if (missing(test.statistic)) test.statistic <- c("Pillai", "Wilks", "Hotelling-Lawley", "Roy") test.statistic <- match.arg(test.statistic, c("Pillai", "Wilks", "Hotelling-Lawley", "Roy"), several.ok = TRUE) nterms <- length(object$terms) summary.object <- list(type=object$type, repeated=object$repeated, multivariate.tests=NULL, univariate.tests=NULL, pval.adjustments=NULL, sphericity.tests=NULL) if (multivariate){ summary.object$multivariate.tests <- vector(nterms, mode="list") names(summary.object$multivariate.tests) <- object$terms summary.object$SSPE <- object$SSPE for (term in 1:nterms) { hyp <- list(SSPH = object$SSP[[term]], SSPE = if (object$repeated) object$SSPE[[term]] else object$SSPE, P = if (object$repeated) object$P[[term]] else NULL, test = test.statistic, df = object$df[term], df.residual = object$error.df, title = object$terms[term]) class(hyp) <- "linearHypothesis.mlm" summary.object$multivariate.tests[[term]] <- hyp } } if (object$repeated && univariate) { singular <- object$singular error.df <- object$error.df table <- matrix(0, nterms, 6) table2 <- matrix(0, nterms, 4) table3 <- matrix(0, nterms, 2) rownames(table3) <- rownames(table2) <- rownames(table) <- object$terms colnames(table) <- c("Sum Sq", "num Df", "Error SS", "den Df", "F value", "Pr(>F)") colnames(table2) <- c("GG eps", "Pr(>F[GG])", "HF eps","Pr(>F[HF])") colnames(table3) <- c("Test statistic", "p-value") if (singular) warning("Singular error SSP matrix:\nnon-sphericity test and corrections not available") for (term in 1:nterms) { SSP <- object$SSP[[term]] SSPE <- object$SSPE[[term]] P <- object$P[[term]] p <- ncol(P) PtPinv <- solve(t(P) %*% P) gg <- if (!singular) GG(SSPE, P) else NA table[term, "Sum Sq"] <- sum(diag(SSP %*% PtPinv)) table[term, "Error SS"] <- sum(diag(SSPE %*% PtPinv)) table[term, "num Df"] <- object$df[term] * p table[term, "den Df"] <- error.df * p table[term, "F value"] <- (table[term, "Sum Sq"]/table[term, "num Df"])/ (table[term, "Error SS"]/table[term, "den Df"]) table[term, "Pr(>F)"] <- pf(table[term, "F value"], table[term, "num Df"], table[term, "den Df"], lower.tail = FALSE) table2[term, "GG eps"] <- gg table2[term, "HF eps"] <- if (!singular) HF(gg, error.df, p) else NA table3[term, ] <- if (!singular) mauchly(SSPE, P, object$error.df) else NA } table3 <- na.omit(table3) if (nrow(table3) > 0) { table2[, "Pr(>F[GG])"] <- pf(table[, "F value"], table2[, "GG eps"] * table[, "num Df"], table2[, "GG eps"] * table[, "den Df"], lower.tail = FALSE) table2[, "Pr(>F[HF])"] <- pf(table[, "F value"], pmin(1, table2[, "HF eps"]) * table[, "num Df"], pmin(1, table2[, "HF eps"]) * table[, "den Df"], lower.tail = FALSE) table2 <- na.omit(table2) if (any(table2[, "HF eps"] > 1)) warning("HF eps > 1 treated as 1") } class(table3) <- class(table) <- "anova" summary.object$univariate.tests <- table summary.object$pval.adjustments <- table2 summary.object$sphericity.tests <- table3 } if (!object$repeated && univariate) { SS <- sapply(object$SSP, diag) SSE <- diag(object$SSPE) df <- object$df dfe <- object$error.df F <- (SS/df)/(SSE/dfe) SS <- cbind(SS, residuals=SSE) SS <- rbind(df=c(df, residuals=dfe), SS) p <- pf(F, df, dfe, lower.tail=FALSE) result <- list(SS=t(SS), F=t(F), p=t(p), type=object$type) if (!missing(p.adjust.method)){ if (isTRUE(p.adjust.method)) p.adjust.method <- "holm" p.adj <- apply(p, 2, p.adjust, method=p.adjust.method) result$p.adjust <- t(p.adj) result$p.adjust.method <- p.adjust.method } class(result) = "univaov" summary.object$univaov <- result } class(summary.object) <- "summary.Anova.mlm" summary.object } print.summary.Anova.mlm <- function(x, digits = getOption("digits"), SSP=TRUE, SSPE=SSP, ... ) { if (!is.null(x$multivariate.tests)) { cat(paste("\nType ", x$type, if (x$repeated) " Repeated Measures", " MANOVA Tests:\n", sep = "")) if ((!x$repeated) && SSPE) { cat("\nSum of squares and products for error:\n") print(x$SSPE, digits = digits, ...) } for (term in 1:length(x$multivariate.tests)) { cat(paste("\n------------------------------------------\n", "\nTerm:", names(x$multivariate.tests)[term], "\n")) print(x$multivariate.tests[[term]], digits = digits, SSP=SSP, SSPE=FALSE, ...) } } if (!is.null(x$univariate.tests)) { cat("\nUnivariate Type", x$type, "Repeated-Measures ANOVA Assuming Sphericity\n\n") print(x$univariate.tests) if (nrow(x$sphericity.tests) > 0) { cat("\n\nMauchly Tests for Sphericity\n\n") print(x$sphericity.tests) cat("\n\nGreenhouse-Geisser and Huynh-Feldt Corrections\n", "for Departure from Sphericity\n\n") table <- x$pval.adjustments[, 1:2, drop = FALSE] class(table) <- "anova" print(table, ...) cat("\n") table <- x$pval.adjustments[, 3:4, drop = FALSE] class(table) print(table, ...) } } if (!is.null(x$univaov)){ print(x$univaov, ...) } invisible(x) } print.univaov <- function(x, digits = max(getOption("digits") - 2L, 3L), style=c("wide", "long"), by=c("response", "term"), ...){ style <- match.arg(style) if (style == "wide") { cat("\n Type", x$type, "Sums of Squares\n") print(x$SS, digits=digits) cat("\n F-tests\n") F <- x$F print(round(F, 2)) cat("\n p-values\n") p <- format.pval(x$p) p <- matrix(p, nrow=nrow(F)) rownames(p) <- rownames(F) colnames(p) <- colnames(F) print(p, quote=FALSE) if (!is.null(x$p.adjust)){ cat("\n p-values adjusted (by term) for simultaneous inference by", x$p.adjust.method, "method\n") p.adjust <- format.pval(x$p.adjust) p.adjust <- matrix(p.adjust, nrow=nrow(F)) rownames(p.adjust) <- rownames(F) colnames(p.adjust) <- colnames(F) print(p.adjust, quote=FALSE) } } else { x.df <- as.data.frame(x, by=by) x.df$F <- round(x.df$F, 2) x.df$p <- format.pval(x.df$p) if (!is.null(x$p.adjust)) x.df$"adjusted p" <- format.pval(x.df$"adjusted p") cat("\n Type", x$type, "Sums of Squares and F tests\n") print(x.df, quote=FALSE, digits=digits) } invisible(x) } as.data.frame.univaov <- function(x, row.names, optional, by=c("response", "term"), ...) { melt <- function(data, varnames = names(dimnames(data)), value.name = "value") { dn <- dimnames(data) labels <- expand.grid( dn[[1]], dn[[2]]) colnames(labels) <- varnames value_df <- setNames(data.frame(as.vector(data)), value.name) cbind(labels, value_df) } nv <- ncol(x$F) nt <- nrow(x$F) by <- match.arg(by) if (by=="response") { vn <- c("term", "response") df <- matrix(x$SS[1:nt, "df", drop=FALSE], nrow=nt, ncol=nv) SS <- melt(x$SS[1:nt, -1, drop=FALSE], varnames=vn, value.name="SS") F <- melt(x$F, varnames=vn, value.name="F") p <- melt(x$p, varnames=vn, value.name="p") if (!is.null(x$p.adjust)) p.adjust <- melt(x$p.adjust, varnames=vn, value.name="adjusted p") } else { vn <- rev(c("term", "response")) df <- t(matrix(x$SS[1:nt, "df", drop=FALSE], nrow=nt, ncol=nv)) SS <- melt(t(x$SS[1:nt, -1, drop=FALSE]), varnames=vn, value.name="SS") F <- melt(t(x$F), varnames=vn, value.name="F") p <- melt(t(x$p), varnames=vn, value.name="p") if (!is.null(x$p.adjust)) p.adjust <- melt(t(x$p.adjust), varnames=vn, value.name="adjusted p") } result <- cbind(SS[,c(2,1,3)], df=c(df), F=F[,"F"], p=p[,"p"]) if (!is.null(x$p.adjust)) result <- cbind(result, "adjusted p"=p.adjust[, "adjusted p"]) result } Anova.manova <- function(mod, ...){ class(mod) <- c("mlm", "lm") Anova(mod, ...) } Manova <- function(mod, ...){ UseMethod("Manova") } Manova.mlm <- function(mod, ...){ Anova(mod, ...) } # Cox regression models df.residual.coxph <- function(object, ...){ object$n - sum(!is.na(coef(object))) } alias.coxph <- function(model){ if(any(which <- is.na(coef(model)))) return(list(Complete=which)) else list() } logLik.coxph <- function(object, ...) object$loglik[2] Anova.coxph <- function(mod, type=c("II","III", 2, 3), test.statistic=c("LR", "Wald"), ...){ type <- as.character(type) type <- match.arg(type) test.statistic <- match.arg(test.statistic) if (length((mod$rscore) > 0) && (test.statistic == "LR")){ warning("LR tests unavailable with robust variances\n Wald tests substituted") test.statistic <- "Wald" } names <- term.names(mod) clusters <- grepl("cluster\\(", names) strata <- grepl("strata\\(", names) if ((any(clusters) || any(strata)) && test.statistic == "LR"){ warning("LR tests not supported for models with clusters or strata\n Wald tests substituted") test.statistic <- "Wald" } switch(type, II=switch(test.statistic, LR=Anova.II.LR.coxph(mod), Wald=Anova.default(mod, type="II", test.statistic="Chisq", vcov.=vcov(mod, complete=FALSE))), III=switch(test.statistic, LR=Anova.III.LR.coxph(mod), Wald=Anova.default(mod, type="III", test.statistic="Chisq", vcov.=vcov(mod, complete=FALSE))), "2"=switch(test.statistic, LR=Anova.II.LR.coxph(mod), Wald=Anova.default(mod, type="II", test.statistic="Chisq", vcov.=vcov(mod, complete=FALSE))), "3"=switch(test.statistic, LR=Anova.III.LR.coxph(mod), Wald=Anova.default(mod, type="III", test.statistic="Chisq", vcov.=vcov(mod, complete=FALSE)))) } Anova.II.LR.coxph <- function(mod, ...){ if (!requireNamespace("survival")) stop("survival package is missing") which.nms <- function(name) which(asgn == which(names == name)) fac <-attr(terms(mod), "factors") names <- term.names(mod) n.terms <- length(names) df <- df.terms(mod) if (sum(df > 0) < 2) { return(anova(mod, test="Chisq")) } method <- mod$method weights <- mod$weights X <- model.matrix(mod) asgn <- attr(X, 'assign') p <- LR <- rep(0, n.terms) df <- df.terms(mod) for (term in 1:n.terms){ if (df[names[term]] == 0){ message("skipping term ", names[term]) next } rels <- names[relatives(names[term], names, fac)] exclude.1 <- as.vector(unlist(sapply(c(names[term], rels), which.nms))) mod.1 <- survival::coxph(mod$y ~ X[, -exclude.1, drop = FALSE], method=method, weights=weights) loglik.1 <- logLik(mod.1) mod.2 <- if (length(rels) == 0) mod else { exclude.2 <- as.vector(unlist(sapply(rels, which.nms))) survival::coxph(mod$y ~ X[, -exclude.2, drop = FALSE], method=method, weights=weights) } loglik.2 <- logLik(mod.2) LR[term] <- -2*(loglik.1 - loglik.2) p[term] <- pchisq(LR[term], df[term], lower.tail=FALSE) } result <- data.frame(LR, df, p) row.names(result) <- names names(result) <- c("LR Chisq", "Df", "Pr(>Chisq)") class(result) <- c("anova", "data.frame") result <- result[df > 0, , drop=FALSE] attr(result, "heading") <- "Analysis of Deviance Table (Type II tests)" result } Anova.III.LR.coxph <- function(mod, ...){ if (!requireNamespace("survival")) stop("survival package is missing") which.nms <- function(name) which(asgn == which(names == name)) fac <-attr(terms(mod), "factors") names <- term.names(mod) n.terms <- length(names) df <- df.terms(mod) if (sum(df > 0) < 2) { return(anova(mod, test="Chisq")) } method <- mod$method weights <- mod$weights X <- model.matrix(mod) asgn <- attr(X, 'assign') LR <- p <- rep(0, n.terms) loglik1 <- logLik(mod) for (term in 1:n.terms){ if (df[names[term]] == 0){ message("skipping term ", names[term]) next } mod.0 <- survival::coxph(mod$y ~ X[, -which.nms(names[term])], method=method, weights=weights) LR[term] <- -2*(logLik(mod.0) - loglik1) p[term] <- pchisq(LR[term], df[term], lower.tail=FALSE) } result <- data.frame(LR, df, p) row.names(result) <- names names(result) <- c("LR Chisq", "Df","Pr(>Chisq)") class(result) <- c("anova", "data.frame") result <- result[df > 0, , drop=FALSE] attr(result,"heading") <- "Analysis of Deviance Table (Type III tests)" result } # parametric survival regression models alias.survreg <- function(model){ if(any(which <- diag(vcov(model, complete=FALSE)) < 1e-10)) return(list(Complete=which)) else list() } logLik.survreg <- function(object, ...) object$loglik[2] Anova.survreg <- function(mod, type=c("II","III", 2, 3), test.statistic=c("LR", "Wald"), ...){ type <- as.character(type) type <- match.arg(type) test.statistic <- match.arg(test.statistic) if (length((mod$rscore) > 0) && (test.statistic == "LR")){ warning("LR tests unavailable with robust variances\nWald tests substituted") test.statistic <- "Wald" } switch(type, II=switch(test.statistic, LR=Anova.II.LR.survreg(mod), Wald=Anova.II.Wald.survreg(mod)), III=switch(test.statistic, LR=Anova.III.LR.survreg(mod), Wald=Anova.III.Wald.survreg(mod)), "2"=switch(test.statistic, LR=Anova.II.LR.survreg(mod), Wald=Anova.II.Wald.survreg(mod)), "3"=switch(test.statistic, LR=Anova.III.LR.survreg(mod), Wald=Anova.III.Wald.survreg(mod))) } Anova.II.LR.survreg <- function(mod, ...){ if (!requireNamespace("survival")) stop("survival package is missing") dist <- mod$dist scale <- mod$call$scale weights <- model.frame(mod)$"(weights)" arg.list <- list(dist=dist) if (!is.null(scale)) arg.list$scale <- scale if (!is.null(weights)) arg.list$weights <- weights which.nms <- function(name) which(asgn == which(names == name)) fac <-attr(terms(mod), "factors") names <- term.names(mod) X <- model.matrix(mod) asgn <- attr(X, 'assign') asgn <- asgn[asgn != 0] if (has.intercept(mod)){ int <- which(names == "(Intercept)") X <- X[, -int] names <- names[-int] } n.terms <- length(names) if (n.terms < 2) { result <- anova(mod) if (!inherits(result, "anova")) class(result) <- c("anova", class(result)) return(result) } p <- LR <- rep(0, n.terms) df <- df.terms(mod) y <- model.frame(mod)[,1] for (term in 1:n.terms){ rels <- names[relatives(names[term], names, fac)] exclude.1 <- as.vector(unlist(sapply(c(names[term], rels), which.nms))) arg.list$formula <- y ~ X[, -exclude.1, drop = FALSE] mod.1 <- do.call(survival::survreg, arg.list) # mod.1 <- survival::survreg(y ~ X[, -exclude.1, drop = FALSE]) loglik.1 <- logLik(mod.1) mod.2 <- if (length(rels) == 0) mod else { arg.list$formula <- y ~ X[, -exclude.2, drop = FALSE] exclude.2 <- as.vector(unlist(sapply(rels, which.nms))) do.call(survival::survreg, arg.list) # survival::survreg(y ~ X[, -exclude.2, drop = FALSE]) } loglik.2 <- logLik(mod.2) LR[term] <- -2*(loglik.1 - loglik.2) p[term] <- pchisq(LR[term], df[term], lower.tail=FALSE) } result <- data.frame(LR, df, p) row.names(result) <- names names(result) <- c("LR Chisq", "Df", "Pr(>Chisq)") class(result) <- c("anova", "data.frame") attr(result, "heading") <- "Analysis of Deviance Table (Type II tests)" result } Anova.III.LR.survreg <- function(mod, ...){ if (!requireNamespace("survival")) stop("survival package is missing") dist <- mod$dist scale <- mod$call$scale weights <- model.frame(mod)$"(weights)" arg.list <- list(dist=dist) if (!is.null(scale)) arg.list$scale <- scale if (!is.null(weights)) arg.list$weights <- weights which.nms <- function(name) which(asgn == which(names == name)) fac <-attr(terms(mod), "factors") names <- term.names(mod) X <- model.matrix(mod) asgn <- attr(X, 'assign') asgn <- asgn[asgn != 0] if (has.intercept(mod)){ int <- which(names == "(Intercept)") X <- X[, -int] names <- names[-int] } n.terms <- length(names) if (n.terms < 2){ result <- anova(mod) if (!inherits(result, "anova")) class(result) <- c("anova", class(result)) return(result) } p <- LR <- rep(0, n.terms) df <- df.terms(mod) y <- model.frame(mod)[,1] loglik1 <- logLik(mod) for (term in 1:n.terms){ arg.list$formula <- y ~ X[, -which.nms(names[term])] mod.0 <- do.call(survival::survreg, arg.list) # mod.0 <- survival::survreg(y ~ X[, -which.nms(names[term])]) LR[term] <- -2*(logLik(mod.0) - loglik1) p[term] <- pchisq(LR[term], df[term], lower.tail=FALSE) } result <- data.frame(LR, df, p) row.names(result) <- names names(result) <- c("LR Chisq", "Df","Pr(>Chisq)") class(result) <- c("anova", "data.frame") attr(result,"heading") <- "Analysis of Deviance Table (Type III tests)" result } Anova.II.Wald.survreg <- function(mod){ V <- vcov(mod, complete=FALSE) b <- coef(mod) if (length(b) != nrow(V)){ p <- which(rownames(V) == "Log(scale)") if (length(p) > 0) V <- V[-p, -p] } Anova.II.default(mod, V, test="Chisq") } Anova.III.Wald.survreg <- function(mod){ V <- vcov(mod, complete=FALSE) b <- coef(mod) if (length(b) != nrow(V)){ p <- which(rownames(V) == "Log(scale)") if (length(p) > 0) V <- V[-p, -p] } Anova.III.default(mod, V, test="Chisq") } # Default Anova() method: requires methods for vcov() (if vcov. argument not specified) and coef(). Anova.default <- function(mod, type=c("II","III", 2, 3), test.statistic=c("Chisq", "F"), vcov.=vcov(mod, complete=FALSE), singular.ok, ...){ vcov. <- getVcov(vcov., mod) type <- as.character(type) type <- match.arg(type) test.statistic <- match.arg(test.statistic) if (missing(singular.ok)) singular.ok <- type == "2" || type == "II" switch(type, II=Anova.II.default(mod, vcov., test.statistic, singular.ok=singular.ok), III=Anova.III.default(mod, vcov., test.statistic, singular.ok=singular.ok), "2"=Anova.II.default(mod, vcov., test.statistic, singular.ok=singular.ok), "3"=Anova.III.default(mod, vcov., test.statistic, singular.ok=singular.ok)) } assignVector <- function(model, ...) UseMethod("assignVector") assignVector.default <- function(model, ...){ m <- model.matrix(model) assign <- attr(m, "assign") if (!is.null(assign)) return (assign) m <- model.matrix(formula(model), data=model.frame(model)) assign <- attr(m, "assign") if (!has.intercept(model)) assign <- assign[assign != 0] assign } Anova.II.default <- function(mod, vcov., test, singular.ok=TRUE, ...){ hyp.term <- function(term){ which.term <- which(term==names) subs.term <- if (is.list(assign)) assign[[which.term]] else which(assign == which.term) relatives <- relatives(term, names, fac) subs.relatives <- NULL for (relative in relatives){ sr <- if (is.list(assign)) assign[[relative]] else which(assign == relative) subs.relatives <- c(subs.relatives, sr) } hyp.matrix.1 <- I.p[subs.relatives,,drop=FALSE] hyp.matrix.1 <- hyp.matrix.1[, not.aliased, drop=FALSE] hyp.matrix.2 <- I.p[c(subs.relatives,subs.term),,drop=FALSE] hyp.matrix.2 <- hyp.matrix.2[, not.aliased, drop=FALSE] hyp.matrix.term <- if (nrow(hyp.matrix.1) == 0) hyp.matrix.2 else t(ConjComp(t(hyp.matrix.1), t(hyp.matrix.2), vcov.)) hyp.matrix.term <- hyp.matrix.term[!apply(hyp.matrix.term, 1, function(x) all(x == 0)), , drop=FALSE] if (nrow(hyp.matrix.term) == 0) return(c(statistic=NA, df=0)) hyp <- linearHypothesis.default(mod, hyp.matrix.term, vcov.=vcov., test=test, singular.ok=singular.ok, ...) if (test=="Chisq") c(statistic=hyp$Chisq[2], df=hyp$Df[2]) else c(statistic=hyp$F[2], df=hyp$Df[2]) } not.aliased <- !is.na(coef(mod)) if (!singular.ok && !all(not.aliased)) stop("there are aliased coefficients in the model") fac <- attr(terms(mod), "factors") intercept <- has.intercept(mod) p <- length(coefficients(mod)) I.p <- diag(p) assign <- assignVector(mod) # attr(model.matrix(mod), "assign") if (!is.list(assign)) assign[!not.aliased] <- NA else if (intercept) assign <- assign[-1] names <- term.names(mod) if (intercept) names <- names[-1] n.terms <- length(names) df <- c(rep(0, n.terms), df.residual(mod)) if (inherits(mod, "coxph")){ assign <- assign[assign != 0] clusters <- grep("^cluster\\(", names) strata <- grep("^strata\\(.*\\)$", names) for (cl in clusters) assign[assign > cl] <- assign[assign > cl] - 1 for (st in strata) assign[assign > st] <- assign[assign > st] - 1 if (length(clusters) > 0 || length(strata) > 0) { message("skipping term ", paste(names[c(clusters, strata)], collapse=", ")) names <- names[-c(clusters, strata)] df <- df[-c(clusters, strata)] n.terms <- n.terms - length(clusters) - length(strata) } } # if (inherits(mod, "plm")) assign <- assign[assign != 0] p <- teststat <- rep(0, n.terms + 1) teststat[n.terms + 1] <- p[n.terms + 1] <- NA for (i in 1:n.terms){ hyp <- hyp.term(names[i]) teststat[i] <- abs(hyp["statistic"]) df[i] <- abs(hyp["df"]) p[i] <- if (test == "Chisq") pchisq(teststat[i], df[i], lower.tail=FALSE) else pf(teststat[i], df[i], df[n.terms + 1], lower.tail=FALSE) } result <- if (test == "Chisq"){ if (length(df) == n.terms + 1) df <- df[1:n.terms] data.frame(df[df > 0], teststat[!is.na(teststat)], p[!is.na(teststat)]) } else data.frame(df, teststat, p) if (nrow(result) == length(names) + 1) names <- c(names,"Residuals") row.names(result) <- names[df > 0] names(result) <- c ("Df", test, if (test == "Chisq") "Pr(>Chisq)" else "Pr(>F)") class(result) <- c("anova", "data.frame") attr(result, "heading") <- c("Analysis of Deviance Table (Type II tests)\n", paste("Response:", responseName(mod))) result } Anova.III.default <- function(mod, vcov., test, singular.ok=FALSE, ...){ intercept <- has.intercept(mod) p <- length(coefficients(mod)) I.p <- diag(p) names <- term.names(mod) n.terms <- length(names) assign <- assignVector(mod) # attr(model.matrix(mod), "assign") df <- c(rep(0, n.terms), df.residual(mod)) if (inherits(mod, "coxph")){ if (intercept) names <- names[-1] assign <- assign[assign != 0] clusters <- grep("^cluster\\(", names) strata <- grep("^strata\\(.*\\)$", names) for (cl in clusters) assign[assign > cl] <- assign[assign > cl] - 1 for (st in strata) assign[assign > st] <- assign[assign > st] - 1 if (length(clusters) > 0 || length(strata) > 0) { message("skipping term ", paste(names[c(clusters, strata)], collapse=", ")) names <- names[-c(clusters, strata)] df <- df[-c(clusters, strata)] n.terms <- n.terms - length(clusters) - length(strata) } } # if (inherits(mod, "plm")) assign <- assign[assign != 0] if (intercept) df[1] <- sum(grepl("^\\(Intercept\\)", names(coef(mod)))) teststat <- rep(0, n.terms + 1) p <- rep(0, n.terms + 1) teststat[n.terms + 1] <- p[n.terms + 1] <- NA not.aliased <- !is.na(coef(mod)) if (!singular.ok && !all(not.aliased)) stop("there are aliased coefficients in the model") for (term in 1:n.terms){ subs <- if (is.list(assign)) assign[[term]] else which(assign == term - intercept) hyp.matrix <- I.p[subs,,drop=FALSE] hyp.matrix <- hyp.matrix[, not.aliased, drop=FALSE] hyp.matrix <- hyp.matrix[!apply(hyp.matrix, 1, function(x) all(x == 0)), , drop=FALSE] if (nrow(hyp.matrix) == 0){ teststat[term] <- NA df[term] <- 0 p[term] <- NA } else { hyp <- linearHypothesis.default(mod, hyp.matrix, vcov.=vcov., test=test, singular.ok=singular.ok, ...) teststat[term] <- if (test=="Chisq") hyp$Chisq[2] else hyp$F[2] df[term] <- abs(hyp$Df[2]) p[term] <- if (test == "Chisq") pchisq(teststat[term], df[term], lower.tail=FALSE) else pf(teststat[term], df[term], df[n.terms + 1], lower.tail=FALSE) } } result <- if (test == "Chisq"){ if (length(df) == n.terms + 1) df <- df[1:n.terms] data.frame(df, teststat[!is.na(teststat)], p[!is.na(teststat)]) } else data.frame(df, teststat, p) if (nrow(result) == length(names) + 1) names <- c(names,"Residuals") row.names(result) <- names names(result) <- c ("Df", test, if (test == "Chisq") "Pr(>Chisq)" else "Pr(>F)") class(result) <- c("anova", "data.frame") attr(result, "heading") <- c("Analysis of Deviance Table (Type III tests)\n", paste("Response:", responseName(mod))) result } ## functions for mixed models # the following function, not exported, to make car consistent with CRAN and development versions of lme4 and with nlme fixef <- function (object){ if (isS4(object)) { if (!inherits(object, "merMod")) object@fixef else lme4::fixef(object) } else object$coefficients$fixed } Anova.merMod <- function(mod, type=c("II","III", 2, 3), test.statistic=c("Chisq", "F"), vcov.=vcov(mod, complete=FALSE), singular.ok, ...){ type <- as.character(type) type <- match.arg(type) test.statistic <- match.arg(test.statistic) if (!missing(vcov.)) { if (test.statistic != "F"){ message("Coefficient covariances computed by ", deparse(substitute(vcov.))) } else { warning('test.statistic="F"; vcov. argument ignored') } } vcov. <- getVcov(vcov., mod) if (missing(singular.ok)) singular.ok <- type == "2" || type == "II" Anova.mer(mod=mod, type=type, test.statistic=test.statistic, vcov.=vcov., singular.ok=singular.ok, ...) } Anova.mer <- function(mod, type=c("II","III", 2, 3), test.statistic=c("Chisq", "F"), vcov.=vcov(mod, complete=FALSE), singular.ok, ...){ vcov. <- getVcov(vcov., mod) type <- as.character(type) type <- match.arg(type) test.statistic <- match.arg(test.statistic) if (missing(singular.ok)) singular.ok <- type == "2" || type == "II" switch(type, II=Anova.II.mer(mod, test=test.statistic, vcov., singular.ok=singular.ok), III=Anova.III.mer(mod, test=test.statistic, vcov., singular.ok=singular.ok), "2"=Anova.II.mer(mod, test=test.statistic, vcov., singular.ok=singular.ok), "3"=Anova.III.mer(mod, test=test.statistic, vcov., singular.ok=singular.ok)) } Anova.II.mer <- function(mod, vcov., singular.ok=TRUE, test=c("Chisq", "F"), ...){ hyp.term <- function(term){ which.term <- which(term==names) subs.term <- which(assign==which.term) relatives <- relatives(term, names, fac) subs.relatives <- NULL for (relative in relatives) subs.relatives <- c(subs.relatives, which(assign==relative)) hyp.matrix.1 <- I.p[subs.relatives,,drop=FALSE] hyp.matrix.1 <- hyp.matrix.1[, not.aliased, drop=FALSE] hyp.matrix.2 <- I.p[c(subs.relatives,subs.term),,drop=FALSE] hyp.matrix.2 <- hyp.matrix.2[, not.aliased, drop=FALSE] hyp.matrix.term <- if (nrow(hyp.matrix.1) == 0) hyp.matrix.2 else t(ConjComp(t(hyp.matrix.1), t(hyp.matrix.2), vcov.)) hyp.matrix.term <- hyp.matrix.term[!apply(hyp.matrix.term, 1, function(x) all(x == 0)), , drop=FALSE] if (nrow(hyp.matrix.term) == 0) return(c(statistic=NA, df=0)) hyp <- linearHypothesis(mod, hyp.matrix.term, vcov.=vcov., singular.ok=singular.ok, test=test, ...) if (test == "Chisq") return(c(statistic=hyp$Chisq[2], df=hyp$Df[2])) else return(c(statistic=hyp$F[2], df=hyp$Df[2], res.df=hyp$Res.Df[2])) } test <- match.arg(test) not.aliased <- !is.na(fixef(mod)) if (!singular.ok && !all(not.aliased)) stop("there are aliased coefficients in the model") fac <- attr(terms(mod), "factors") intercept <- has.intercept(mod) p <- length(fixef(mod)) I.p <- diag(p) if (test == "F"){ vcov. <- as.matrix(pbkrtest::vcovAdj(mod, details=0)) } assign <- attr(model.matrix(mod), "assign") assign[!not.aliased] <- NA names <- term.names(mod) if (intercept) names <- names[-1] n.terms <- length(names) p <- teststat <- df <- res.df <- rep(0, n.terms) for (i in 1:n.terms){ hyp <- hyp.term(names[i]) teststat[i] <- abs(hyp["statistic"]) df[i] <- abs(hyp["df"]) res.df[i] <- hyp["res.df"] p[i] <- if (test == "Chisq") pchisq(teststat[i], df[i], lower.tail=FALSE) else pf(teststat[i], df[i], res.df[i], lower.tail=FALSE) } if (test=="Chisq"){ result <- data.frame(teststat, df, p) row.names(result) <- names names(result) <- c ("Chisq", "Df", "Pr(>Chisq)") class(result) <- c("anova", "data.frame") attr(result, "heading") <- c("Analysis of Deviance Table (Type II Wald chisquare tests)\n", paste("Response:", responseName(mod))) } else { result <- data.frame(teststat, df, res.df, p) row.names(result) <- names names(result) <- c ("F", "Df", "Df.res", "Pr(>F)") class(result) <- c("anova", "data.frame") attr(result, "heading") <- c("Analysis of Deviance Table (Type II Wald F tests with Kenward-Roger df)\n", paste("Response:", responseName(mod))) } result } Anova.III.mer <- function(mod, vcov., singular.ok=FALSE, test=c("Chisq", "F"), ...){ intercept <- has.intercept(mod) p <- length(fixef(mod)) I.p <- diag(p) names <- term.names(mod) n.terms <- length(names) assign <- attr(model.matrix(mod), "assign") p <- teststat <- df <- res.df <- rep(0, n.terms) if (intercept) df[1] <- 1 not.aliased <- !is.na(fixef(mod)) if (!singular.ok && !all(not.aliased)) stop("there are aliased coefficients in the model") if (test == "F"){ vcov. <- as.matrix(pbkrtest::vcovAdj(mod, details=0)) } for (term in 1:n.terms){ subs <- which(assign == term - intercept) hyp.matrix <- I.p[subs,,drop=FALSE] hyp.matrix <- hyp.matrix[, not.aliased, drop=FALSE] hyp.matrix <- hyp.matrix[!apply(hyp.matrix, 1, function(x) all(x == 0)), , drop=FALSE] if (nrow(hyp.matrix) == 0){ teststat[term] <- NA df[term] <- 0 p[term] <- NA } else { hyp <- linearHypothesis(mod, hyp.matrix, test=test, vcov.=vcov., singular.ok=singular.ok, ...) if (test == "Chisq"){ teststat[term] <- hyp$Chisq[2] df[term] <- abs(hyp$Df[2]) p[term] <- pchisq(teststat[term], df[term], lower.tail=FALSE) } else{ teststat[term] <- hyp$F[2] df[term] <- abs(hyp$Df[2]) res.df[term]=hyp$Res.Df[2] p[term] <- pf(teststat[term], df[term], res.df[term], lower.tail=FALSE) } } } if (test == "Chisq"){ result <- data.frame(teststat, df, p) row.names(result) <- names names(result) <- c ("Chisq", "Df", "Pr(>Chisq)") class(result) <- c("anova", "data.frame") attr(result, "heading") <- c("Analysis of Deviance Table (Type III Wald chisquare tests)\n", paste("Response:", responseName(mod))) } else { result <- data.frame(teststat, df, res.df, p) row.names(result) <- names names(result) <- c ("F", "Df", "Df.res", "Pr(>F)") class(result) <- c("anova", "data.frame") attr(result, "heading") <- c("Analysis of Deviance Table (Type III Wald F tests with Kenward-Roger df)\n", paste("Response:", responseName(mod))) } result } has.intercept.lme <- function(model, ...){ any(names(fixef(model)) == "(Intercept)") } Anova.lme <- function(mod, type=c("II","III", 2, 3), vcov.=vcov(mod, complete=FALSE), singular.ok, ...){ if (!missing(vcov.)) message("Coefficient covariances computed by ", deparse(substitute(vcov.))) vcov. <- getVcov(vcov., mod) type <- as.character(type) type <- match.arg(type) if (missing(singular.ok)) singular.ok <- type == "2" || type == "II" switch(type, II=Anova.II.lme(mod, vcov., singular.ok=singular.ok), III=Anova.III.lme(mod, vcov., singular.ok=singular.ok), "2"=Anova.II.lme(mod, vcov., singular.ok=singular.ok), "3"=Anova.III.lme(mod, vcov., singular.ok=singular.ok)) } Anova.II.lme <- function(mod, vcov., singular.ok=TRUE, ...){ hyp.term <- function(term){ which.term <- which(term==names) subs.term <- which(assign==which.term) relatives <- relatives(term, names, fac) subs.relatives <- NULL for (relative in relatives) subs.relatives <- c(subs.relatives, which(assign==relative)) hyp.matrix.1 <- I.p[subs.relatives,,drop=FALSE] hyp.matrix.1 <- hyp.matrix.1[, not.aliased, drop=FALSE] hyp.matrix.2 <- I.p[c(subs.relatives,subs.term),,drop=FALSE] hyp.matrix.2 <- hyp.matrix.2[, not.aliased, drop=FALSE] hyp.matrix.term <- if (nrow(hyp.matrix.1) == 0) hyp.matrix.2 else t(ConjComp(t(hyp.matrix.1), t(hyp.matrix.2), vcov.)) hyp.matrix.term <- hyp.matrix.term[!apply(hyp.matrix.term, 1, function(x) all(x == 0)), , drop=FALSE] if (nrow(hyp.matrix.term) == 0) return(c(statistic=NA, df=0)) hyp <- linearHypothesis(mod, hyp.matrix.term, vcov.=vcov., singular.ok=singular.ok, ...) c(statistic=hyp$Chisq[2], df=hyp$Df[2]) } not.aliased <- !is.na(fixef(mod)) if (!singular.ok && !all(not.aliased)) stop("there are aliased coefficients in the model") fac <- attr(terms(mod), "factors") intercept <- has.intercept(mod) p <- length(fixef(mod)) I.p <- diag(p) # assign <- attr(model.matrix(mod), "assign") attribs.mm <- attributes(model.matrix(mod)) assign <- attribs.mm$assign nms.coef <- names(coef(mod)) nms.mm <- attribs.mm$dimnames[[2]] assign[!not.aliased] <- NA valid.coefs <- nms.mm %in% nms.coef if (any(!valid.coefs)){ warning("The following coefficients are not in the model due to missing levels:\n", paste(nms.mm[!valid.coefs], collapse=", ")) } assign <- assign[valid.coefs] # assign[!not.aliased] <- NA names <- term.names(mod) if (intercept) names <- names[-1] n.terms <- length(names) p <- teststat <- df <- rep(0, n.terms) for (i in 1:n.terms){ hyp <- hyp.term(names[i]) teststat[i] <- abs(hyp["statistic"]) df[i] <- abs(hyp["df"]) p[i] <- pchisq(teststat[i], df[i], lower.tail=FALSE) } result <- data.frame(teststat, df, p) row.names(result) <- names names(result) <- c("Chisq", "Df", "Pr(>Chisq)") class(result) <- c("anova", "data.frame") attr(result, "heading") <- c("Analysis of Deviance Table (Type II tests)\n", paste("Response:", responseName(mod))) result } Anova.III.lme <- function(mod, vcov., singular.ok=FALSE, ...){ intercept <- has.intercept(mod) p <- length(fixef(mod)) I.p <- diag(p) names <- term.names(mod) n.terms <- length(names) # assign <- attr(model.matrix(mod), "assign") attribs.mm <- attributes(model.matrix(mod)) assign <- attribs.mm$assign nms.coef <- names(coef(mod)) nms.mm <- attribs.mm$dimnames[[2]] not.aliased <- !is.na(fixef(mod)) if (!singular.ok && !all(not.aliased)) stop("there are aliased coefficients in the model") assign[!not.aliased] <- NA valid.coefs <- nms.mm %in% nms.coef if (any(!valid.coefs)){ warning("The following coefficients are not in the model due to missing levels:\n", paste(nms.mm[!valid.coefs], collapse=", ")) } assign <- assign[valid.coefs] df <- rep(0, n.terms) if (intercept) df[1] <- 1 p <- teststat <-rep(0, n.terms) # not.aliased <- !is.na(fixef(mod)) # if (!singular.ok && !all(not.aliased)) # stop("there are aliased coefficients in the model") for (term in 1:n.terms){ subs <- which(assign == term - intercept) hyp.matrix <- I.p[subs,,drop=FALSE] hyp.matrix <- hyp.matrix[, not.aliased, drop=FALSE] hyp.matrix <- hyp.matrix[!apply(hyp.matrix, 1, function(x) all(x == 0)), , drop=FALSE] if (nrow(hyp.matrix) == 0){ teststat[term] <- NA df[term] <- 0 p[term] <- NA } else { hyp <- linearHypothesis(mod, hyp.matrix, vcov.=vcov., singular.ok=singular.ok, ...) teststat[term] <- hyp$Chisq[2] df[term] <- abs(hyp$Df[2]) p[term] <- pchisq(teststat[term], df[term], lower.tail=FALSE) } } result <- data.frame(teststat, df, p) row.names(result) <- names names(result) <- c ("Chisq", "Df", "Pr(>Chisq)") class(result) <- c("anova", "data.frame") attr(result, "heading") <- c("Analysis of Deviance Table (Type III tests)\n", paste("Response:", responseName(mod))) result } Anova.svyglm <- function(mod, ...) Anova.default(mod, ...) Anova.rlm <- function(mod, ...) Anova.default(mod, test.statistic="F", ...) Anova.coxme <- function(mod, type=c("II","III", 2, 3), test.statistic=c("Wald", "LR"), ...){ type <- as.character(type) type <- match.arg(type) test.statistic <- match.arg(test.statistic) switch(type, II=switch(test.statistic, LR=Anova.II.LR.coxme(mod, ...), Wald=Anova.default(mod, type="II", test.statistic="Chisq", ...)), III=switch(test.statistic, LR=stop("type-III LR tests not available for coxme models"), Wald=Anova.default(mod, type="III", test.statistic="Chisq", ...)), "2"=switch(test.statistic, LR=Anova.II.LR.coxme(mod, ...), Wald=Anova.default(mod, type="II", test.statistic="Chisq", ...)), "3"=switch(test.statistic, LR=stop("type-III LR tests not available for coxme models"), Wald=Anova.default(mod, type="III", test.statistic="Chisq"))) } Anova.II.LR.coxme <- function(mod, ...){ if (!requireNamespace("coxme")) stop("coxme package is missing") which.nms <- function(name) which(asgn == which(names == name)) fac <-attr(terms(mod), "factors") names <- term.names(mod) n.terms <- length(names) if (n.terms < 2){ return(anova(mod, test="Chisq")) } X <- model.matrix(mod) asgn <- attr(X, 'assign') p <- LR <- rep(0, n.terms) df <- df.terms(mod) random <- mod$formulaList$random random <- sapply(random, as.character)[2, ] random <- paste(paste0("(", random, ")"), collapse=" + ") fixed <- as.character(mod$formulaList$fixed)[3] for (term in 1:n.terms){ rels <- names[relatives(names[term], names, fac)] formula <- paste0(". ~ . - ", paste(c(names[term], rels), collapse=" - "), " + ", random) mod.1 <- update(mod, as.formula(formula)) loglik.1 <- logLik(mod.1, type="integrated") mod.2 <- if (length(rels) == 0) mod else { formula <- paste0(". ~ . - ", paste(rels, collapse=" - "), " + ", random) update(mod, as.formula(formula)) } loglik.2 <- logLik(mod.2, type="integrated") LR[term] <- -2*(loglik.1 - loglik.2) p[term] <- pchisq(LR[term], df[term], lower.tail=FALSE) } result <- data.frame(LR, df, p) row.names(result) <- names names(result) <- c("LR Chisq", "Df", "Pr(>Chisq)") class(result) <- c("anova", "data.frame") attr(result, "heading") <- "Analysis of Deviance Table (Type II tests)" result } # the following unexported methods make Anova.default() and linearHypotheis.default() work with "svyolr" objects assignVector.svyolr <- function(model, ...){ m <- model.matrix(model) assign <- attr(m, "assign") assign[assign != 0] } coef.svyolr <- function(object, ...) NextMethod() vcov.svyolr <- function(object, ...){ nms <- names(coef(object)) (object$var)[nms, nms] } car/R/influence-mixed-models.R0000644000176000001440000001567614140261763015753 0ustar ripleyusers# # added 2017-12-13 by J. Fox # # 2017-12-14: improved recovery of model data # # removed faulty one-step approximations # # 2018-01-28: fix computation of Cook's D for lme models # # 2018-05-23: fixed bug when more than one grouping variable (reported by Maarten Jung) # # 2018-06-07: skip plot of "sigma^2" in GLMM if dispersion fixed to 1; improved labelling for covariance components # # 2018-11-04: tweak to dfbetas.influence.merMod() suggested by Ben Bolker. # # 2018-11-09: parallel version of influence.merMod() # # 2020-12-04: make influence.lme() label rows of deleted fixed effects matrix so infIndexPlot() works # # (fixing problem reported by Francis L. Huang). # # merMod methods removed in favour of their versions in lme4 # # # influence diagnostics for mixed models globalVariables(".groups") dfbeta.influence.lme <- function(model, which=c("fixed", "var.cov"), ...){ which <- match.arg(which) b <- if (which == "fixed") model[[2]] else model[[4]] b0 <- if (which == "fixed") model[[1]] else model[[3]] b - matrix(b0, nrow=nrow(b), ncol=ncol(b), byrow=TRUE) } dfbetas.influence.lme <- function(model, ...){ dfbeta(model)/t(sapply(model[[6]], function(x) sqrt(diag(as.matrix(x))))) } cooks.distance.influence.lme <- function(model, ...){ db <- dfbeta(model) n <- nrow(db) p <- ncol(db) d <- numeric(n) vcovs <- model[[6]] sig.sq <- (exp(model[[4]][, ncol(model[[4]])]))^2 for (i in 1:n){ d[i] <- (db[i, ] %*% solve(vcovs[[i]]) %*% db[i, ])/(p*sig.sq[i]) } d } influence.lme <- function(model, groups, data, ncores=1, ...){ if (is.infinite(ncores)) { ncores <- parallel::detectCores(logical=FALSE) } if (missing(data)) data <- model$data if (is.null(data)){ data <- getCall(model)$data data <- if (!is.null(data)) eval(data, parent.frame()) else stop("model did not use the data argument") } if (missing(groups)) { groups <- ".case" data$.case <- rownames(data) } else if (length(groups) > 1){ del.var <- paste0(groups, collapse=".") data[, del.var] <- apply(data[, groups], 1, function (row) paste0(row, collapse=".")) groups <- del.var } unique.del <- unique(data[, groups]) data$.groups <- data[, groups] fixed <- fixef(model) # fixed.1 <- matrix(0, length(unique.del), length(fixed)) # rownames(fixed.1) <- unique.del # colnames(fixed.1) <- names(fixed) vc <- attr(model$apVar, "Pars") vc.1 <- matrix(0, length(unique.del), length(vc)) rownames(vc.1) <- unique.del colnames(vc.1) <- names(vc) vcov.1 <- vector(length(unique.del), mode="list") names(vcov.1) <- unique.del deleteGroup <- function(del){ data$del <- del mod.1 <- suppressWarnings(update(model, data=data, subset=.groups != del, control=nlme::lmeControl(returnObject=TRUE))) fixed.1 <- fixef(mod.1) vc.0 <- attr(mod.1$apVar, "Pars") vc.1 <- if (!is.null(vc.0)) vc.0 else rep(as.numeric(NA), length(vc)) vcov.1 <- vcov(mod.1) list(fixed.1=fixed.1, vc.1=vc.1, vcov.1=vcov.1) } result <- if(ncores >= 2){ message("Note: using a cluster of ", ncores, " cores") cl <- parallel::makeCluster(ncores) on.exit(parallel::stopCluster(cl)) parallel::clusterEvalQ(cl, require("nlme")) parallel::clusterApply(cl, unique.del, deleteGroup) } else { lapply(unique.del, deleteGroup) } result <- combineLists(result) left <- "[-" right <- "]" if (groups == ".case") { groups <- "case" } rownames(result$fixed.1) <- unique.del colnames(result$fixed.1) <- names(fixed) nms <- c("fixed.effects", paste0("fixed.effects", left, groups, right), "var.cov.comps", paste0("var.cov.comps", left, groups, right), "vcov", paste0("vcov", left, groups, right), "groups", "deleted") result <- list(fixed, fixed.1=result$fixed.1, vc, vc.1=result$vc.1, vcov(model), vcov.1=result$vcov.1, groups, unique.del) names(result) <- nms class(result) <- "influence.lme" result } infIndexPlot.influence.lme <- function(model, vars=c("dfbeta", "dfbetas", "var.cov.comps", "cookd"), id=TRUE, grid=TRUE, main="Diagnostic Plots", ...){ if (missing(vars)) vars <- c("dfbeta", "cookd") infIndexPlot.influence.merMod(model, vars=vars, id=id, grid=grid, main=main) } infIndexPlot.influence.merMod <- function(model, vars=c("dfbeta", "dfbetas", "var.cov.comps", "cookd"), id=TRUE, grid=TRUE, main="Diagnostic Plots", ...){ id <- applyDefaults(id, defaults=list(method="y", n=2, cex=1, col=carPalette()[1], location="lr"), type="id") if (isFALSE(id)){ id.n <- 0 id.method <- "none" labels <- id.cex <- id.col <- id.location <- NULL } else{ labels <- id$labels if (is.null(labels)) labels <- row.names(model[[2]]) id.method <- id$method id.n <- if ("identify" %in% id.method) Inf else id$n id.cex <- id$cex id.col <- id$col id.location <- id$location } if (missing(vars)) vars <- c("dfbeta", "cookd") what <- pmatch(tolower(vars), c("dfbeta", "dfbetas", "var.cov.comps", "cookd")) if(length(what) < 1) stop("Nothing to plot") X <- cbind(if (1 %in% what) dfbeta(model), if (2 %in% what) dfbetas(model), if (3 %in% what) dfbeta(model, "var.cov"), if (4 %in% what) cooks.distance(model)) if (4 %in% what) colnames(X)[ncol(X)] <- "Cook's D" names <- colnames(X) # check for row.names, and use them if they are numeric. oldwarn <- options()$warn options(warn=-1) xaxis <- as.numeric(row.names(model[[2]])) options(warn=oldwarn) if (any (is.na(xaxis))) xaxis <- 1:length(xaxis) plotnum <- 0 nplots <- ncol(X) if ("sigma^2" %in% names){ if (all(X[, "sigma^2"] == 0)){ # check for fixed dispersion X <- X[, names != "sigma^2", drop=FALSE] names <- names[names != "sigma^2"] nplots <- nplots - 1 } } op <- par(mfrow=c(nplots, 1), mar=c(1, 4, 0, 2) + .0, mgp=c(2, 1, 0), oma=c(6, 0, 6, 0)) on.exit(par(op)) for (j in 1:nplots){ plotnum <- plotnum + 1 plot(xaxis, X[, j], type="n", ylab=names[j], xlab="", xaxt="n", tck=0.1, ...) if(grid){ grid(lty=1, equilogs=FALSE) box()} points(xaxis, X[, j], type="h", ...) #} points(xaxis, X[, j], type="p", ...) abline(h=0, lty=2 ) axis(1, labels= ifelse(plotnum < nplots, FALSE, TRUE)) showLabels(xaxis, X[, j], labels=labels, method=id.method, n=id.n, cex=id.cex, col=id.col, location=id.location) } mtext(side=3, outer=TRUE ,main, cex=1.2, line=1) mtext(side=1, outer=TRUE, paste0("Index(", model$groups, ")"), line=3) invisible() } car/R/invResPlot.R0000644000176000001440000000345414140261763013512 0ustar ripleyusers# Last modified 25 Nov 2009 for point marking # 18 January 2012 added robust estimation from Pendergast and Sheather # 25 April 2016 check na.action for compatibility with Rcmdr # 2017-02-13: modified to use id arg in calls to invTranPlot(). J. Fox # 2017-11-30: substitute carPalette() for palette(). J. Fox # 2019-05-16: make sure that xlab arg is properly passed to invTranPlot(). J. Fox # 2019-11-14: change class(x) == "y" to inherits(x, "y") inverseResponsePlot <- function(model, lambda=c(-1, 0, 1), robust=FALSE, xlab=NULL, ...) UseMethod("inverseResponsePlot") invResPlot <- function(model, ...) UseMethod("inverseResponsePlot") inverseResponsePlot.lm <- function(model, lambda=c(-1, 0, 1), robust=FALSE, xlab=NULL, id=FALSE, ...) { if(inherits(model$na.action, "exclude")) model <- update(model, na.action=na.omit) id <- applyDefaults(id, defaults=list(method="x", n=2, cex=1, col=carPalette()[1], location="lr"), type="id") if (isFALSE(id)){ id.n <- 0 id.method <- "none" labels <- id.cex <- id.col <- id.location <- NULL } else{ labels <- id$labels if (is.null(labels)) labels <- names(residuals(model)) id.method <- id$method id.n <- if ("identify" %in% id.method) Inf else id$n id.cex <- id$cex id.col <- id$col id.location <- id$location } if(robust == TRUE){ m <- model$call m[[1L]] <- as.name("rlm") model <- eval(m, parent.frame()) } mf <- model$model if (is.null(mf)) mf <- update(model, model=TRUE, method="model.frame") if (is.null(xlab)) xlab <- names(mf)[1] else force(xlab) y <- mf[, 1] yhat <- predict(model) invTranPlot(y, yhat, lambda=lambda, xlab=xlab, robust=robust, id=list(n=id.n, method=id.method, labels=labels, cex=id.cex, col=id.col, location=id.location), ...) } car/R/deltaMethod.R0000644000176000001440000001606114140261763013635 0ustar ripleyusers#------------------------------------------------------------------------------- # Revision history: # 2009-10-29: renamed var argument to .vcov; tidied code. John # 2010-07-02; added method for survreg and coxph objects. # 2010-07-02; rewrote default method to permit parameter names to have # meta-characters # 2011-07028 Removed meta-character checks; removed parameterPrefix because # it didn't work and caused problems; added parameterNames to restore the # utility of parameterPrefix # 2011-10-02 Fixed bugs in the .survreg and .coxph methods so parameterNames # works correctly # 2012-03-02: fixed abbreviation of envir argument. J. Fox # 2012-04-08: modfied deltaMethod.default() to use coef and vcov # 2012-12-10: removed the 'deltaMethodMessageFlag' # 2013-06-20: added deltaMethod.merMod(). J. Fox # 2013-06-20: tweaks for lme4. J. Fox # 2013-07-01: New 'constants' argument for use when called from within a function. # 2013-07-18: fixed a bug in passing the 'func' argument # 2016-03-31: added level argument and report CIs. J. Fox # 2017-11-09: made compatible with vcov() in R 2.5.0. J. Fox # 2017-11-29: further fixes for vcov() and vcov.(). J. Fox # 2017-12-01: fix bug in handling vcov. arg in some methods. J. Fox # 2019-01-16: changed g arg to g. to allow variable named "g". J. Fox # 2019-06-03: introduction of environment to hold coefficients and constants. Pavel Krivitsky # 2019-06-05: option for hypothesis test. J. Fox # 2019-06-07: move handling intercepts to default method, suggestion of Pavel Krivitsky. J. Fox # 2020-05-27: fix to deltaMethod.survreg() to handle Log(scale) parameter. J. Fox # 2020-09-02: Correct bug when using parameter name "(Intercept)". SW # 2020-12-15: added error checking to vcov using getVcov #------------------------------------------------------------------------------- deltaMethod <- function (object, ...) { UseMethod("deltaMethod") } deltaMethod.default <- function (object, g., vcov., func = g., constants, level=0.95, rhs=NULL, ..., envir=parent.frame()) { if (!is.character(g.)) stop("The argument 'g.' must be a character string") if ((exists.method("coef", object, default=FALSE) || (!is.atomic(object) && !is.null(object$coefficients))) && exists.method("vcov", object, default=FALSE)){ if (missing(vcov.)) vcov. <- vcov(object, complete=FALSE) object <- coef(object) } para <- object para.names <- names(para) para.names[1] <- gsub("\\(Intercept\\)", "Intercept", para.names[1]) g. <- parse(text = gsub("\\(Intercept\\)", "Intercept", g.)) q <- length(para) envir <- new.env(parent=envir) for (i in 1:q) { assign(para.names[i], para[i], envir) } if(!missing(constants)){ for (i in seq_along(constants)) assign(names(constants[i]), constants[[i]], envir)} est <- eval(g., envir) names(est) <- NULL gd <- rep(0, q) for (i in 1:q) { gd[i] <- eval(D(g., para.names[i]), envir) } se.est <- as.vector(sqrt(t(gd) %*% vcov. %*% gd)) result <- data.frame(Estimate = est, SE = se.est, row.names = c(func)) p <- (1 - level)/2 z <- - qnorm(p) lower <- est - z*se.est upper <- est + z*se.est pct <- paste(format(100*c(p, 1 - p), trim=TRUE, scientific=FALSE, digits=3), "%") result <- cbind(result, lower, upper) names(result)[3:4] <- pct if (!is.null(rhs)){ z <- (est - rhs)/se.est p <- 2*(pnorm(abs(z), lower.tail=FALSE)) result <- cbind(result, "Hypothesis"=rhs, "z value"=z, "Pr(>|z|)"=p) } class(result) <- c("deltaMethod", class(result)) result } print.deltaMethod <- function(x, ...){ if (ncol(x) == 3) print(x, ...) else printCoefmat(x, ...) invisible(x) } deltaMethod.lm <- function (object, g., vcov. = vcov(object, complete=FALSE), parameterNames = names(coef(object)), ..., envir=parent.frame()) { para <- coef(object) para.names <- parameterNames names(para) <- para.names vcov. <- getVcov(vcov., object) deltaMethod.default(para, g., vcov., ..., envir=envir) } # nls has named parameters so parameterNames is ignored deltaMethod.nls <- function(object, g., vcov.=vcov(object, complete=FALSE), ..., envir=parent.frame()){ vcov. <- getVcov(vcov., object) deltaMethod.default(coef(object), g., vcov., ..., envir=envir) } deltaMethod.polr <- function(object,g.,vcov.=vcov(object, complete=FALSE), ..., envir=parent.frame()){ sel <- 1:(length(coef(object))) vcov. <- getVcov(vcov., object)[sel, sel] # vcov. <- if(is.function(vcov.)) vcov.(object)[sel, sel] else vcov.[sel, sel] deltaMethod.lm(object, g., vcov., ..., envir=envir) } deltaMethod.multinom <- function(object, g., vcov.=vcov(object, complete=FALSE), parameterNames = if(is.matrix(coef(object))) colnames(coef(object)) else names(coef(object)), ..., envir=parent.frame()){ vcov. <- getVcov(vcov., object) # vcov. <- if(is.function(vcov.)) vcov.(object) else vcov. out <- NULL coefs <- coef(object) if (!is.matrix(coefs)) { coefs <- t(as.matrix(coefs)) } colnames(coefs) <- parameterNames nc <- dim(coefs)[2] for (i in 1:dim(coefs)[1]){ para <- coefs[i, ] ans <- deltaMethod(para, g., vcov.[(i - 1) + 1:nc, (i - 1) + 1:nc], ..., envir=envir) rownames(ans)[1] <- paste(rownames(coefs)[i], rownames(ans)[1]) out <- rbind(out,ans) } out} # method for survreg objects. deltaMethod.survreg <- function(object, g., vcov. = vcov(object, complete=FALSE), parameterNames = names(coef(object)), ..., envir=parent.frame()) { if (length(parameterNames != nrow(vcov.))){ p <- which(rownames(vcov.) == "Log(scale)") if (length(p) > 0) vcov. <- vcov.[-p, -p] } deltaMethod.lm(object, g., vcov., parameterNames , ..., envir=envir) } # method for coxph objects. deltaMethod.coxph <- function(object, g., vcov. = vcov(object, complete=FALSE), parameterNames = names(coef(object)), ..., envir=parent.frame()) { deltaMethod.lm(object, g., vcov., parameterNames, ..., envir=envir) } # lmer deltaMethod.merMod <- function(object, g., vcov. = vcov(object, complete=FALSE), parameterNames = names(fixef(object)), ..., envir=parent.frame()) { deltaMethod.mer(object=object, g.=g., vcov.=vcov, parameterNames=parameterNames, ..., envir=envir) } deltaMethod.mer <- function(object, g., vcov. = vcov(object, complete=FALSE), parameterNames = names(fixef(object)), ..., envir=parent.frame()) { para <- fixef(object) names(para) = parameterNames vcov. <- getVcov(vcov., object) # vcov. <- if (is.function(vcov.)) # vcov.(object) # else vcov. deltaMethod(para, g., vcov., ..., envir=envir) } #lme deltaMethod.lme <- function(object, g., vcov. = vcov(object, complete=FALSE), parameterNames = names(fixef(object)), ..., envir=parent.frame()) { para <- fixef(object) names(para) = parameterNames vcov. <- getVcov(vcov., object) # vcov. <- if (is.function(vcov.)) # vcov.(object) # else vcov. deltaMethod(para, g., vcov., ..., envir=envir) } # nlsList lsList deltaMethod.lmList <- function(object, g., ..., envir=parent.frame()) { out <- t(sapply(object, function(x) deltaMethod(x, g., ..., envir=envir))) rownames(out) <- paste(rownames(out), g.) out } car/R/scatterplot.R0000644000176000001440000003520414140261763013747 0ustar ripleyusers# fancy scatterplots (J. Fox) # 2010-09-05: J. Fox: changed color choice # 2010-09-16: fixed point color when col is length 1 # 2010-12-19: J. Fox: added argument legend.coords to place legend. # 2011-01-15: J. Fox: If x is a factor, calls Boxplot() # 2011-03-08: J. Fox: changed col argument # 2012-04-18: J. Fox: fixed labels argument in scatterplot.formula(). # 2012-04-24: J. Fox: further fix to labels # 2012-09-12: J. Fox: modified treatment of smoother; added loessLine(), gamLine(), quantregLine(). # 2012-09-17: S. Weisberg: smoothers moved to scatterplotSmoothers.R, defaults changed # 2012-09-19: J. Fox: restored smooth and span arguments for backwards compatibility # 2013-02-07: S. Weisberg: modifed call to showLabels to work correctly with groups # 2014-09-04: J. Fox: empty groups produce warning rather than error # 2015-07-17: J. Fox: improved above-plot legends. # 2015-08-05: J. Fox: fixed sp() # 2017-01-09: J. Fox: consolidated many arguments into id, smooth, and legend; # 2017-02-09: J. Fox: consolidated ellipse arguments; small fixes. # 2017-02-17: S. Weisberg: removed many arguments that can be passed via other argument or ... # 2017-02-22: J. Fox: improvement to col argument # 2017-02-28: S. Weisberg: showLabels bug-fix. # 2016-02-28: S. Weisberg: added cex arg to the legend # 2017-04-14: S. Weisberg: changed default colors so points and corresponding lines always have same color # 2017-05-08: S. Weisberg changed col=carPalette() # 2017-11-30: substitute carPalette() for palette(). J. Fox # 2017-12-07: J. Fox: added fill, fill.alpha subargs to ellipse arg, suggestion of Michael Friendly. # 2018-03-23: J. Fox: fix ellipses when log-axes used by groups; fix interactive point identification by groups. # 2018-04-02: J. Fox: warning rather than error for too few colors. # 2018-04-12: J. Fox: fixed error produced when groups not a factor, reported by Alexandre Courtiol. # 2018-05-19: J. Fox: fixed bug when legend=FALSE, reported by Castor Guisande. # 2018-06-25: S. Weisberg made the argument 'var' an alias of 'spread' # 2019-01-15: J. Fox: make scatterplot.formula() more robust # 2020-05-03: J. Fox: make marginal boxplots work with xlim and ylim (problem reported by Yousri Fanous) # 2021-04-05: J. Fox: don't explicitly dispatch on argument x in generic reg <- function(reg.line, x, y, col, lwd, lty, log.x, log.y){ if(log.x) x <- log(x) if(log.y) y <- log(y) mod <- reg.line(y ~ x) y.hat <- fitted.values(mod) x <- model.matrix(mod)[, 2] min <- which.min(x) max <- which.max(x) if (!log.x){ x1 <- x[min] x2 <- x[max] } else { x1 <- exp(x[min]) x2 <- exp(x[max]) } if (!log.y){ y1 <- y.hat[min] y2 <- y.hat[max] } else { y1 <- exp(y.hat[min]) y2 <- exp(y.hat[max]) } lines(c(x1, x2), c(y1, y2), lwd=lwd, col=col, lty=lty) } find.legend.columns <- function(n, target=min(4, n)){ rem <- n %% target if (rem != 0 && rem < target/2) target <- target - 1 target } scatterplot <- function(x, ...){ UseMethod("scatterplot") } scatterplot.formula <- function (formula, data, subset, xlab, ylab, id=FALSE, legend=TRUE, ...) { na.save <- options(na.action=na.omit) on.exit(options(na.save)) na.pass <- function(dframe) dframe id <- if (is.logical(id)){ if (isTRUE(id)) list() else FALSE } else as.list(id) legend <- applyDefaults(legend, defaults=list(), type="legend") m <- match.call(expand.dots=FALSE) if (is.matrix(eval(m$data, sys.frame(sys.parent())))) m$data <- as.data.frame(data) m$na.action <- na.pass m$legend <- m$id <- m$xlab <- m$ylab <- m$... <- NULL m[[1]] <- as.name("model.frame") if (!inherits(formula, "formula") | length(formula) != 3) stop("invalid formula") formula <- as.character(c(formula)) formula <- as.formula(sub("\\|", "+", formula)) m$formula <- formula if (missing(data)){ X <- na.omit(eval(m, parent.frame())) if (!isFALSE(id) && is.null(id$labels)) id$labels <- gsub("X", "", row.names(X)) if (is.factor(X[, 2]) && !is.list(id)) id <- list(labels=gsub("X", "", row.names(X))) } else{ X <- eval(m, parent.frame()) if (!isFALSE(id) && is.null(id$labels)) id$labels <- row.names(X) if (is.factor(X[, 2]) && !is.list(id)) id <- list(labels=row.names(X)) } names <- names(X) if (missing(xlab)) xlab <- names[2] if (missing(ylab)) ylab <- names[1] X[, 1] <- as.vector(X[, 1]) if (!is.factor(X[, 2])) X[, 2] <- as.vector(X[, 2]) if (ncol(X) == 2) scatterplot(X[,2], X[,1], xlab=xlab, ylab=ylab, id=id, ...) else { if (!isFALSE(legend)){ if (is.null(legend$title)) legend$title <- names[3] } scatterplot(X[,2], X[,1], groups=X[,3], xlab=xlab, ylab=ylab, legend=legend, id=id, ...) } } scatterplot.default <- function(x, y, boxplots=if (by.groups) "" else "xy", regLine=TRUE, legend=TRUE, id=FALSE, ellipse=FALSE, grid=TRUE, smooth=TRUE, groups, by.groups=!missing(groups), xlab=deparse(substitute(x)), ylab=deparse(substitute(y)), log="", jitter=list(), cex=par("cex"), col=carPalette()[-1], pch=1:n.groups, reset.par=TRUE, ...){ force(col) dots <- list(...) xlim <- dots$xlim ylim <- dots$ylim id <- applyDefaults(id, defaults=list(method="mahal", n=2, cex=1, col=carPalette()[-1], location="lr"), type="id") legend <- applyDefaults(legend, defaults=list(title=deparse(substitute(groups)), inset=0.02, cex=1)) legend.plot <- !(isFALSE(legend) || missing(groups)) if (legend.plot){ legend.title <- legend$title legend.cex <- legend$cex } if (isFALSE(id)){ id.n <- 0 id.method <- "mahal" labels <- id.cex <- id.col <- id.location <- NULL } else{ labels <- id$labels id.method <- id$method id.n <- if ("identify" %in% id.method) Inf else id$n id.cex <- id$cex id.col <- if (by.groups) id$col else id$col[1] id.location <- id$location } smoother.args <- applyDefaults(smooth, defaults=list(smoother=loessLine, spread=!by.groups, lty.smooth=2, lty.spread=4), type="smooth") if (!isFALSE(smoother.args)) { # check for an argument 'var' in smoother.args. if(!is.null(smoother.args$var)) smoother.args$spread <- smoother.args$var # end change smoother <- smoother.args$smoother spread <- if(is.null(smoother.args$spread)) TRUE else smoother.args$spread smoother.args$smoother <- NULL } else smoother <- "none" ellipse.args <- applyDefaults(ellipse, defaults=list(levels=c(.5, .95), robust=TRUE, fill=TRUE, fill.alpha=0.2, type="ellipse")) if (!is.logical(ellipse)) ellipse <- TRUE if (!isFALSE(ellipse.args)){ levels <- ellipse.args$levels robust <- ellipse.args$robust fill <- ellipse.args$fill fill.alpha <- ellipse.args$fill.alpha } n.groups <- if (by.groups) { if (!is.factor(groups)) groups <- as.factor(groups) length(levels(groups)) } else 1 regLine.args <- applyDefaults(regLine, defaults=list(method=lm, lty=1, lwd=2, col=rep(col, n.groups), type="regLine")) if(!isFALSE(regLine.args)) { if(length(regLine.args$col) < n.groups){ regLine.args$col <- rep(regLine.args$col, n.groups) } } logged <- function(axis=c("x", "y")){ axis <- match.arg(axis) 0 != length(grep(axis, log)) } hbox <- function(x){ if (logged("x")){ log.x <- "x" .x <- log(x) } else { log.x <- "" .x <- x } plot(x, seq(0, 1, length=length(x)), type="n", axes=FALSE, xlab="", ylab="", log=log.x, xlim=xlim) res <- boxplot.stats(.x, coef = 1.5, do.conf=FALSE) if (logged("x")){ res$stats <- exp(res$stats) if (!is.null(res$out)) res$out <- exp(res$out) } LW <- res$stats[1] Q1 <- res$stats[2] M <- res$stats[3] Q3 <- res$stats[4] UW <- res$stats[5] lines(c(Q1, Q1, Q3, Q3, Q1), c(0, 1, 1, 0, 0)) lines(c(M, M), c(0, 1)) lines(c(LW, Q1), c(.5, .5)) lines(c(Q3, UW), c(.5, .5)) if (!is.null(res$out)) points(res$out, rep(.5, length(res$out)), cex=cex) } vbox <- function(y){ if (logged("y")){ log.y <- "y" .y <- log(y) } else { log.y <- "" .y <- y } plot(seq(0, 1, length=length(y)), y, type="n", axes=FALSE, xlab="", ylab="", log=log.y, ylim=ylim) res <- boxplot.stats(.y, coef = 1.5, do.conf=FALSE) if (logged("y")){ res$stats <- exp(res$stats) if (!is.null(res$out)) res$out <- exp(res$out) } LW <- res$stats[1] Q1 <- res$stats[2] M <- res$stats[3] Q3 <- res$stats[4] UW <- res$stats[5] lines(c(0, 1, 1, 0, 0), c(Q1, Q1, Q3, Q3, Q1)) lines(c(0, 1), c(M, M)) lines(c(.5, .5), c(LW, Q1)) lines(c(.5, .5), c(Q3, UW)) if (!is.null(res$out)) points(rep(.5, length(res$out)), res$out, cex=cex) } # force(by.groups) id <- as.list(id) if (is.null(labels)){ labels <- if (is.null(names(y))) seq(along=y) else names(y) } if (length(labels) != length(y)) stop("labels argument is the wrong length") if (is.factor(x)) { if (!(id.method %in% c("y", "identify", "none"))) id.method <- "y" return(Boxplot(y, x, id.method="y", labels=labels, xlab=xlab, ylab=ylab)) } mar <- par("mar") mfcol <- par("mfcol") if (reset.par) on.exit(par(mar=mar, mfcol=mfcol)) if( FALSE == boxplots) boxplots <- "" if (!missing(groups)){ data <- na.omit(data.frame(groups, x, y, labels, stringsAsFactors=FALSE)) groups <- data[ , 1] # if (!is.factor(groups)) groups <- as.factor(groups) .x <- data[,2] .y <- data[,3] labels <- data[,4] legend.columns <- if (legend.plot) legend$columns else 0 top <- if (legend.plot && is.null(legend$coords)){ if (is.null(legend.columns)) legend.columns <- find.legend.columns(nlevels(groups)) 4 + ceiling(nlevels(groups))/legend.columns } else mar[3] if (legend.plot && !is.null(legend$coords) && is.null(legend.columns)){ legend.columns <- 1 } } else { .x <- x .y <- y top <- mar[3] groups <- factor(rep(1, length(.x))) } xbox <- length(grep("x", boxplots)) > 0 ybox <- length(grep("y", boxplots)) > 0 if (xbox && ybox) layout(matrix(c(1, 0, 3, 2), 2, 2), widths = c(5, 95), heights= c(95, 5)) else if (ybox) layout(matrix(c(1, 2),1, 2), widths = c(5, 95), heights= 100) else if (xbox) layout(matrix(c(2, 1), 2, 1), widths = 100, heights= c(95, 5)) else layout (matrix(1, 1, 1), widths=100, heights=100) par(mar=c(mar[1], 0, top, 0)) if (ybox > 0) vbox(.y) par(mar=c(0, mar[2], 0, mar[4])) if (xbox > 0) hbox(.x) par(mar=c(mar[1:2], top, mar[4])) plot(.x, .y, xlab=xlab, ylab=ylab, log=log, cex=cex, type="n", ...) if(grid){ grid(lty=1, equilogs=FALSE) box()} if (n.groups > length(col)) { warning("number of groups exceeds number of available colors\n colors are recycled") col <- rep(col, n.groups) } if (length(col) == 1) col <- rep(col, 3) indices <- NULL range.x <- if (logged("x")) range(log(.x), na.rm=TRUE) else range(.x, na.rm=TRUE) counts <- table(groups) if (any(counts == 0)){ levels <- levels(groups) warning("the following groups are empty: ", paste(levels[counts == 0], collapse=", ")) } for (i in 1:n.groups){ if (counts[i] == 0) next subs <- groups == levels(groups)[i] points(if (is.null(jitter$x) || jitter$x == 0) .x[subs] else jitter(.x[subs], factor=jitter$x), if (is.null(jitter$y) || jitter$y == 0) .y[subs] else jitter(.y[subs], factor=jitter$y), pch=pch[i], col=col[if (n.groups == 1) 1 else i], cex=cex) if (by.groups){ if (is.function(smoother)) smoother(.x[subs], .y[subs], col=col[i], log.x=logged("x"), log.y=logged("y"), spread=spread, smoother.args=smoother.args) if (!isFALSE(regLine.args)) reg(regLine.args$method, .x[subs], .y[subs], lty=regLine.args$lty, lwd=regLine.args$lwd, log.x=logged("x"), log.y=logged("y"), col= regLine.args$col[i]) if (ellipse) { X <- na.omit(data.frame(x=.x[subs], y=.y[subs])) if (logged("x")) X$x <- log(X$x) if (logged("y")) X$y <- log(X$y) with(X, dataEllipse(x, y, plot.points=FALSE, lwd=1, log=log, levels=levels, col=col[i], robust=robust, fill=fill, fill.alpha=fill.alpha)) } if (id.method[1] != "identify") indices <- c(indices, showLabels(.x[subs], .y[subs], labels=labels[subs], method=id.method, n=id.n, cex=id.cex, col=col[i], location=id.location, all=list(labels=labels, subs=subs))) }} if (!by.groups){ if (is.function(smoother)) smoother(.x, .y, col=col[1], log.x=logged("x"), log.y=logged("y"), spread, smoother.args=smoother.args) if (!isFALSE(regLine.args)) reg(regLine.args$method, .x, .y, lty=regLine.args$lty, lwd=regLine.args$lwd, log.x=logged("x"), log.y=logged("y"), col=regLine.args$col[1]) if (ellipse) { X <- na.omit(data.frame(x=.x, y=.y)) if (logged("x")) X$x <- log(X$x) if (logged("y")) X$y <- log(X$y) with(X, dataEllipse(x, y, plot.points=FALSE, lwd=1, log=log, levels=levels, col=col[1], robust=robust, fill=fill, fill.alpha=fill.alpha)) } if (id.method[1] != "identify") indices <- showLabels( .x, .y, labels=labels, method=id.method, n=id.n, cex=id.cex, col=id.col, location=id.location) } if (legend.plot) { xpd <- par(xpd=TRUE) on.exit(par(xpd=xpd), add=TRUE) usr <- par("usr") legend.coords <- if (is.null(legend$coords)){ legend.x <- if (logged("x")) 10^(usr[1]) else usr[1] legend.y <- if (logged("y")) 10^(usr[4] + 1.2*top*strheight("x")) else usr[4] + 1.2*top*strheight("x") list(x=legend.x, y=legend.y) } else legend$coords legend(legend.coords, legend=levels(groups)[counts > 0], pch=pch[counts > 0], col=col[1:n.groups][counts > 0], cex=legend.cex, #pt.cex=cex, cex=cex, #cex=cex.lab, title=legend.title, bg="white", ncol=legend.columns, inset=legend$inset) } if (id.method[1] == "identify") indices <- showLabels(.x, .y, labels, method=id.method, n=length(.x), cex=id.cex, col="black", id.location=id.location) if (is.null(indices)) invisible(indices) else if (is.numeric(indices)) sort(indices) else indices } sp <- function(x, ...) UseMethod("scatterplot") car/R/mcPlots.R0000644000176000001440000002126414140261763013025 0ustar ripleyusers# October 1, 2014 mcPlots, by S. Weisberg and J. Fox # 'mc' stands for Marginal and Conditional: for the specified regressor X in model # The 'marginal' plot is of Y vs X with Y and X both centered # The 'conditional plot is the added-variable plot e(Y|rest) vs e(X|rest) # If 'overlaid=TRUE', the default, both plots are overlayed # If 'overlaid=FALSE', then the plots are side-by-side # The 'overlaid' plot is similar to the initial and final frame of an ARES plot # Cook and Weisberg (1989), "Regression diagnostics with dynamic graphics", Technometrics, 31, 277. # This plot would benefit from animation. # 2017-02-13: consolidated id and ellipse arguments. J. Fox # 2017-11-30: substitute carPalette() for palette(). J. Fox # 2018-12-17: added title argument, if title=FALSE, suppress unchangable main= arguments # 2018-07-13: made mcPlots() generic. J. Fox # 2021-04-28: added pt.wts and cex args. J. Fox mcPlots <- function(model, ...){ UseMethod("mcPlots") } mcPlots.default <- function(model, terms=~., layout=NULL, ask, overlaid=TRUE, ...){ terms <- if(is.character(terms)) paste("~",terms) else terms vform <- update(formula(model),terms) if(any(is.na(match(all.vars(vform), all.vars(formula(model)))))) stop("Only predictors in the formula can be plotted.") terms.model <- attr(attr(model.frame(model), "terms"), "term.labels") terms.vform <- attr(terms(vform), "term.labels") terms.used <- match(terms.vform, terms.model) mm <- model.matrix(model) model.names <- attributes(mm)$dimnames[[2]] model.assign <- attributes(mm)$assign good <- model.names[!is.na(match(model.assign, terms.used))] # if (intercept) good <- c("(Intercept)", good) if(attr(attr(model.frame(model), "terms"), "intercept") == 0) stop("Error---the 'lm' object must have an intercept") nt <- length(good) if (nt == 0) stop("No plots specified") if(overlaid){ if (nt > 1 & (is.null(layout) || is.numeric(layout))) { if(is.null(layout)){ layout <- switch(min(nt, 9), c(1, 1), c(1, 2), c(2, 2), c(2, 2), c(3, 2), c(3, 2), c(3, 3), c(3, 3), c(3, 3)) } ask <- if(missing(ask) || is.null(ask)) prod(layout)= 1 & (is.null(layout) || is.numeric(layout))) { if(is.null(layout)){ layout <- switch(min(nt, 4), c(1, 2), c(2, 2), c(3, 2), c(4, 2)) } ask <- if(missing(ask) || is.null(ask)) layout[1] < nt else ask op <- par(mfrow=layout, ask=ask, no.readonly=TRUE, oma=c(0, 0, 1.5, 0), mar=c(5, 4, 1, 2) + .1) on.exit(par(op)) } } for (term in good) mcPlot(model, term, new=FALSE, overlaid=overlaid, ...) # mtext(side=3,outer=TRUE,main, cex=1.2) } mcPlot <- function(model, ...) UseMethod("mcPlot") mcPlot.lm <- function(model, variable, id=FALSE, col.marginal=carPalette()[2], col.conditional=carPalette()[3], col.arrows="gray", pch = c(16,1), cex=par("cex"), pt.wts=FALSE, lwd = 2, grid=TRUE, ellipse=FALSE, overlaid=TRUE, new=TRUE, title=TRUE, ...){ id <- applyDefaults(id, defaults=list(method=list(abs(residuals(model, type="pearson")), "x"), n=2, cex=1, col=carPalette()[1], location="lr"), type="id") if (isFALSE(id)){ id.n <- 0 id.method <- "none" labels <- id.cex <- id.col <- id.location <- NULL } else{ labels <- id$labels if (is.null(labels)) labels <- names(na.omit(residuals(model))) id.method <- id$method id.n <- if ("identify" %in% id.method) Inf else id$n id.cex <- id$cex id.col <- id$col id.location <- id$location } ellipse.args <- applyDefaults(ellipse, defaults=list(levels=0.5)) if (!isFALSE(ellipse)) ellipse <- TRUE variable <- if (is.character(variable) & 1 == length(variable)) variable else deparse(substitute(variable)) if(new && !overlaid) { op <- par(mfrow=c(1,2)) on.exit(par(op)) } # if(missing(labels)) # labels <- names(residuals(model)[!is.na(residuals(model))]) else deparse(substitute(variable)) if(attr(attr(model.frame(model), "terms"), "intercept") == 0) stop("Error---the 'lm' object must have an intercept") mod.mat <- model.matrix(model) var.names <- colnames(mod.mat) var <- which(variable == var.names) if (0 == length(var)) stop(paste(variable, "is not a column of the model matrix.")) response <- response(model) responseName <- responseName(model) if (is.null(weights(model))) wt <- rep(1, length(response)) else wt <- weights(model) res0 <- lm(cbind(mod.mat[, var], response) ~ 1, weights=wt)$residual res <- lsfit(mod.mat[, -var], cbind(mod.mat[, var], response), wt = wt, intercept = FALSE)$residuals w <- if (pt.wts){ w <- sqrt(wt) cex*w/mean(w) } else cex xlab <- paste(var.names[var], "| others") ylab <- paste(responseName, " | others") xlm <- c( min(res0[, 1], res[, 1]), max(res0[, 1], res[, 1])) ylm <- c( min(res0[, 2], res[, 2]), max(res0[, 2], res[, 2])) if(overlaid){ mn <- if(title) paste("Marginal/Conditional plot of", var.names[var]) else NULL plot(res[, 1], res[, 2], xlab = xlab, ylab = ylab, type="n", main=mn, xlim=xlm, ylim=ylm, ...) if(grid){ grid(lty=1, equilogs=FALSE) box()} points(res0[, 1], res0[, 2], pch=pch[1], col=col.marginal, cex=w) points(res[, 1], res[, 2], col=col.conditional, pch=pch[2], cex=w, ...) arrows(res0[, 1], res0[, 2], res[, 1], res[, 2], length=0.125, col=col.arrows) abline(lsfit(res0[, 1], res0[, 2], wt = wt), col = col.marginal, lwd = lwd) abline(lsfit(res[, 1], res[, 2], wt = wt), col = col.conditional, lwd = lwd) if (ellipse) { ellipse.args1 <- c(list(res0, add=TRUE, plot.points=FALSE, col=col.marginal), ellipse.args) do.call(dataEllipse, ellipse.args1) ellipse.args1 <- c(list(res, add=TRUE, plot.points=FALSE, col=col.conditional), ellipse.args) do.call(dataEllipse, ellipse.args1) } showLabels(res0[, 1], res0[, 2], labels=labels, method=id.method, n=id.n, cex=id.cex, col=id.col, location=id.location) colnames(res) <- c(var.names[var], responseName) rownames(res) <- rownames(mod.mat) invisible(res)} else { # side.by.side plots mn <- if(title) paste("Marginal plot of", var.names[var]) else NULL plot(res0[, 1], res0[, 2], type="n", xlab = paste("Centered", var.names[var], sep=" "), ylab = paste("Centered", responseName, sep=" "), main=mn, xlim=xlm, ylim=ylm, ...) if(grid){ grid(lty=1, equilogs=FALSE) box()} points(res0[, 1], res0[, 2], pch=pch[1], col=col.marginal, cex=w) abline(lsfit(res0[, 1], res0[, 2], wt = wt), col = col.marginal, lwd = lwd) if (ellipse) { ellipse.args1 <- c(list(res0, add=TRUE, plot.points=FALSE, col=col.marginal), ellipse.args) do.call(dataEllipse, ellipse.args1) } showLabels(res0[, 1], res0[, 2], labels=labels, method=id.method, n=id.n, cex=id.cex, col=id.col, location=id.location) colnames(res) <- c(var.names[var], responseName) rownames(res) <- rownames(mod.mat) mn <- if(title) paste("Added-Variable plot of", var.names[var]) else NULL plot(res[, 1], res[, 2], xlab = xlab, ylab = ylab, type="n", main=mn, xlim=xlm, ylim=ylm, ...) if(grid){ grid(lty=1, equilogs=FALSE) box()} points(res[, 1], res[, 2], col=col.conditional, pch=pch[2], cex=w, ...) abline(lsfit(res[, 1], res[, 2], wt = wt), col = col.conditional, lwd = lwd) if (ellipse) { ellipse.args1 <- c(list(res, add=TRUE, plot.points=FALSE, col=col.conditional), ellipse.args) do.call(dataEllipse, ellipse.args1) } showLabels(res[, 1], res[, 2], labels=labels, method=id.method, n=id.n, cex=id.cex, col=id.col, location=id.location) invisible(res)} } mcPlot.glm <- function(model, ...){ stop("marginal-conditional plots are not available for 'glm' objects;\n", " consider using avPlot()") } car/R/car-deprecated.R0000644000176000001440000000534514140261763014251 0ustar ripleyusers# March 9, 2012 modified by SW as suggested by Derek Ogle to return an object # of class c("bootCase", "matrix"). # May 2012 added methods for 'bootCase' # 2012-12-10 replaced .GlobalEnv by car:::.carEnv to suppress warnings # 2013-01-28 Changed argument f to f. # 2013-07-08 Changed .carEnv to car:::.carEnv # 2015-01-27 .carEnv now in global environment. John # 2018-02-19 these functions now deprecated nextBoot <- function(...){ .Deprecated("Boot", package="car") UseMethod("nextBoot") } nextBoot.default <- function(object, sample, ...){ update(object, subset=sample) } nextBoot.lm <- function(object, sample, ...) nextBoot.default(object, sample) nextBoot.nls <- function(object, sample, ...){ # modify to assure resampling only rows in the original subset 9/1/2005 update(object,subset=sample,start=coef(object), data=data.frame(update(object,model=TRUE)$model))} bootCase <- function(...){ .Deprecated("Boot", package="car") UseMethod("bootCase") } bootCase.lm <- function(object, f.=coef, B=999, ...) { bootCase.default(object, f., B, names(resid(object))) # bootCase.default(update(object, # data=na.omit(model.frame(object))), f, B) } bootCase.glm <- function(object, f.=coef, B=999, ...) { bootCase.lm(object, f., B) } bootCase.nls <- function(object, f.=coef, B=999, ...) { bootCase.default(object, f., B, seq(length(resid(object)))) } bootCase.default <- function (object, f.=coef, B = 999, rows, ...) { n <- length(resid(object)) opt<-options(show.error.messages = FALSE) on.exit(options(opt)) pointEstimate <- f.(object) coefBoot <- matrix(0, nrow=B, ncol=length(f.(object))) colnames(coefBoot) <- names(pointEstimate) # adds names if they exist class(coefBoot) <- c("bootCase", "matrix") count.error <- 0 i <- 0 while (i < B) { assign(".boot.sample", sample(rows, replace=TRUE), envir=.carEnv) obj.boot <- try(update(object, subset=get(".boot.sample", envir=.carEnv))) if (is.null(class(obj.boot))) { count.error <- 0 i <- i + 1 coefBoot[i, ] <- f.(obj.boot) } else { if (class(obj.boot)[1] != "try-error") { count.error <- 0 i <- i + 1 coefBoot[i, ] <- f.(obj.boot) } else { count.error <- count.error + 1 } } if (count.error >= 25) { options(show.error.messages = TRUE) stop("25 consecutive bootstraps did not converge. Bailing out.")} } remove(".boot.sample", envir=.carEnv) attr(coefBoot, "pointEstimate") <- pointEstimate return(coefBoot) } car/R/leveneTest.R0000644000176000001440000000333314140261763013517 0ustar ripleyusers# moved from Rcmdr 13 July 2004 # levene.test.default function slightly modified and generalized from Brian Ripley via R-help # the original generic version was contributed by Derek Ogle # last modified 2019-02-01 by J. Fox leveneTest <- function (y, ...) { UseMethod("leveneTest") } leveneTest.default <- function (y, group, center=median, ...) { # original levene.test if (!is.numeric(y)) stop(deparse(substitute(y)), " is not a numeric variable") if (!is.factor(group)) { warning(deparse(substitute(group)), " coerced to factor.") group <- as.factor(group) } valid <- complete.cases(y, group) meds <- tapply(y[valid], group[valid], center, ...) resp <- abs(y - meds[group]) table <- anova(lm(resp ~ group))[, c(1, 4, 5)] rownames(table)[2] <- " " dots <- deparse(substitute(...)) attr(table, "heading") <- paste("Levene's Test for Homogeneity of Variance (center = ", deparse(substitute(center)), if(!(dots == "NULL")) paste(":", dots), ")", sep="") table } leveneTest.formula <- function(y, data, ...) { form <- y mf <- if (missing(data)) model.frame(form) else model.frame(form, data) if (any(sapply(2:dim(mf)[2], function(j) is.numeric(mf[[j]])))) stop("Levene's test is not appropriate with quantitative explanatory variables.") y <- mf[,1] if(dim(mf)[2]==2) group <- mf[,2] else { if (length(grep("\\+ | \\| | \\^ | \\:",form))>0) stop("Model must be completely crossed formula only.") group <- interaction(mf[,2:dim(mf)[2]]) } leveneTest.default(y=y, group=group, ...) } leveneTest.lm <- function(y, ...) { m <- model.frame(y) m$..y <- model.response(m) f <- formula(y) f[2] <- expression(..y) leveneTest.formula(f, data=m, ...) } car/R/dfbetaPlots.R0000644000176000001440000001100614140261763013644 0ustar ripleyusers# added 13 March 2010 by J. Fox # modified 2 Sept 2010 by J. Fox, made colors, axes lables, and # arguments more consistent with other functions; ... passes args to plot # 2017-11-09: made consistent with vcov() in R 2.5.0. J. Fox # 2017-11-30: substitute carPalette() for palette(). J. Fox # 2021-08-31: fix bug in rownames in dfbetasPlots.lm() reported by Shu Fai Cheun. J. Fox dfbetasPlots <- function(model, ...){ UseMethod("dfbetasPlots") } dfbetasPlots.lm <- function(model, terms= ~ ., intercept=FALSE, layout=NULL, ask, main, xlab, ylab, labels=rownames(dfbetas), id.method="y", id.n=if(id.method[1]=="identify") Inf else 0, id.cex=1, id.col=carPalette()[1], id.location="lr", col=carPalette()[1], grid=TRUE, ...){ terms <- if(is.character(terms)) paste("~",terms) else terms vform <- update(formula(model),terms) if(any(is.na(match(all.vars(vform), all.vars(formula(model)))))) stop("Only predictors in the formula can be plotted.") terms.model <- attr(attr(model.frame(model), "terms"), "term.labels") terms.vform <- attr(terms(vform), "term.labels") terms.used <- match(terms.vform, terms.model) mm <- model.matrix(model) model.names <- attributes(mm)$dimnames[[2]] model.assign <- attributes(mm)$assign good <- model.names[!is.na(match(model.assign, terms.used))] if (intercept) good <- c("(Intercept)", good) nt <- length(good) if (nt == 0) stop("No plots specified") if (missing(main)) main <- if (nt == 1) "dfbetas Plot" else "dfbetas Plots" if (missing(xlab)) xlab <- "Index" autolabel <- missing(ylab) if (nt > 1 & (is.null(layout) || is.numeric(layout))) { if(is.null(layout)){ layout <- switch(min(nt, 9), c(1, 1), c(1, 2), c(2, 2), c(2, 2), c(3, 2), c(3, 2), c(3, 3), c(3, 3), c(3, 3)) } ask <- if(missing(ask) || is.null(ask)) prod(layout) 1 & (is.null(layout) || is.numeric(layout))) { if(is.null(layout)){ layout <- switch(min(nt, 9), c(1, 1), c(1, 2), c(2, 2), c(2, 2), c(3, 2), c(3, 2), c(3, 3), c(3, 3), c(3, 3)) } ask <- if(missing(ask) || is.null(ask)) prod(layout)|z|)", nrow(X)), rep("", nrow(X)))) colnames(Y) <- paste("Model", 1:nc) for (i in 1:nrow(X)){ count <- 1 Y[(i - 1)*(krows + 1) + count, ] <- X[i, (0:(nc - 1))*krows + count] if (se){ count <- count + 1 Y[(i - 1)*(krows + 1) + count, ] <- X[i, (0:(nc - 1))*krows + count] } if (zvals){ count <- count + 1 Y[(i - 1)*(krows + 1) + count, ] <- X[i, (0:(nc - 1))*krows + count] } if (pvals){ count <- count + 1 Y[(i - 1)*(krows + 1) + count, ] <- X[i, (0:(nc - 1))*krows + count] } } Y } splitExpr <- function(expr, width=getOption("width") - 4, at="[ ,=]"){ if (length(grep("\n", expr)) >0 ){ cmds <- strsplit(expr, "\n")[[1]] allcmds <- character(length(cmds)) for (i in 1:length(cmds)) allcmds[i] <- splitExpr(cmds[i], width=width, at=at) return(paste(allcmds, collapse="\n")) } if (nchar(expr) <= width) return(expr) where <- gregexpr(at, expr)[[1]] if (where[1] < 0) return(expr) singleQuotes <- gregexpr("'", expr)[[1]] doubleQuotes <- gregexpr('"', expr)[[1]] comment <- regexpr("#", expr) if (singleQuotes[1] > 0 && (singleQuotes[1] < doubleQuotes[1] || doubleQuotes[1] < 0 ) && (singleQuotes[1] < comment[1] || comment[1] < 0 )){ nquotes <- length(singleQuotes) if (nquotes < 2) stop("unbalanced quotes") for(i in seq(nquotes/2)) where[(where > singleQuotes[2 * i - 1]) & (where < singleQuotes[2 * i])] <- NA where <- na.omit(where) } else if (doubleQuotes[1] > 0 && (doubleQuotes[1] < singleQuotes[1] || singleQuotes[1] < 0) && (doubleQuotes[1] < comment[1] || comment[1] < 0 )){ nquotes <- length(doubleQuotes) if (nquotes < 2) stop("unbalanced quotes") for(i in seq(nquotes/2)) where[(where > doubleQuotes[2 * i - 1]) & (where < doubleQuotes[2 * i])] <- NA where <- na.omit(where) } else if (comment > 0){ where[where > comment] <- NA where <- na.omit(where) } if (length(where) == 0) return(expr) where2 <- where[where <= width] where2 <- if (length(where2) == 0) where[1] else where2[length(where2)] paste(substr(expr, 1, where2), "\n ", Recall(substr(expr, where2 + 1, nchar(expr)), width, at), sep="") } removeExtraQuotes <- function(string) sub("\\\"$", "", sub("^\\\"", "", string)) squeezeMultipleSpaces <- function(string) gsub(" {2,}", " ", string) intersection <- function(...){ args <- list(...) if (length(args) == 2) intersect(args[[1]], args[[2]]) else intersect(args[[1]], do.call(intersection, args[-1])) } models <- list(...) n.models <- length(models) if (n.models < 1) return(NULL) if (n.models > 1){ classes <- lapply(models, class) common.classes <- do.call(intersection, classes) if (length(common.classes) == 0) warning("models to be compared are of different classes") } getnames <- function(model) { if (inherits(model, "merMod") || inherits(model, "mer") || inherits(model, "lme")) names(fixef(model)) else names(coef(model)) } getcoef <- function(model) { if (inherits(model, "merMod") || inherits(model, "mer") || inherits(model, "lme")) fixef(model) else coef(model) } getcall <- function(model) { paste(deparse(if (isS4(model)) model@call else model$call), collapse="") } getvar <- function(model) { if (inherits(model, "merMod") || inherits(model, "mer")) as.matrix(vcov(model, complete=FALSE)) else vcov(model, complete=FALSE) } vcov. <- if (missing(vcov.)) lapply(models, getvar) else{ if (se) cat(paste(strwrap(paste0("\nStandard errors computed by ", deparse(substitute(vcov.)), "\n\n"), width=getOption("width") - 2), collapse="\n ")) if (length(vcov.) == 1){ if (!is.function(vcov.)) stop("vcov. is not a function") lapply(models, vcov.) } else{ if (length(vcov.) != length(models)) stop("number of entries in vcov. not equal to number of models") else { vc <- vector(length(models), mode="list") for (i in 1:length(models)){ vc[[i]] <- if (is.function(vcov.[[i]])) vcov.[[i]](models[[i]]) else if (is.matrix(vcov.[[i]])) vcov.[[i]] else stop(i, "th element of vcov. is not a function or a matrix") } vc } } } coef.names <- unique(unlist(lapply(models, getnames))) table <- matrix(NA, length(coef.names), n.models * 4) rownames(table) <- coef.names colnames(table) <- if (n.models > 1) paste(rep(c("Model", "SE", "z", "Pr(>|z|)"), n.models), rep(1:n.models, each = 4)) else c("Estimate", "Std. Error", "z", "Pr(>|z|)") calls <- !any(sapply(models, getcall) == "NULL") if (print == TRUE && calls) cat("Calls:") for (i in 1:n.models) { model <- models[[i]] fout <- getcall(model) mod <- if (n.models > 1) paste(i, ": ", sep = "") else "" if (print && calls){ cat(splitExpr(squeezeMultipleSpaces(paste("\n", mod, removeExtraQuotes(fout[1]), sep = "")))) } if (print && calls && length(fout) > 1) { for (f in fout[-1]) cat("\n", splitExpr(squeezeMultipleSpaces(removeExtraQuotes(f)))) } ests <- getcoef(model) aliased <- is.na(ests) new <- matrix(NA, length(ests), 4) new[, 1] <- ests new[!is.na(ests), 2] <- sqrt(diag(vcov.[[i]])) new[, 3] <- new[, 1]/new[, 2] new[, 4] <- 2*pnorm(abs(new[, 3]), lower.tail=FALSE) new[aliased, 1] <- -Inf table[getnames(model), 4 * (i - 1) + 1:4] <- new } table <- table[, c(TRUE, se, zvals, pvals)] if (print) { cat("\n\n") if (se || zvals || pvals) table <- interleave(table, se, zvals, pvals) cs.inds <- vector(n.models, mode="list") posn.coef <- 0 posn.z <- rep(0, n.models) posn.p <- rep(0, n.models) for (i in 1:length(coef.names)){ posn.coef <- posn.coef + 1 posn.se <- posn.coef + se cs.inds[[i]] <- c(posn.coef:posn.se) if (zvals) posn.z[i] <- posn.se + 1 if (pvals) posn.p[i] <- posn.se + zvals + 1 posn.coef <- posn.se + zvals + pvals + any(c(se, zvals, pvals)) } table.f <- formatCompareCoefs(table, cs.inds=cs.inds, digits = digits, tst.ind = if (zvals) posn.z else NULL, P.values= if (pvals) posn.p else NULL) print.default(table.f, quote = FALSE, right = TRUE) } invisible(table) } formatCompareCoefs <- function (x, digits, cs.inds, tst.ind, P.values = NULL){ # this function adapted from stats::printCoefmat() x <- t(x) dig.tst <- max(1L, min(5L, digits - 1L)) d <- dim(x) nc <- d[2L] xm <- data.matrix(x) Cf <- array("", dim = d, dimnames = dimnames(xm)) for (cs.ind in cs.inds){ acs <- abs(coef.se <- xm[, cs.ind, drop = FALSE]) if (any(ia <- is.finite(acs))) { digmin <- 1 + if (length(acs <- acs[ia & acs != 0])) floor(log10(range(acs[acs != 0], finite = TRUE))) else 0 Cf[, cs.ind] <- format(round(coef.se, max(1L, digits - digmin)), digits = digits) } } if (length(tst.ind)) Cf[, tst.ind] <- format(round(xm[, tst.ind], digits = dig.tst), digits = digits) if (!is.null(P.values)){ Cf[, P.values] <- format.pval(xm[, P.values], digits=dig.tst, eps=.Machine$double.eps) } Cf[Cf == "NA" | is.na(xm)] <- "" Cf[is.infinite(xm)] <- "aliased" t(Cf) } car/R/car-defunct.R0000644000176000001440000000356114140261763013577 0ustar ripleyusers# last modified 2017-02-10 by J. Fox av.plot <- function (...) { .Defunct("avPlot", package="car") } av.plots <- function (...) { .Defunct("avPlots", package="car") } box.cox <- function (...) { .Defunct("bcPower", package="car") } bc <- function (...) { .Defunct("bcPower", package="car") } box.cox.powers <- function (...) { .Defunct("powerTransform", package="car") } box.cox.var <- function (...) { .Defunct("boxCoxVariable", package="car") } box.tidwell <- function (...) { .Defunct("boxTidwell", package="car") } ceres.plot <- function (...) { .Defunct("ceresPlot", package="car") } ceres.plots <- function (...) { .Defunct("ceresPlots", package="car") } confidence.ellipse <- function (...) { .Defunct("confidenceEllipse", package="car") } cookd <- function (...) { .Defunct("cooks.distance", package="stats") } cr.plot <- function (...) { .Defunct("crPlot", package="car") } cr.plots <- function (...) { .Defunct("crPlots", package="car") } data.ellipse <- function (...) { .Defunct("dataEllipse", package="car") } durbin.watson <- function (...) { .Defunct("durbinWatsonTest", package="car") } levene.test <- function (...) { .Defunct("leveneTest", package="car") } leverage.plot <- function (...) { .Defunct("leveragePlot", package="car") } leverage.plots <- function (...) { .Defunct("leveragePlots", package="car") } linear.hypothesis <- function (...) { .Defunct("linearHypothesis", package="car") } outlier.test <- function (...) { .Defunct("outlierTest", package="car") } ncv.test <- function (...) { .Defunct("ncvTest", package="car") } qq.plot <- function (...) { .Defunct("qqPlot", package="car") } scatterplot.matrix <- function (...) { .Defunct("scatterplotMatrix", package="car") } skewPower <- function (...) { .Defunct("bcnPower", package="car") } spread.level.plot <- function (...) { .Defunct("spreadLevelPlot", package="car") } car/R/boxCox.R0000644000176000001440000001337614140261763012653 0ustar ripleyusers# 2015-08-26: Modified by S. Weisberg to add support for bcn power transformations. # 2017-05-11: Added boxCox2d, renamed verssion of contour.powerTransform # 2017-05-11: Bug fixes in boxCox.formula with argument passing to other methods # 2020-02-17: Replaced match.fun by local, non-exported matchFun # 2021-05-27: Added a main= argument to boxCox.default for a default title, and # ... passes to plot. Rd updated. boxCox <- function(object,...) UseMethod("boxCox") # New arguments: param, and gamma boxCox.formula <- function (object, lambda = seq(-2, 2, 1/10), plotit=TRUE, family="bcPower", param=c("lambda", "gamma"), gamma=NULL, grid=TRUE,...) { m <- length(lambda) object <- lm(object, y = TRUE, qr = TRUE) result <- NextMethod() if (plotit) invisible(result) else result } boxCox.lm <- function (object, lambda = seq(-2, 2, 1/10), plotit = TRUE, ...) { m <- length(lambda) if (is.null(object$y) || is.null(object$qr)) object <- update(object, y = TRUE, qr = TRUE) result <- NextMethod() if (plotit) invisible(result) else result } boxCox.default <- function(object, lambda = seq(-2, 2, 1/10), plotit = TRUE, interp = plotit, eps = 1/50, xlab=NULL, ylab=NULL, main= "Profile Log-likelihood", family="bcPower", param=c("lambda", "gamma"), gamma=NULL, grid=TRUE, ...) { if(class(object)[1] == "mlm") stop("This function is for univariate response only") param <- match.arg(param) ylab <- if(is.null(ylab)){if(family != "bcnPower") "log-likelihood" else{ if(param=="gamma") {expression(max(logL[gamma](lambda,gamma)))} else {expression(max[lambda](logL(lambda, gamma)))}}} else ylab xlab <- if(is.null(xlab)){if(param == "lambda") expression(lambda) else expression(gamma)} else xlab fam <- matchFun(family) if (is.null(object$y) || is.null(object$qr)) stop(paste(deparse(substitute(object)), "does not have both 'qr' and 'y' components")) y <- object$y n <- length(y) xqr <- object$qr xl <- loglik <- if(family != "bcnPower") as.vector(lambda) else { if(param == "lambda") as.vector(lambda) else { # if argument gamma is non-null, use it for the range for gamma. # if gamma is null then use the range of the mle plus or minus 3 ses if(!is.null(gamma)) as.vector(gamma) else{ p1 <- powerTransform(object, family="bcnPower") gam <- p1$gamma se <- sd(y) # arbitrary scaling factor seq(max(.01, gam - 3*se), gam + 3*se, length=100) } } } m <- length(xl) if(family != "bcnPower"){ for (i in 1L:m) { yt <- fam(y,xl[i],j=TRUE) loglik[i] <- -n/2 * log(sum(qr.resid(xqr, yt)^2)) }} else{ lambda.1d <- function(gamma){ fn <- function(lam) bcnPowerllik(NULL, y, NULL, lambda=lam, gamma=gamma, xqr=xqr)$llik f <- optimize(f=fn, interval=c(-3, 3), maximum=TRUE) f$objective } gamma.1d <- function(lambda){ fn <- function(gam) bcnPowerllik(NULL, y, NULL, lambda=lambda, gamma=gam, xqr=xqr)$llik f <- optimize(f=fn, interval=c(0.01, max(y)), maximum=TRUE) f$objective } for (i in 1L:m) { loglik[i] <- if(param == "lambda") gamma.1d(loglik[i]) else lambda.1d(loglik[i]) } } if (interp) { sp <- spline(xl, loglik, n = 100) xl <- sp$x loglik <- sp$y m <- length(xl) } if (plotit) { mx <- (1L:m)[loglik == max(loglik)][1L] Lmax <- loglik[mx] lim <- Lmax - qchisq(19/20, 1)/2 plot(xl, loglik, xlab = xlab, ylab = ylab, type = "n", ylim = range(loglik, lim), main=main, ...) if(grid){ grid(lty=1, equilogs=FALSE) box()} lines(xl, loglik) plims <- par("usr") abline(h = lim, lty = 2) y0 <- plims[3L] scal <- (1/10 * (plims[4L] - y0))/par("pin")[2L] scx <- (1/10 * (plims[2L] - plims[1L]))/par("pin")[1L] text(xl[1L] + scx, lim + scal, " 95%") la <- xl[mx] if (mx > 1 && mx < m) segments(la, y0, la, Lmax, lty = 2) ind <- range((1L:m)[loglik > lim]) if (loglik[1L] < lim) { i <- ind[1L] x <- xl[i - 1] + ((lim - loglik[i - 1]) * (xl[i] - xl[i - 1]))/(loglik[i] - loglik[i - 1]) segments(x, y0, x, lim, lty = 2) } if (loglik[m] < lim) { i <- ind[2L] + 1 x <- xl[i - 1] + ((lim - loglik[i - 1]) * (xl[i] - xl[i - 1]))/(loglik[i] - loglik[i - 1]) segments(x, y0, x, lim, lty = 2) } } list(x = xl, y = loglik) } ########## boxCox2d <- function(x, ksds=4, levels=c(.5, .95, .99, .999), main="bcnPower Log-likelihood", grid=TRUE, ...){ if(class(x)[1] != "bcnPowerTransform") stop("Error--first argument must be a bcnPower transformation") object <- x if(dim(object$y)[2] != 1L) stop("This function is for univariate Y only") q <- object$llik - qchisq(levels, 2)/2 se <- sqrt(diag(object$invHess)) center <- c(object$lambda, object$gamma) x1 <- seq(object$lambda - ksds*se[1], object$lambda + ksds*se[1], length=100) y <- seq(max(.01, object$gamma - ksds*se[2]), object$gamma + ksds*se[2], length=100) z <- matrix(0, nrow=length(x1), ncol=length(y)) for (i in 1:length(x1)){ for (j in 1:length(y)){ z[i,j] <- bcnPowerllik(NULL, object$y, object$weights, x1[i], y[j], xqr=object$xqr)$llik } } contour(x1, y, z, xlab=expression(lambda), ylab=expression(gamma), main=main, nlevels=length(levels), levels=q, ...) points(center[1], center[2], pch=16, cex=1.25) text(center[1], center[2], as.character(round(object$llik, 2)), pos=4, cex=.75) if(grid){ grid(lty=1, equilogs=FALSE) box()} } car/R/qqPlot.R0000644000176000001440000002566314140261763012673 0ustar ripleyusers# Quantile-comparison plots (J. Fox) # last modified 30 September 2009 by J. Fox # November 2009 by S. Weisberg -- changed to use showLabels for point identification # 14 April 2010: set id.n = 0. J. Fox # 1 June 2010: set reps=100 in qqPlot.lm. J. Fox # 28 June 2010: fixed labeling bug S. Weisberg # 11 March 2011: moved up ... argument. J. Fox # 23 May 2012: line="none" now honored in qqPlot.default. J. Fox # 2 May 2013: qqPlot.lm() now works with "aov" objects (fixing problem reported by Thomas Burk). J. Fox # 2015-12-12: allow vectorized col, pch, and cex arguments (suggestion of Emmanuel Curis) # 2017-02-12: consolidated id argument. J. Fox # 2017-02-16: replace rlm() with MASS::rlm(). J. Fox # 2017-03-25: fixed handling of indexes so that unsorted indexes are reported. J. Fox # 2017-06-27: added formula method and plotting by groups. J. Fox # 2017-10-26: fix qqPlot.lm() so that it doesn't return names identifical to indices. J. Fox # 2017-11-30: substitute carPalette() for palette(). J. Fox # 2018-03-23: properly return point IDs when method="identify" # 2018-11-04: fixed handling of NAs when plotting by groups in qqPlot.default(). J. Fox # 2019-04-09: respect order of factor levels when plotting by groups (problem and fix by Vilmantas Gegzna). J. Fox # 2020-10-19: added filled confidence envelopes. J. Fox qqp <- function(...) qqPlot(...) qqPlot<-function(x, ...) { UseMethod("qqPlot") } qqPlot.default <- function(x, distribution="norm", groups, layout, ylim=range(x, na.rm=TRUE), ylab=deparse(substitute(x)), xlab=paste(distribution, "quantiles"), glab=deparse(substitute(groups)), main=NULL, las=par("las"), envelope=TRUE, col=carPalette()[1], col.lines=carPalette()[2], lwd=2, pch=1, cex=par("cex"), line=c("quartiles", "robust", "none"), id=TRUE, grid=TRUE, ...){ if (!missing(groups)){ if (isTRUE(id)) id <- list(n=2) if (is.null(id$labels)) id$labels <- seq(along=x) grps <- levels(as.factor(groups)) if (missing(layout)) layout <- mfrow(length(grps), max.plots=12) if (prod(layout) < length(grps)) stop("layout cannot accomodate ", length(grps), " plots") oldpar <- par(mfrow=layout) on.exit(par(oldpar)) for (group in grps){ id.gr <- id if (!isFALSE(id)) id.gr$labels <- id$labels[groups == group] qqPlot.default(x[groups == group], distribution=distribution, ylim=ylim, ylab=ylab, xlab=xlab, main=paste(glab, "=", group), las=las, envelope=envelope, col=col, col.lines=col.lines, pch=pch, cex=cex, line=line, id=id.gr, grid=grid, ...) } return(invisible(NULL)) } if (!is.list(envelope) && length(envelope == 1) && is.numeric(envelope)){ envelope <- list(level=envelope) } if (!isFALSE(envelope)){ envelope <- applyDefaults(envelope, defaults=list(level=0.95, style="filled", col=col.lines, alpha=0.15, border=TRUE)) style <- match.arg(envelope$style, c("filled", "lines", "none")) col.envelope <- envelope$col conf <- envelope$level alpha <- envelope$alpha border <- envelope$border if (style == "none") envelope <- FALSE } id <- applyDefaults(id, defaults=list(method="y", n=2, cex=1, col=carPalette()[1], location="lr"), type="id") if (isFALSE(id)){ id.n <- 0 id.method <- "none" labels <- id.cex <- id.col <- id.location <- NULL } else{ labels <- id$labels if (is.null(labels)) labels <- if(!is.null(names(x))) names(x) else seq(along=x) id.method <- id$method id.n <- if ("identify" %in% id.method) Inf else id$n id.cex <- id$cex id.col <- id$col id.location <- id$location } line <- match.arg(line) index <- seq(along=x) good <- !is.na(x) ord <- order(x[good]) if (length(col) == length(x)) col <- col[good][ord] if (length(pch) == length(x)) pch <- pch[good][ord] if (length(cex) == length(x)) cex <- cex[good][ord] ord.x <- x[good][ord] ord.lab <- labels[good][ord] q.function <- eval(parse(text=paste("q", distribution, sep=""))) d.function <- eval(parse(text=paste("d", distribution, sep=""))) n <- length(ord.x) P <- ppoints(n) z <- q.function(P, ...) plot(z, ord.x, type="n", xlab=xlab, ylab=ylab, main=main, las=las, ylim=ylim) if(grid){ grid(lty=1, equilogs=FALSE) box()} points(z, ord.x, col=col, pch=pch, cex=cex) if (line == "quartiles" || line == "none"){ Q.x <- quantile(ord.x, c(.25,.75)) Q.z <- q.function(c(.25,.75), ...) b <- (Q.x[2] - Q.x[1])/(Q.z[2] - Q.z[1]) a <- Q.x[1] - b*Q.z[1] if (line == "quartiles") abline(a, b, col=col.lines, lwd=lwd) } if (line=="robust") { coef <- coef(MASS::rlm(ord.x ~ z)) a <- coef[1] b <- coef[2] abline(a, b, col=col.lines, lwd=lwd) } if (!isFALSE(envelope)) { zz <- qnorm(1 - (1 - conf)/2) SE <- (b/d.function(z, ...))*sqrt(P*(1 - P)/n) fit.value <- a + b*z upper <- fit.value + zz*SE lower <- fit.value - zz*SE if (style == "filled"){ envelope(z, z, lower, upper, col=col.envelope, alpha=alpha, border=border) } else { lines(z, upper, lty=2, lwd=lwd, col=col.lines) lines(z, lower, lty=2, lwd=lwd, col=col.lines) } } extreme <- showLabels(z, ord.x, labels=ord.lab, method = id.method, n = id.n, cex=id.cex, col=id.col, location=id.location) if (is.numeric(extreme)){ nms <- names(extreme) extreme <- index[good][ord][extreme] if (!all(as.character(extreme) == nms)) names(extreme) <- nms } if (length(extreme) > 0) extreme else invisible(NULL) } qqPlot.formula <- function (formula, data, subset, id=TRUE, ylab, glab, ...) { m <- match.call(expand.dots = FALSE) if (is.matrix(eval(m$data, sys.frame(sys.parent())))) m$data <- as.data.frame(data) m$formula <- m$... <- m$id <- m$ylab <- NULL m[[1]] <- as.name("model.frame") if (missing(ylab)) ylab <- as.character(formula[[2]]) if (length(formula) == 2){ groups <- FALSE } else if (length(formula) == 3){ groups <- TRUE if(missing(glab)) glab <- as.character(formula[[3]]) } m$formula <-formula if (missing(data)){ x <- na.omit(eval(m, parent.frame())) } else{ x <- eval(m, parent.frame()) } if (!isFALSE(id)){ if (isTRUE(id)){ id <- list(n=2) } if (is.null(id$labels)){ id$labels <- rownames(x) } } if (!groups && ncol(x) > 1) stop("more than one variable specified") if (groups && ncol(x) != 2) stop("formula must be of the form variable ~ groups") if (!groups) qqPlot(x[, 1], id=id, ylab=ylab, ...) else qqPlot(x[, 1], groups=x[, 2], id=id, ylab=ylab, glab=glab, ...) } qqPlot.lm <- function(x, xlab=paste(distribution, "Quantiles"), ylab=paste("Studentized Residuals(", deparse(substitute(x)), ")", sep=""), main=NULL, distribution=c("t", "norm"), line=c("robust", "quartiles", "none"), las=par("las"), simulate=TRUE, envelope=TRUE, reps=100, col=carPalette()[1], col.lines=carPalette()[2], lwd=2, pch=1, cex=par("cex"), id=TRUE, grid=TRUE, ...){ distribution <- match.arg(distribution) force(xlab) force(ylab) x <- update(x, na.action="na.exclude") if (!is.list(envelope) && length(envelope == 1) && is.numeric(envelope)){ envelope <- list(level=envelope) } if (!isFALSE(envelope)){ envelope <- applyDefaults(envelope, defaults=list(level=0.95, style="filled", col=col.lines, alpha=0.15, border=TRUE)) style <- match.arg(envelope$style, c("filled", "lines", "none")) col.envelope <- envelope$col conf <- envelope$level alpha <- envelope$alpha border <- envelope$border if (style == "none") envelope <- FALSE } id <- applyDefaults(id, defaults=list(method="y", n=2, cex=1, col=carPalette()[1], location="lr"), type="id") if (isFALSE(id)){ id.n <- 0 id.method <- "none" labels <- id.cex <- id.col <- id.location <- NULL } else{ labels <- id$labels if (is.null(labels)) labels <- names(residuals(x)) if (length(labels) != length(residuals(x))) stop("the number of labels, ", length(labels), ", differs from the number of cases, ", length(residuals(x))) id.method <- id$method id.n <- if ("identify" %in% id.method) Inf else id$n id.cex <- id$cex id.col <- id$col id.location <- id$location } result <- NULL line <- match.arg(line) rstudent <- rstudent(x) index <- seq(along=rstudent) sumry <- summary.lm(x) res.df <- sumry$df[2] if(!simulate){ result <- qqPlot(rstudent, distribution=if (distribution == "t") "t" else "norm", df=res.df-1, line=line, main=main, xlab=xlab, ylab=ylab, las=las, envelope=envelope, col=col, col.lines=col.lines, lwd=lwd, pch=pch, cex=cex, id=list(method=id.method, n=id.n, cex=id.cex, col=id.col, location="lr", labels=labels), ...) } else { good <- !is.na(rstudent) rstudent <- rstudent[good] labels <- labels[good] n <- length(rstudent) ord <- order(rstudent) ord.x <- rstudent[ord] ord.lab <- labels[ord] P <- ppoints(n) z <- if (distribution == 't') qt(P, df=res.df-1) else qnorm(P) plot(z, ord.x, type="n", xlab=xlab, ylab=ylab, main=main, las=las) if(grid) grid(lty=1, equilogs=FALSE) points(z, ord.x, pch=pch, col=col, cex=cex) yhat <- na.omit(fitted.values(x)) S <- sumry$sigma Y <- matrix(yhat, n, reps) + matrix(rnorm(n*reps, sd=S), n, reps) X <- model.matrix(x) rstud <- apply(rstudent(lm(Y ~ X - 1)), 2, sort) if (!isFALSE(envelope)) { lower <- apply(rstud, 1, quantile, prob=(1 - conf)/2) upper <- apply(rstud, 1, quantile, prob=(1 + conf)/2) if (style == "filled"){ envelope(z, z, lower, upper, col=col.envelope, alpha=alpha, border=border) } else { lines(z, upper, lty=2, lwd=lwd, col=col.lines) lines(z, lower, lty=2, lwd=lwd, col=col.lines) } } if (line == "quartiles"){ Q.x <- quantile(rstudent, c(.25,.75)) Q.z <- if (distribution == 't') qt(c(.25,.75), df=res.df - 1) else qnorm(c(.25,.75)) b <- (Q.x[2] - Q.x[1])/(Q.z[2] - Q.z[1]) a <- Q.x[1] - b*Q.z[1] abline(a, b, col=col.lines, lwd=lwd) } if (line=="robust"){ coef <- coefficients(MASS::rlm(ord.x~z)) a <- coef[1] b <- coef[2] abline(a, b, col=col.lines, lwd=lwd) } result <- showLabels(z, ord.x,labels=ord.lab, method = id.method, n = id.n, cex=id.cex, col=id.col, location=id.location) nms <- names(result) result <- index[good][ord][result] names(result) <- nms result } if (all(as.character(result) == names(result))) names(result) <- NULL if (length(result) == 0) invisible(result) else if (is.numeric(result)) sort(result) else result } qqPlot.glm <- function(x, ...){ stop("QQ plot for studentized residuals not available for glm") } car/R/panel.car.R0000644000176000001440000000066314140261763013247 0ustar ripleyusers# panel function for use with coplot (J. Fox) # last modified 2 April 2009 panel.car <- function(x, y, col, pch, cex=1, span=.5, lwd=2, reg.line=lm, lowess.line=TRUE,...){ points(x, y, col=col, pch=pch, cex=cex) if (is.function(reg.line)) regLine(reg.line(y ~ x), lty=2, lwd=lwd, col=col, ...) if (lowess.line) lines(lowess(na.omit(as.data.frame(cbind(x, y))), f=span), col=col, lwd=lwd, ...) } car/R/showLabels.R0000644000176000001440000001253114140261763013504 0ustar ripleyusers# last modified 25 Februrary 2010 by J. Fox # rewritten 15 April 2010 S Weisberg # 2013-02-07 S. Weisberg bug fix for use with 'scatterplot' with groups. # Added an argument to showLabels1 'all' that gives a list of two # elements for the original labels and subset indicator. See # scatterplot.R for an example of its use. # If a list of cases to be labelled is supplied, id.n is needed only # if all n labels are to be printed. # 2014-03-12 added new id.method "r" that labels using order(abs(y), decreasing=TRUE) # 2016-05-16 added argument id.location = c("lr", "ab") for location of point labels # 2017-01-08 added "avoid" to id.location arg. J. Fox # 2017-01-08 removed ".id" from arg names for showLabels() # 2017-01-10 special handling for method="none". # 2017-02-13 fixed showLabels1() when location="avoid" # 2017-03-25: don't supply names if indexes are the same as labels. J. Fox showLabels <- function(x, y, labels=NULL, method="identify", n = length(x), cex=1, col=carPalette()[1], location=c("lr", "ab", "avoid"), ...) { location <- match.arg(location) res <- NULL method <- if(is.list(method)) method else list(method) for (meth in method){ if (length(meth) == 1 && is.character(meth) && meth == "none") next res <- c(res, showLabels1(x, y, labels, meth, n, cex, col, location, ...)) } return(if(is.null(res)) invisible(res) else res) } showLabels1 <- function(x, y, labels=NULL, id.method="identify", id.n = length(x), id.cex=1, id.col=carPalette()[1], id.location="lr", all=NULL, ...) { # If labels are NULL, try to get the labels from x: if (is.null(labels)) labels <- names(x) if (is.null(labels)) labels <- paste(seq_along(x)) if (is.null(id.col)) id.col <- carPalette()[1] if (is.null(id.location)) id.location <- "lr" # logged-axes? log.x <- par("xlog") log.y <- par("ylog") # id.method can be any of the following: # --- a list of row numbers # --- a list of labels # --- a vector of n numbers # --- a text string: 'identify', 'x', 'y', 'mahal', 'r' idmeth <- pmatch(id.method[1], c("x", "y", "mahal", "identify", "r")) if(!is.na(idmeth)) idmeth <- c("x", "y", "mahal", "identify", "r")[idmeth] # if idmeth is NA, then id.method must be <= n numbers or labels id.var <- NULL if(is.na(idmeth)){ if(is.null(all)) all <- list(labels=labels, subs=rep(TRUE, length(labels))) names(all$labels) <- all$labels if(length(id.method) >= length(x)){ id.var <- id.method[which(all$subs)] id.n <- min(id.n, length(id.var)) } else { id.var <- rep(0, length(x)) names(id.var) <- labels inSubset <- all$labels[all$subs] %in% all$labels[id.method] id.var[inSubset] <- 1 id.n <- sum(inSubset) } } else { # use identify? if(idmeth == "identify"){ result <- labels[identify(x, y, labels, n=length(x), cex=id.cex, col=id.col)] if(length(result) > 0) return(unique(result)) else return(NULL) } # missing values need to be removed ismissing <- is.na(x) | is.na(y) | is.na(labels) if( any(ismissing) ) { x <- x[!ismissing] y <- y[!ismissing] labels <- labels[!ismissing] } # other methods: id.var <- switch(id.method, x = if(log.x==TRUE) suppressWarnings(if(all(x) > 0) abs(log(x) - mean(log(x))) else return(invisible(NULL))) else abs(x - mean(x)), y = if(log.y==TRUE) suppressWarnings(if(all(y) > 0) abs(log(y) - mean(log(y))) else return(invisible(NULL))) else abs(y - mean(y)), r = if(log.y==TRUE) suppressWarnings(if(all(y) > 0) abs(log(y)) else return(invisible(NULL))) else abs(y), mahal = if(log.x == TRUE & log.y == TRUE) { suppressWarnings(if(all(x) > 0 & all(y) > 0) rowSums( qr.Q(qr(cbind(1, log(x), log(y))))^2 ) else return(invisible(NULL))) } else { if(log.x == TRUE) { suppressWarnings(if(all(x) > 0 ) rowSums( qr.Q(qr(cbind(1, log(x), y)))^2 ) else return(invisible(NULL))) } else { if(log.y == TRUE) { suppressWarnings(if(all(y) > 0 ) rowSums( qr.Q(qr(cbind(1, x, log(y))))^2 ) else return(invisible(NULL))) } else { rowSums( qr.Q(qr(cbind(1, x, y)))^2 ) }}}) } # require id.n positive if(id.n <= 0L) return(invisible(NULL)) # criterion ind <- order(id.var, decreasing=TRUE)[1L:min(length(id.var), id.n)] # position, now depends on id.location (as of 5/16/2016) if (id.location != "avoid"){ if(id.location == "lr"){ mid <- mean(if(par("xlog")==TRUE) 10^(par("usr")[1:2]) else par("usr")[1:2]) labpos <- c(4,2)[1+as.numeric(x > mid)] } else { mid <- mean(if(par("ylog")==TRUE) 10^(par("usr")[3:4]) else par("usr")[3:4]) labpos <- c(3,1)[1+as.numeric(y > mid)] } # print for (i in ind) { text(x[i], y[i], labels[i], cex = id.cex, xpd = TRUE, col = id.col, pos = labpos[i], offset = 0.25)} } else maptools::pointLabel(c(x[ind], x[ind]), c(y[ind], y[ind]), c(paste0(" ", labels[ind], " "), rep(" ", length(ind))), cex=id.cex, xpd=TRUE, col=id.col) if (any(as.character(ind) != labels[ind])) names(ind) <- labels[ind] result <- ind if (length(result) == 0) return(NULL) else return(result) } car/R/Ellipse.R0000644000176000001440000003211214140261763012773 0ustar ripleyusers# Ellipses (orignally by J. Fox and G. Monette) # added grid lines, 25 May 2010 by S. Weisberg # arguments more consistent with other functions; ... passes args to plot, 5 Sept 2010 by J. Fox # confidenceEllipse.lm and .glm can add to current plot, applying patch from Rafael Laboissiere, 17 Oct 2010 by J. Fox # added fill and fill.alpha arguments for translucent fills (suggested by Michael Friendly), 14 Nov 2010 by J. Fox # modified 2 May 2011 by Michael Friendly # - allow pivot=TRUE (with warning) # - barf on non-symmetric shape # - return coordinates of ellipse invisibly # dataEllipse() and confidenceEllipse() invisibly return coordinates, 3 May 2011 by J. Fox # Modified 5 May 2011 by Michael Friendly # - dataEllipse now honors add=FALSE, plot.points=FALSE # Modified 16 May 2011 by Michaell Friendly # - corrected bug introduced in dataEllipse via allowing pivot=TRUE # Modified 7 Aug 2011 by J. Fox: added draw argument # Modified 28 Nov 2011 by J. Fox (suggested by Michael Friendly): # - corrected bug in xlab, ylab in confidenceEllipse() # - added dfn argument to .lm and .glm methods for confidenceEllipse() # Modified 14&16 Dec 2011 by J. Fox (suggested by Michael Friendly) to add weights argument to dataEllipse(). # Modified 2 Feb 2012 by J. Fox: Improved handling of center.pch argument to ellipse() (suggestion of Rob Kushler). # 16 July 2012 added showLabels to dataEllipse # 2014-02-16: prevent dataEllipse() from opening a graphics device when draw=FALSE (fixing bug reported by Rafael Laboissiere). # 2015-09-04: throw error if there are too few colors for groups (fixing bug reported by Ottorino Pantani). J. Fox # 2016-02-16: replace cov.trob() call with MASS::cov.trob(). J. Fox # 2017-11-30: substitute carPalette() for palette(). J. Fox ellipse <- function(center, shape, radius, log="", center.pch=19, center.cex=1.5, segments=51, draw=TRUE, add=draw, xlab="", ylab="", col=carPalette()[2], lwd=2, fill=FALSE, fill.alpha=0.3, grid=TRUE, ...) { trans.colors <- function(col, alpha=0.5, names=NULL) { # this function by Michael Friendly nc <- length(col) na <- length(alpha) # make lengths conform, filling out to the longest if (nc != na) { col <- rep(col, length.out=max(nc,na)) alpha <- rep(alpha, length.out=max(nc,na)) } clr <-rbind(col2rgb(col)/255, alpha=alpha) col <- rgb(clr[1,], clr[2,], clr[3,], clr[4,], names=names) col } logged <- function(axis=c("x", "y")){ axis <- match.arg(axis) 0 != length(grep(axis, log)) } if (! (is.vector(center) && 2==length(center))) stop("center must be a vector of length 2") if (! (is.matrix(shape) && all(2==dim(shape)))) stop("shape must be a 2 by 2 matrix") if (max(abs(shape - t(shape)))/max(abs(shape)) > 1e-10) stop("shape must be a symmetric matrix") angles <- (0:segments)*2*pi/segments unit.circle <- cbind(cos(angles), sin(angles)) # ellipse <- t(center + radius*t(unit.circle %*% chol(shape,pivot=TRUE))) Q <- chol(shape, pivot=TRUE) order <- order(attr(Q, "pivot")) ellipse <- t( center + radius*t( unit.circle %*% Q[,order])) colnames(ellipse) <- c("x", "y") if (logged("x")) ellipse[, "x"] <- exp(ellipse[, "x"]) if (logged("y")) ellipse[, "y"] <- exp(ellipse[, "y"]) fill.col <- trans.colors(col, fill.alpha) if (draw) { if (add) { lines(ellipse, col=col, lwd=lwd, ...) if (fill) polygon(ellipse, col=fill.col, border=NA) } else { plot(ellipse, type="n", xlab = xlab, ylab = ylab, ...) if(grid){ grid(lty=1, equilogs=FALSE) box()} lines(ellipse, col=col, lwd=lwd, ... ) if (fill) polygon(ellipse, col=fill.col, border=NA) } if ((center.pch != FALSE) && (!is.null(center.pch))) points(center[1], center[2], pch=center.pch, cex=center.cex, col=col) } invisible(ellipse) } dataEllipse <- function(x, y, groups, group.labels=group.levels, ellipse.label, weights, log="", levels=c(0.5, 0.95), center.pch=19, center.cex=1.5, draw=TRUE, plot.points=draw, add=!plot.points, segments=51, robust=FALSE, xlab=deparse(substitute(x)), ylab=deparse(substitute(y)), col=if (missing(groups)) carPalette()[1:2] else carPalette()[1:length(group.levels)], pch=if (missing(groups)) 1 else seq(group.levels), lwd=2, fill=FALSE, fill.alpha=0.3, grid=TRUE, id=FALSE, ...) { label.ellipse <- function(ellipse, label, col, ...){ # This sub-function from Michael Friendly if (cor(ellipse)[1,2] >= 0){ # position label above top right index <- which.max(ellipse[,2]) x <- ellipse[index, 1] + 0.5 * strwidth(label) y <- ellipse[index, 2] + 0.5 * strheight("A") adj <- c(1, 0) } else { # position label below bot left index <- which.min(ellipse[,2]) x <- ellipse[index, 1] - 0.5 * strwidth(label) y <- ellipse[index, 2] - 0.5 * strheight("A") adj <- c(0, 1) } text(x, y, label, adj=adj, col=col, ...) } default.col <- if (missing(groups)) carPalette()[1] else carPalette()[1:length(groups)] id <- applyDefaults(id, defaults=list(method="mahal", n=2, cex=1, col=default.col, location="lr"), type="id") if (isFALSE(id)){ id.n <- 0 id.method <- "none" labels <- id.cex <- id.col <- id.location <- NULL } else{ labels <- id$labels if (is.null(labels)) labels <- seq(along=y) id.method <- id$method id.n <- if ("identify" %in% id.method) Inf else id$n id.cex <- id$cex id.col <- id$col id.location <- id$location } if(missing(y)){ if (is.matrix(x) && ncol(x) == 2) { if (missing(xlab)) xlab <- colnames(x)[1] if (missing(ylab)) ylab <- colnames(x)[2] y <- x[,2] x <- x[,1] } else stop("x and y must be vectors, or x must be a 2 column matrix") } else if(!(is.vector(x) && is.vector(y) && length(x) == length(y))) stop("x and y must be vectors of the same length") if (missing(weights)) weights <- rep(1, length(x)) if (length(weights) != length(x)) stop("weights must be of the same length as x and y") if (!missing(groups)){ xlab ylab if (!is.factor(groups)) stop ("groups must be a factor") if (!(length(groups) == length(x))) stop ("groups, x, and y must all be of the same length") if(missing(labels)) labels <- seq(length(x)) valid <- complete.cases(x, y, groups) x <- x[valid] y <- y[valid] weights <- weights[valid] groups <- groups[valid] labels <- labels[valid] group.levels <- levels(groups) col <- col[!is.na(col)] if (length(col) < length(group.levels)) stop("too few colors for number of groups") result <- vector(length(group.levels), mode="list") names(result) <- group.levels if(draw) { if (!add) { plot(x, y, type="n", xlab=xlab, ylab=ylab, ...) if(grid){ grid(lty=1, equilogs=FALSE) box() } } } id.lev <- list(method=id.method, n=id.n, cex=id.cex, col=NULL, labels=NULL, location=id.location) for (lev in 1:length(group.levels)){ level <- group.levels[lev] sel <- groups == level id.lev$labels <- labels[sel] id.lev$col <- rep(id.col[lev], 2) result[[lev]] <- dataEllipse(x[sel], y[sel], weights=weights[sel], log=log, levels=levels, center.pch=center.pch, center.cex=center.cex, draw=draw, plot.points=plot.points, add=TRUE, segments=segments, robust=robust, col=rep(col[lev], 2), pch=pch[lev], lwd=lwd, fill=fill, fill.alpha=fill.alpha, id=id.lev, # labels=labels[sel], id.method=id.method, id.n=id.n, id.cex=id.cex, # id.col=col[lev], id.location=id.location, ellipse.label=group.labels[lev], ...) } return(invisible(result)) } if (length(col) == 1) col <- rep(col, 2) if(draw) { if (!add) { plot(x, y, type="n", xlab=xlab, ylab=ylab, ...) if(grid){ grid(lty=1, equilogs=FALSE) box()} } if (plot.points) points(x, y, col=col[1], pch=pch[1], ...) } dfn <- 2 dfd <- length(x) - 1 if (robust) { use <- weights > 0 v <- MASS::cov.trob(cbind(x[use], y[use]), wt=weights[use]) shape <- v$cov center <- v$center } else { v <- cov.wt(cbind(x, y), wt=weights) shape <- v$cov center <- v$center } result <- vector("list", length=length(levels)) names(result) <- levels for (i in seq(along=levels)) { level <- levels[i] radius <- sqrt(dfn * qf(level, dfn, dfd )) result[[i]] <- ellipse(center, shape, radius, log=log, center.pch=center.pch, center.cex=center.cex, segments=segments, col=col[2], lwd=lwd, fill=fill, fill.alpha=fill.alpha, draw=draw, ...) if (!missing(ellipse.label)) { lab <- if (length(ellipse.label) < i) ellipse.label[1] else ellipse.label[i] label.ellipse(result[[i]], lab, col[2], ...) } } if (missing(labels)) labels <- seq(length(x)) if (draw) showLabels(x, y, labels=labels, method=id.method, n=id.n, cex=id.cex, col=id.col, location = id.location) invisible(if (length(levels) == 1) result[[1]] else result) } confidenceEllipse <- function (model, ...) { UseMethod("confidenceEllipse") } confidenceEllipse.lm <- function(model, which.coef, vcov.=vcov, L, levels=0.95, Scheffe=FALSE, dfn, center.pch=19, center.cex=1.5, segments=51, xlab, ylab, col=carPalette()[2], lwd=2, fill=FALSE, fill.alpha=0.3, draw=TRUE, add=!draw, ...){ if (missing(dfn)) dfn <- if (Scheffe) sum(df.terms(model)) else 2 dfd <- df.residual(model) vcov. <- getVcov(vcov., model) if (missing(L)){ which.coef <- if(length(coefficients(model)) == 2) c(1, 2) else{ if (missing(which.coef)){ if (has.intercept(model)) c(2,3) else c(1, 2) } else which.coef } coef <- coefficients(model)[which.coef] if (missing(xlab)) xlab <- paste(names(coef)[1], "coefficient") if (missing(ylab)) ylab <- paste(names(coef)[2], "coefficient") shape <- vcov.[which.coef, which.coef] } else { res <- makeLinearCombinations(L, coef(model), vcov.) coef <- res$coef xlab <- res$xlab ylab <- res$ylab shape <- res$shape } levels <- rev(sort(levels)) result <- vector("list", length=length(levels)) names(result) <- levels for (i in seq(along=levels)){ level <- levels[i] radius <- sqrt(dfn*qf(level, dfn, dfd)) add.plot <- !level==max(levels) | add result[[i]] <- ellipse(coef, shape, radius, add=add.plot, xlab=xlab, ylab=ylab, center.pch=center.pch, center.cex=center.cex, segments=segments, col=col, lwd=lwd, fill=fill, fill.alpha=fill.alpha, draw=draw, ...) } invisible(if (length(levels) == 1) result[[1]] else result) } confidenceEllipse.default <- function(model, which.coef, vcov.=vcov, L, levels=0.95, Scheffe=FALSE, dfn, center.pch=19, center.cex=1.5, segments=51, xlab, ylab, col=carPalette()[2], lwd=2, fill=FALSE, fill.alpha=0.3, draw=TRUE, add=!draw, ...){ vcov. <- getVcov(vcov., model) #if (is.function(vcov.)) vcov. <- vcov.(model) if (missing(L)){ which.coef <- if(length(coefficients(model)) == 2) c(1, 2) else{ if (missing(which.coef)){ if (has.intercept(model)) c(2, 3) else c(1, 2) } else which.coef } coef <- coefficients(model)[which.coef] shape <- vcov.[which.coef, which.coef] xlab <- if (missing(xlab)) paste(names(coef)[1], "coefficient") ylab <- if (missing(ylab)) paste(names(coef)[2], "coefficient") } else { res <- makeLinearCombinations(L, coef(model), vcov.) coef <- res$coef xlab <- res$xlab ylab <- res$ylab shape <- res$shape } df <- if (!missing(dfn)) dfn else if (Scheffe) sum(df.terms(model)) else 2 levels <- rev(sort(levels)) result <- vector("list", length=length(levels)) names(result) <- levels for (i in seq(along=levels)){ level <- levels[i] radius <- sqrt(qchisq(level, df)) add.plot <- !level==max(levels) | add result[[i]] <- ellipse(coef, shape, radius, add=add.plot, xlab=xlab, ylab=ylab, center.pch=center.pch, center.cex=center.cex, segments=segments, col=col, lwd=lwd, fill=fill, fill.alpha=fill.alpha, draw=draw, ...) } invisible(if (length(levels) == 1) result[[1]] else result) } confidenceEllipse.glm <- function (model, chisq, ...) { sumry <- summary(model) if (missing(chisq)) chisq <- is.null(sumry$dispersion) if (chisq) confidenceEllipse.default(model, ...) else confidenceEllipse.lm(model, ...) } makeLinearCombinations <- function(L, coef, V){ nms <- names(coef) if (is.character(L)){ L <- makeHypothesis(nms, L) L <- L[, -ncol(L)] } if (nrow(L) != 2 || ncol(L) != length(coef)) stop("the hypothesis matrix is the wrong size") coef <- as.vector(L %*% coef) shape <- L %*% V %*% t(L) L.nms <- printHypothesis(L, c(0, 0), nms) names(coef) <- sub(" =.*", "", L.nms) xlab <- names(coef)[1] ylab <- names(coef)[2] list(coef=coef, shape=shape, xlab=xlab, ylab=ylab) } car/R/Import.R0000644000176000001440000000442514140313001012635 0ustar ripleyusers# function Import March 14, 2017 # This add two arguments to the `import` file in the rio package # import is just a front end to a number of file reading files and packages in R # 3/14/2017: S. Weisberg, wrote the file, that adds # row.names=TRUE, default, will select the left-most column of character data in the data file as # row names subject to length(x) == length(unique(x)) # charAsFactor=TRUE converts character to factor if length(x) > length(unique(x)) # logicalAsFactor=charAsFactor converts logical to factor # These arguments are read only if format %in% c("txt", "csv", "xls", "xlsx", "ods"). # 4/2/2017: S. Weisberg changed and simplified arguments. # 5/22/2017: S. Weisberg, fixed bug reading files with one character column (added drop=FALSE) # 5/6/2020: S. Weisberg, changed default for stringsAsFactors to FALSE. # 11/2/2021: A. Zeileis, check for rio availability (so that rio can be in Suggests only) Import <- function(file, format, ..., row.names=TRUE, stringsAsFactors = FALSE){ if(!requireNamespace("rio")) stop("Import() relies on rio::import(), please install package 'rio'") d <- rio::import(file, format, ...) fmt <- if(!missing(format)) format else{ pos <- regexpr("\\.([[:alnum:]]+)$", file) ifelse(pos > -1L, substring(file, pos + 1L), "") } # check for rows with no data d <- d[!apply(d, 1, function(row) all(is.na(row))), ] if(fmt %in% c("txt", "csv", "xls", "xlsx", "ods")){ classes <- unlist(lapply(as.list(d), class)) char <- classes %in% c("character", "logical") if(!any(char)) return(d) allUnique <- rep(FALSE, dim(d)[2]) allUnique[char] <- apply(d[, char, drop=FALSE], 2, function(x) length(x) == length(unique(x))) if(row.names == TRUE){ if(any(allUnique)){ row.namesCol <- which(allUnique)[1] # use first non-repeating character col as row.names row.names(d) <- d[[row.namesCol]] # set the row.names d <- d[, -row.namesCol] # delete row.names column from data.frame allUnique <- allUnique[-row.namesCol] char <- char[-row.namesCol]} } if(stringsAsFactors & any(!allUnique)){ for(j in which(char & !allUnique)) d[, j] <- factor(d[, j]) }} return(d) } car/R/carHexsticker.R0000644000176000001440000000016114140261763014174 0ustar ripleyuserscarHexsticker <- function(){ browseURL(paste0("file://", system.file("doc", "car-hex.pdf", package="car"))) }car/R/regLine.R0000644000176000001440000000122614140261763012765 0ustar ripleyusers# draw regression line from model to extremes of fit (J. Fox) # last modified 2 October 2009 by J. Fox # 2017-11-30: substitute carPalette() for palette(). J. Fox # 2019-11-14: change class(x) == "y" to inherits(x, "y") regLine <- function(mod, col=carPalette()[2], lwd=2, lty=1, ...){ if(!is.null(class(mod$na.action)) && inherits(mod$na.action, "exclude")) class(mod$na.action) <-"omit" coef <- coefficients(mod) if (length(coef) != 2) stop("requires simple linear regression") x <- model.matrix(mod)[,2] y <- fitted.values(mod) min <- which.min(x) max <- which.max(x) lines(c(x[min], x[max]), c(y[min], y[max]), col=col, lty=lty, lwd=lwd, ...) } car/R/vif.R0000644000176000001440000001045414140261763012167 0ustar ripleyusers#------------------------------------------------------------------------------- # Revision history: # 2009-09-28 by J. Fox # 2013-05-21 replaced vif.lm with vif.default and added # model.matrix.gls to make gls models work. J. Fox # 2015-01-13: fixed model.matrix.gls to work with models with formulas as object. J. Fox # 2020-12-19: new polr and svyolr methods for ordinal regression models. J. Fox #------------------------------------------------------------------------------- # Generalized Variance-Inflation Factors (Henric Nilsson and John Fox) vif<-function(mod, ...){ UseMethod("vif") } vif.default <- function(mod, ...) { if (any(is.na(coef(mod)))) stop ("there are aliased coefficients in the model") v <- vcov(mod) assign <- attr(model.matrix(mod), "assign") if (names(coefficients(mod)[1]) == "(Intercept)") { v <- v[-1, -1] assign <- assign[-1] } else warning("No intercept: vifs may not be sensible.") terms <- labels(terms(mod)) n.terms <- length(terms) if (n.terms < 2) stop("model contains fewer than 2 terms") R <- cov2cor(v) detR <- det(R) result <- matrix(0, n.terms, 3) rownames(result) <- terms colnames(result) <- c("GVIF", "Df", "GVIF^(1/(2*Df))") for (term in 1:n.terms) { subs <- which(assign == term) result[term, 1] <- det(as.matrix(R[subs, subs])) * det(as.matrix(R[-subs, -subs])) / detR result[term, 2] <- length(subs) } if (all(result[, 2] == 1)) result <- result[, 1] else result[, 3] <- result[, 1]^(1/(2 * result[, 2])) result } vif.merMod <- function(mod, ...) { if (any(is.na(fixef(mod)))) stop ("there are aliased coefficients in the model") v <- as.matrix(vcov(mod)) assign <- attr(model.matrix(mod), "assign") if (names(fixef(mod)[1]) == "(Intercept)") { v <- v[-1, -1] assign <- assign[-1] } else warning("No intercept: vifs may not be sensible.") terms <- labels(terms(mod)) n.terms <- length(terms) if (n.terms < 2) stop("model contains fewer than 2 terms") R <- cov2cor(v) detR <- det(R) result <- matrix(0, n.terms, 3) rownames(result) <- terms colnames(result) <- c("GVIF", "Df", "GVIF^(1/(2*Df))") for (term in 1:n.terms) { subs <- which(assign == term) result[term, 1] <- det(as.matrix(R[subs, subs])) * det(as.matrix(R[-subs, -subs])) / detR result[term, 2] <- length(subs) } if (all(result[, 2] == 1)) result <- result[, 1] else result[, 3] <- result[, 1]^(1/(2 * result[, 2])) result } model.matrix.gls <- function(object, ...){ model.matrix(formula(object), data=eval(object$call$data)) } vif.polr <- function(mod, ...) { if (any(is.na(coef(mod)))) stop ("there are aliased coefficients in the model") v <- vcov(mod) nms <- names(coef(mod)) v <- v[nms, nms] assign <- attr(model.matrix(mod), "assign") assign <- assign[assign != 0] terms <- labels(terms(mod)) n.terms <- length(terms) if (n.terms < 2) stop("model contains fewer than 2 terms") R <- cov2cor(v) detR <- det(R) result <- matrix(0, n.terms, 3) rownames(result) <- terms colnames(result) <- c("GVIF", "Df", "GVIF^(1/(2*Df))") for (term in 1:n.terms) { subs <- which(assign == term) result[term, 1] <- det(as.matrix(R[subs, subs])) * det(as.matrix(R[-subs, -subs])) / detR result[term, 2] <- length(subs) } if (all(result[, 2] == 1)) result <- result[, 1] else result[, 3] <- result[, 1]^(1/(2 * result[, 2])) result } vif.svyolr <- function(mod, ...) { if (any(is.na(coef(mod)))) stop ("there are aliased coefficients in the model") v <- vcov(mod) nms <- names(coef(mod, intercepts=FALSE)) v <- v[nms, nms] assign <- attr(model.matrix(mod), "assign") assign <- assign[assign != 0] terms <- labels(terms(mod)) n.terms <- length(terms) if (n.terms < 2) stop("model contains fewer than 2 terms") R <- cov2cor(v) detR <- det(R) result <- matrix(0, n.terms, 3) rownames(result) <- terms colnames(result) <- c("GVIF", "Df", "GVIF^(1/(2*Df))") for (term in 1:n.terms) { subs <- which(assign == term) result[term, 1] <- det(as.matrix(R[subs, subs])) * det(as.matrix(R[-subs, -subs])) / detR result[term, 2] <- length(subs) } if (all(result[, 2] == 1)) result <- result[, 1] else result[, 3] <- result[, 1]^(1/(2 * result[, 2])) result } car/R/TransformationAxes.R0000644000176000001440000001444714140261763015240 0ustar ripleyusers# Axes for transformations (J. Fox) # last modified 2018-02-01 by J. Fox # functions to add untransformed axis to right or top of a plot # for power, Box-Cox, or Yeo-Johnson transformations basicPowerAxis <- function(power, base=exp(1), side=c("right", "above", "left", "below"), at, start=0, lead.digits=1, n.ticks, grid=FALSE, grid.col=gray(0.50), grid.lty=2, axis.title="Untransformed Data", cex=1, las=par("las")) { side <- if(is.numeric(side)) side else which(match.arg(side) == c("below", "left", "above", "right")) axp <- if (side %% 2 == 1) par("xaxp") else par("yaxp") if (missing(n.ticks)) n.ticks <- axp[3] + 1 ticks <- nice(seq(from=axp[1], to=axp[2], length=n.ticks), lead.digits=lead.digits) ticks.x <- if (power != 0) nice(ticks[ticks > 0]^(1/power), lead.digits=lead.digits) else nice(log(base)*exp(ticks), lead.digits=lead.digits) ticks.x <- if (missing(at)) ticks.x else at ticks.text <- as.character(ticks.x - start) ticks.trans <- if (power != 0) ticks.x^power else log(ticks.x, base) axis(side, labels=ticks.text, at=ticks.trans, las=las) if (grid && (side %% 2 == 0)) abline(h=ticks.trans, lty=grid.lty, col=grid.col) if (grid && (side %% 2 == 1)) abline(v=ticks.trans, lty=grid.lty, col=grid.col) mtext(axis.title, side=side, line=3, cex=cex) } bcPowerAxis <- function(power, side=c("right", "above", "left", "below"), at, start=0, lead.digits=1, n.ticks, grid=FALSE, grid.col=gray(0.50), grid.lty=2, axis.title="Untransformed Data", cex=1, las=par("las")) { inverse.power <- function(x, p){ if (p == 0) exp(x) else (1 + p*x)^(1/p) } side <- if (is.numeric(side)) side else which(match.arg(side) == c("below", "left", "above", "right")) axp <- if (side %% 2 == 1) par("xaxp") else par("yaxp") if (missing(n.ticks)) n.ticks <- axp[3] + 1 ticks <- nice(seq(from=axp[1], to=axp[2], length=n.ticks), lead.digits=lead.digits) ticks.x <- if (power != 0) nice(inverse.power(ticks[ticks > 0], power), lead.digits=lead.digits) else nice(inverse.power(ticks, 0), lead.digits=lead.digits) ticks.x <- if (missing(at)) ticks.x else at ticks.text <- as.character(ticks.x - start) ticks.trans <- bcPower(ticks.x, power) axis(side, labels=ticks.text, at=ticks.trans, las=las) if (grid && (side %% 2 == 0)) abline(h=ticks.trans, lty=grid.lty, col=grid.col) if (grid && (side %% 2 == 1)) abline(v=ticks.trans, lty=grid.lty, col=grid.col) mtext(axis.title, side=side, line=3, cex=cex) } bcnPowerAxis <- function(power, shift, side=c("right", "above", "left", "below"), at, start=0, lead.digits=1, n.ticks, grid=FALSE, grid.col=gray(0.50), grid.lty=2, axis.title="Untransformed Data", cex=1, las=par("las")) { side <- if (is.numeric(side)) side else which(match.arg(side) == c("below", "left", "above", "right")) axp <- if (side %% 2 == 1) par("xaxp") else par("yaxp") if (missing(n.ticks)) n.ticks <- axp[3] + 1 ticks <- nice(seq(from=axp[1], to=axp[2], length=n.ticks), lead.digits=lead.digits) ticks.x <- if (power != 0) nice(bcnPowerInverse(ticks[ticks > 0], lambda=power, gamma=shift), lead.digits=lead.digits) else nice(bcnPowerInverse(ticks, lambda=0, gamma=shift), lead.digits=lead.digits) ticks.x <- if (missing(at)) ticks.x else at ticks.text <- as.character(ticks.x - start) ticks.trans <- bcnPower(ticks.x, lambda=power, gamma=shift) axis(side, labels=ticks.text, at=ticks.trans, las=las) if (grid && (side %% 2 == 0)) abline(h=ticks.trans, lty=grid.lty, col=grid.col) if (grid && (side %% 2 == 1)) abline(v=ticks.trans, lty=grid.lty, col=grid.col) mtext(axis.title, side=side, line=3, cex=cex) } yjPowerAxis <- function(power, side=c("right", "above", "left", "below"), at, lead.digits=1, n.ticks, grid=FALSE, grid.col=gray(0.50), grid.lty=2, axis.title="Untransformed Data", cex=1, las=par("las")) { inverse.bc <- function(x,p){ if (p == 0) exp(x) else (1 + p*x)^(1/p) } inverse.power <- function(x, p){ ifelse(x == 0, 0, ifelse(x > 0, inverse.bc(x, p) - 1, -inverse.bc(abs(x), 2 - p) + 1)) } side <- if(is.numeric(side)) side else which(match.arg(side) == c("below", "left", "above", "right")) axp <- if (side %% 2 == 1) par("xaxp") else par("yaxp") if (missing(n.ticks)) n.ticks <- axp[3] + 1 ticks <- nice(seq(from=axp[1], to=axp[2], length=n.ticks), lead.digits=lead.digits) ticks.x <- nice(inverse.power(ticks, power), lead.digits=lead.digits) ticks.x <- if (missing(at)) ticks.x else at ticks.text <- as.character(ticks.x) ticks.trans <- yjPower(ticks.x, power) axis(side, labels=ticks.text, at=ticks.trans, las=las) if (grid && (side %% 2 == 0)) abline(h=ticks.trans, lty=grid.lty, col=grid.col) if (grid && (side %% 2 == 1)) abline(v=ticks.trans, lty=grid.lty, col=grid.col) mtext(axis.title, side=side, line=3, cex=cex) } # function to add a right or top probability axis to a plot of logits or probits probabilityAxis <- function(scale=c("logit", "probit"), side=c("right", "above", "left", "below"), at, lead.digits=1, grid=FALSE, grid.lty=2, grid.col=gray(0.50), axis.title = "Probability", interval = 0.1, cex = 1, las=par("las")){ side <- if(is.numeric(side)) side else which(match.arg(side) == c("below", "left", "above", "right")) scale <- match.arg(scale) trans <- if (scale == "logit") function(p) log(p/(1 - p)) else qnorm inv.trans <- if (scale == "logit") function(x) 1/(1 + exp(-x)) else pnorm x <- if (side %% 2 == 1) par("usr")[c(1, 2)] else par("usr")[c(3, 4)] fact <- 10^( - (floor(log(interval, 10)))) p.min <- nice(inv.trans(x[1]), direction="down", lead.digits=lead.digits) p.max <- nice(inv.trans(x[2]), direction="up", lead.digits=lead.digits) tick.min <- max(interval, (floor(fact*p.min))/fact) tick.max <- min(1 - interval, (ceiling(fact*p.max))/fact) ticks.p <- seq(tick.min, tick.max, interval) mins <- c(.05, .01, .005, .001, .0005, .0001) maxs <- c(.95, .99, .995, .999, .9995, .9999) ticks.p <- c(mins[mins >= p.min], ticks.p) ticks.p <- c(ticks.p, c(maxs[maxs <= p.max])) ticks.p <- if (missing(at)) ticks.p else at ticks.text <- as.character(ticks.p) ticks.x <- trans(ticks.p) axis(side, labels=ticks.text, at=ticks.x, las=las) if (grid && (side %% 2 == 0)) abline(h=ticks.x, lty=grid.lty, col=grid.col) if (grid && (side %% 2 == 1)) abline(v=ticks.x, lty=grid.lty, col=grid.col) mtext(axis.title, side=side, line=3, cex=cex) } car/R/which.names.R0000644000176000001440000000174014140261763013605 0ustar ripleyusers# positions of names in a data frame (J. Fox) # last modified 2018-01-30 by J. Fox whichNames <- function(names, object, ...){ UseMethod("whichNames", object) } which.names <- function(names, object, ...){ UseMethod("whichNames", object) } whichNames.data.frame <- function(names, object, ...){ row.names <- row.names(object) check <- outer(row.names, names, '==') if (!all(matched <- apply(check, 2, any))) warning(paste(paste(names[!matched], collapse=", "), "not matched")) result <- which(apply(check, 1, any)) names(result) <- row.names[result] result[names[matched]] } whichNames.default <- function(names, object, ...){ obj.names <- names(object) check <- outer(obj.names, names, '==') if (!all(matched <- apply(check, 2, any))) warning(paste(paste(names[!matched], collapse=", "), "not matched")) result <- which(apply(check, 1, any)) names(result) <- obj.names[result] result[names[matched]] }car/R/scatterplotMatrix.R0000644000176000001440000003367314140261763015144 0ustar ripleyusers# fancy scatterplot matrices (J. Fox) # 2010-09-04: J. Fox: changed color choice # 2010-09-16: fixed point color when col is length 1 # 2011-03-08: J. Fox: changed col argument # 2012-04-18: J. Fox: fixed labels argument in scatterplotMatrix.formula() # 2012-09-12: J. Fox: smoother now given as function # 2012-09-19: J. Fox: restored smooth and span args for backwards compatibility # 2013-02-08: S. Weisberg: bug-fix for showLabels with groups # 2013-08-26: J. Fox: added use argument # 2014-08-07: J. Fox: plot univariate distributions by group (except for histogram) # 2014-08-17: J. Fox: report warning rather than error if not enough points in a group # to compute density # 2014-09-04: J. Fox: empty groups produce warning rather than error # 2017-02-14: J. Fox: consolidated smooth, id, legend, and ellipse arguments # 2017-02-17: S. Weisberg, more changes to arguments # 2017-02-19: J. Fox: bug fixes and improvement to col argument # 2017-04-18; S. Weisberg fixed bug in handling id=FALSE with matrix/data frame input. # 2017-04-18; S. Weisberg changed the default for by.groups to TRUE # 2017-04-20: S. Weisberg fixed bug with color handling # 2017-04-20: S. Weisberg the default diagonal is now adaptiveDensity using adaptiveKernel fn # diagonal argument is now a list similar to regLine and smooth # changed arguments and updated man page # 2017-05-08: S. Weisberg changed col=carPalette() # 2017-06-22: J. Fox: eliminated extraneous code for defunct labels argument; small cleanup # 2017-12-07: J. Fox: added fill, fill.alpha subargs to ellipse arg, suggestion of Michael Friendly. # 2018-02-09: S. Weisberg removed the transform and family arguments from the default method # 2018-04-02: J. Fox: warning rather than error for too few colors. # 2018-04-12: J. Fox: clean up handling of groups arg. # 2020-07-02: J. Fox: fix buglet in scatterplotMatrix.formula() when groups specified. scatterplotMatrix <- function(x, ...){ UseMethod("scatterplotMatrix") } scatterplotMatrix.formula <- function (formula, data=NULL, subset, ...) { na.save <- options(na.action=na.omit) on.exit(options(na.save)) na.pass <- function(dframe) dframe m <- match.call(expand.dots = FALSE) if (is.matrix(eval(m$data, sys.frame(sys.parent())))) m$data <- as.data.frame(data) m$id <- m$formula <- m$... <- NULL m$na.action <- na.pass m[[1]] <- as.name("model.frame") if (!inherits(formula, "formula") | length(formula) != 2) stop("invalid formula") rhs <- formula[[2]] if ("|" != deparse(rhs[[1]])){ groups <- FALSE } else{ groups <- TRUE formula <- paste(as.character(formula), collapse=" ") formula <- as.formula(sub("\\|", "+", formula)) } m$formula <-formula if (missing(data)){ X <- na.omit(eval(m, parent.frame())) # if (is.null(labels)) labels <- gsub("X", "", row.names(X)) } else{ X <- eval(m, parent.frame()) # if (is.null(labels)) labels <- rownames(X) } if (!groups) scatterplotMatrix(X, ...) else{ ncol<-ncol(X) scatterplotMatrix.default(X[, -ncol], groups=X[, ncol], ...) } } scatterplotMatrix.default <- function(x, smooth=TRUE, id=FALSE, legend=TRUE, regLine=TRUE, ellipse=FALSE, var.labels=colnames(x), diagonal=TRUE, plot.points=TRUE, groups=NULL, by.groups=TRUE, use=c("complete.obs", "pairwise.complete.obs"), col=carPalette()[-1], pch=1:n.groups, cex=par("cex"), cex.axis=par("cex.axis"), cex.labels=NULL, cex.main=par("cex.main"), row1attop=TRUE, ...){ transform <- FALSE # family <- "bcPower" force(col) # n.groups <- if(by.groups) length(levels(groups)) else 1 if(isFALSE(diagonal)) diagonal <- "none" else { diagonal.args <- applyDefaults(diagonal, defaults=list(method="adaptiveDensity"), type="diag") diagonal <- if(!isFALSE(diagonal.args)) diagonal.args$method diagonal.args$method <- NULL } # regLine; use old arguments reg.line, lty and lwd regLine.args <- applyDefaults(regLine, defaults=list(method=lm, lty=1, lwd=2, col=col), type="regLine") if(!isFALSE(regLine.args)) { reg.line <- regLine.args$method lty <- regLine.args$lty lwd <- regLine.args$lwd } else reg.line <- "none" # setup smoother, now including spread n.groups <- if(is.null(groups)) 1 else { if (!is.factor(groups)) groups <- as.factor(groups) length(levels(groups)) } smoother.args <- applyDefaults(smooth, defaults=list(smoother=loessLine, spread=(n.groups)==1, col=col, lty.smooth=2, lty.spread=4), type="smooth") if (!isFALSE(smoother.args)) { # check for an argument 'var' in smoother.args. if(!is.null(smoother.args$var)) smoother.args$spread <- smoother.args$var # end change smoother <- smoother.args$smoother spread <- if(is.null(smoother.args$spread)) TRUE else smoother.args$spread smoother.args$spread <- smoother.args$smoother <- NULL if(n.groups==1) smoother.args$col <- col[1] } else smoother <- "none" # setup id id <- applyDefaults(id, defaults=list(method="mahal", n=2, cex=1, col=col, location="lr"), type="id") if (is.list(id) && "identify" %in% id$method) stop("interactive point identification not permitted") if (isFALSE(id)){ id.n <- 0 id.method <- "mahal" labels <- id.cex <- id.col <- id.location <- NULL } else{ labels <- if(!is.null(id$labels)) id$labels else row.names(x) id.method <- id$method id.n <- id$n id.cex <- id$cex id.col <- id$col id.location <- id$location } if (is.null(labels)) labels <- as.character(seq(length.out=nrow(x))) legend <- applyDefaults(legend, defaults=list(coords=NULL), type="legend") if (!(isFALSE(legend) || missing(groups))){ legend.plot <- TRUE legend.pos <- legend$coords } else { legend.plot <- FALSE legend.pos <- NULL } # ellipse ellipse <- applyDefaults(ellipse, defaults=list(levels=c(0.5, 0.95), robust=TRUE, fill=TRUE, fill.alpha=0.2), type="ellipse") if (isFALSE(ellipse)){ levels <- NULL robust <- NULL } else{ levels <- ellipse$levels robust <- ellipse$robust fill <- ellipse$fill fill.alpha <- ellipse$fill.alpha ellipse <- TRUE } # pre 2017 code follows # family <- match.arg(family) use <- match.arg(use) na.action <- if (use == "complete.obs") na.omit else na.pass if (!(missing(groups))){ x <- na.action(data.frame(groups, labels, x, stringsAsFactors=FALSE)) # groups <- as.factor(as.character(x[, 1])) groups <- x$groups # if (!is.factor(groups)) groups <- as.factor(as.character(x[,1])) labels <- x[, 2] x <- x[, -(1:2)] } else { x <- na.action(data.frame(labels, x, stringsAsFactors=FALSE)) labels <- x[, 1] x <- x[, -1] id.col <- id.col[1] } legendPlot <- function(position="topright"){ usr <- par("usr") legend(position, bg="white", legend=levels(groups), pch=pch, col=col[1:n.groups], cex=cex) } do.legend <- legend.plot ####### diagonal panel functions # The following panel function adapted from Richard Heiberger panel.adaptiveDensity <- function(x, ...){ args <- applyDefaults(diagonal.args, defaults=list(bw=bw.nrd0, adjust=1, kernel=dnorm, na.rm=TRUE)) if (n.groups > 1){ levs <- levels(groups) for (i in 1:n.groups){ xx <- x[levs[i] == groups] dens.x <- try(adaptiveKernel(xx, adjust = args$adjust, na.rm=args$na.rm, bw=args$bw, kernel=args$kernel), silent=TRUE) if (!inherits(dens.x, "try-error")){ lines(dens.x$x, min(x, na.rm=TRUE) + dens.x$y * diff(range(x, na.rm=TRUE))/diff(range(dens.x$y, na.rm=TRUE)), col=col[i]) } else warning("cannot estimate density for group ", levs[i], "\n", dens.x, "\n") rug(xx, col=col[i]) } } else { dens.x <- adaptiveKernel(x, adjust = args$adjust, na.rm=args$na.rm, bw=args$bw, kernel=args$kernel) lines(dens.x$x, min(x, na.rm=TRUE) + dens.x$y * diff(range(x, na.rm=TRUE))/diff(range(dens.x$y, na.rm=TRUE)), col=col[1]) rug(x) } if (do.legend) legendPlot(position=if (is.null(legend.pos)) "topright" else legend.pos) do.legend <<- FALSE } # panel.density <- function(x, ...){ args <- applyDefaults(diagonal.args, defaults=list(bw="nrd0", adjust=1, kernel="gaussian", na.rm=TRUE)) if (n.groups > 1){ levs <- levels(groups) for (i in 1:n.groups){ xx <- x[levs[i] == groups] dens.x <- try(density(xx, adjust = args$adjust, na.rm=args$na.rm, bw=args$bw, kernel=args$kernel), silent=TRUE) if (!inherits(dens.x, "try-error")){ lines(dens.x$x, min(x, na.rm=TRUE) + dens.x$y * diff(range(x, na.rm=TRUE))/diff(range(dens.x$y, na.rm=TRUE)), col=col[i]) } else warning("cannot estimate density for group ", levs[i], "\n", dens.x, "\n") rug(xx, col=col[i]) } } else { dens.x <- density(x, adjust = args$adjust, na.rm=args$na.rm, bw=args$bw, kernel=args$kernel) lines(dens.x$x, min(x, na.rm=TRUE) + dens.x$y * diff(range(x, na.rm=TRUE))/diff(range(dens.x$y, na.rm=TRUE)), col=col[1]) rug(x) } if (do.legend) legendPlot(position=if (is.null(legend.pos)) "topright" else legend.pos) do.legend <<- FALSE } panel.histogram <- function(x, ...){ par(new=TRUE) args <- applyDefaults(diagonal.args, defaults=list(breaks="FD")) h.col <- col[1] if (h.col == "black") h.col <- "gray" hist(x, main="", axes=FALSE, breaks=args$breaks, col=h.col) if (do.legend) legendPlot(position=if (is.null(legend.pos)) "topright" else legend.pos) do.legend <<- FALSE } panel.boxplot <- function(x, ...){ b.col <- col[1:n.groups] b.col[b.col == "black"] <- "gray" par(new=TRUE) if (n.groups == 1) boxplot(x, axes=FALSE, main="", col=col[1]) else boxplot(x ~ groups, axes=FALSE, main="", col=b.col) if (do.legend) legendPlot(position=if (is.null(legend.pos)) "topright" else legend.pos) do.legend <<- FALSE } # The following panel function adapted from Richard Heiberger panel.oned <- function(x, ...) { range <- range(x, na.rm=TRUE) delta <- diff(range)/50 y <- mean(range) if (n.groups == 1) segments(x - delta, x, x + delta, x, col = col[1]) else { segments(x - delta, x, x + delta, x, col = col[as.numeric(groups)]) } if (do.legend) legendPlot(position=if (is.null(legend.pos)) "bottomright" else legend.pos) do.legend <<- FALSE } panel.qqplot <- function(x, ...){ par(new=TRUE) if (n.groups == 1) qqnorm(x, axes=FALSE, xlab="", ylab="", main="", col=col[1]) else qqnorm(x, axes=FALSE, xlab="", ylab="", main="", col=col[as.numeric(groups)]) qqline(x, col=col[1]) if (do.legend) legendPlot(position=if (is.null(legend.pos)) "bottomright" else legend.pos) do.legend <<- FALSE } panel.blank <- function(x, ...){ if (do.legend) legendPlot(if (is.null(legend.pos)) "topright" else legend.pos) do.legend <<- FALSE } which.fn <- match(diagonal, c("adaptiveDensity", "density", "boxplot", "histogram", "oned", "qqplot", "none")) if(is.na(which.fn)) stop("incorrect name for the diagonal argument, see ?scatterplotMatrix") diag <- list(panel.adaptiveDensity, panel.density, panel.boxplot, panel.histogram, panel.oned, panel.qqplot, panel.blank)[[which.fn]] groups <- as.factor(if(missing(groups)) rep(1, length(x[, 1])) else groups) counts <- table(groups) if (any(counts == 0)){ levels <- levels(groups) warning("the following groups are empty: ", paste(levels[counts == 0], collapse=", ")) groups <- factor(groups, levels=levels[counts > 0]) } # n.groups <- length(levels(groups)) if (n.groups > length(col)) { warning("number of groups exceeds number of available colors\n colors are recycled") col <- rep(col, n.groups) } if (length(col) == 1) col <- rep(col, 3) labs <- labels pairs(x, labels=var.labels, cex.axis=cex.axis, cex.main=cex.main, cex.labels=cex.labels, cex=cex, diag.panel=diag, row1attop = row1attop, panel=function(x, y, ...){ for (i in 1:n.groups){ subs <- groups == levels(groups)[i] if (plot.points) points(x[subs], y[subs], pch=pch[i], col=col[if (n.groups == 1) 1 else i], cex=cex) if (by.groups){ if (is.function(smoother)) smoother(x[subs], y[subs], col=smoother.args$col[i], log.x=FALSE, log.y=FALSE, spread=spread, smoother.args=smoother.args) if (is.function(reg.line)) regLine(reg.line(y[subs] ~ x[subs]), lty=lty, lwd=lwd, col=regLine.args$col[i]) if (ellipse) dataEllipse(x[subs], y[subs], plot.points=FALSE, levels=levels, col=col[i], robust=robust, lwd=1, fill=fill, fill.alpha=fill.alpha) showLabels(x[subs], y[subs], labs[subs], method=id.method, n=id.n, col=col[i], cex=id.cex, location=id.location, all=list(labels=labs, subs=subs)) } } if (!by.groups){ if (is.function(reg.line)) abline(reg.line(y ~ x), lty=lty, lwd=lwd, col=regLine.args$col[1]) if (is.function(smoother)) smoother(x, y, col=col[1], log.x=FALSE, log.y=FALSE, spread=spread, smoother.args=smoother.args) if (ellipse) dataEllipse(x, y, plot.points=FALSE, levels=levels, col=smoother.args$col, robust=robust, lwd=1, fill=fill, fill.alpha=fill.alpha) showLabels(x, y, labs, method=id.method, n=id.n, col=id.col, location=id.location, cex=id.cex) } }, ... ) } spm <- function(x, ...){ scatterplotMatrix(x, ...) } car/R/poTest.R0000644000176000001440000000543214140261763012661 0ustar ripleyusers# added by J. Fox on 2017-10-14 poTest <- function(model, ...){ UseMethod("poTest") } poTest.polr <- function(model, ...){ if (model$method != "logistic") stop("test for proportional odds is only for the logistic model") X <- model.matrix(model) y <- model.frame(model)[, 1] levels <- levels(y) k <- length(levels) p <- ncol(X) - 1 y <- as.numeric(y) models <- vector(k - 1, mode="list") for (j in 1:(k - 1)){ models[[j]] <- glm(y > j ~ X - 1, family=binomial) } vcov <- matrix(0, (k - 1)*p, (k - 1)*p) for (el in 1:(k - 1)){ for (j in 1:el){ W.j.el <- fitted(models[[el]]) - fitted(models[[j]])*fitted(models[[el]]) W.el.el <- fitted(models[[el]]) - fitted(models[[el]])^2 W.j.j <- fitted(models[[j]]) - fitted(models[[j]])^2 V <- solve(t(X * W.j.j) %*% X) %*% (t(X * W.j.el) %*% X) %*% solve(t(X * W.el.el) %*% X) subs.j <- (j - 1)*p + 1:p subs.el <- (el - 1)*p + 1:p vcov[subs.j, subs.el] <- vcov[subs.el, subs.j] <- V[-1, -1] } } beta <- unlist(lapply(models, function(m) coef(m)[-1])) D <- matrix(0, (k - 2)*p, (k - 1)*p) I <- diag(p) for (j in 1:(k - 2)){ subs.j <- (j - 1)*p + 1:p subs.el <- j*p + 1:p D[subs.j, 1:p] <- I D[subs.j, subs.el] <- -I } chisq <- t(D %*% beta) %*% solve(D %*% vcov %*% t(D)) %*% (D %*% beta) df <- (k - 2)*p chisq.p <- numeric(p) zeros <- matrix(0, k - 2, (k - 1)*p) D.p <- vector(p, mode="list") for (i in 1:p){ DD <- zeros j <- 1:(k - 2) DD[j, i] <- 1 DD[cbind(j, j*p + i)] <- -1 chisq.p[i] <- t(DD %*% beta) %*% solve(DD %*% vcov %*% t(DD)) %*% (DD %*% beta) D.p[[i]] <- DD } b <- coef(model) coef.names <- names(b) b <- cbind(b, matrix(beta, ncol = k - 1)) colnames(b) <- c("b[polr]", paste0("b[>", levels[1:(k - 1)], "]")) result <- list(call=model$call, coef.names=coef.names, b=b, vcov=vcov, D=D, chisq=as.vector(chisq), df=df, D.p=D.p, chisq.p=chisq.p, df.p = k - 2) class(result) <- "poTest" result } print.poTest <- function(x, digits=3, ...){ cat("\nTests for Proportional Odds\n") print(x$call) cat("\n") names <- c("Overall", x$coef.names) chisq <- c(x$chisq, x$chisq.p) df <- c(x$df, rep(x$df.p, length(x$chisq.p))) pval <- pchisq(chisq, df, lower.tail=FALSE) table <- cbind(chisq, df, pval) colnames(table) <- c("Chisquare", "df", "Pr(>Chisq)") b <- x$b b <- rbind(rep(NA, ncol(b)), b) table <- cbind(b, table) rownames(table) <- names printCoefmat(table, P.values=TRUE, has.Pvalue=TRUE, tst.ind = ncol(b) + 1, na.print="", digits=digits) invisible(x) } car/R/Predict.R0000644000176000001440000001717114140261763013000 0ustar ripleyusers# 2017-11-07: added complete=FALSE to vcov.() call exists.method <- function(generic, object, default=TRUE, strict=FALSE){ # this function copied from the Rcmdr package; won't be exported classes <- class(object) if (default) classes <- c(classes, "default") if (strict) classes <- classes[1] any(paste(generic, ".", classes, sep="") %in% as.character(methods(generic))) } Predict <- function(object, ...){ if (exists.method("Predict", object, strict=TRUE)) UseMethod("Predict") else if (!exists.method("predict", object, strict=TRUE) && exists.method("Predict", object)) UseMethod("Predict") else UseMethod("predict") } # Predict.default <- function(object, ...){ # doesn't work correctly # UseMethod("predict") # } Predict.lm <-function (object, newdata, se.fit = FALSE, scale = NULL, df = Inf, interval = c("none", "confidence", "prediction"), level = 0.95, type = c("response", "terms"), terms = NULL, na.action = na.pass, pred.var = res.var/weights, weights = 1, vcov., ...) { # modified version of stats::predict.lm() # the next two local functions copied from stats package qr.lm <- function (x, ...) { if (is.null(r <- x$qr)) stop("lm object does not have a proper 'qr' component.\n Rank zero or should not have used lm(.., qr=FALSE).") r } weights.default <- function (object, ...) { wts <- object$weights if (is.null(wts)) wts else napredict(object$na.action, wts) } tt <- terms(object) if (!inherits(object, "lm")) warning("calling predict.lm() ...") if (missing(newdata) || is.null(newdata)) { mm <- X <- model.matrix(object) mmDone <- TRUE offset <- object$offset } else { Terms <- delete.response(tt) m <- model.frame(Terms, newdata, na.action = na.action, xlev = object$xlevels) if (!is.null(cl <- attr(Terms, "dataClasses"))) .checkMFClasses(cl, m) X <- model.matrix(Terms, m, contrasts.arg = object$contrasts) offset <- rep(0, nrow(X)) if (!is.null(off.num <- attr(tt, "offset"))) for (i in off.num) offset <- offset + eval(attr(tt, "variables")[[i + 1]], newdata) if (!is.null(object$call$offset)) offset <- offset + eval(object$call$offset, newdata) mmDone <- FALSE } n <- length(object$residuals) p <- object$rank p1 <- seq_len(p) piv <- if (p) qr.lm(object)$pivot[p1] if (p < ncol(X) && !(missing(newdata) || is.null(newdata))) warning("prediction from a rank-deficient fit may be misleading") beta <- object$coefficients predictor <- drop(X[, piv, drop = FALSE] %*% beta[piv]) if (!is.null(offset)) predictor <- predictor + offset interval <- match.arg(interval) if (interval == "prediction") { if (missing(newdata)) warning("predictions on current data refer to _future_ responses\n") if (missing(newdata) && missing(weights)) { w <- weights.default(object) if (!is.null(w)) { weights <- w warning("assuming prediction variance inversely proportional to weights used for fitting\n") } } if (!missing(newdata) && missing(weights) && !is.null(object$weights) && missing(pred.var)) warning("Assuming constant prediction variance even though model fit is weighted\n") if (inherits(weights, "formula")) { if (length(weights) != 2L) stop("'weights' as formula should be one-sided") d <- if (missing(newdata) || is.null(newdata)) model.frame(object) else newdata weights <- eval(weights[[2L]], d, environment(weights)) } } type <- match.arg(type) if (se.fit || interval != "none") { w <- object$weights res.var <- if (is.null(scale)) { r <- object$residuals rss <- sum(if (is.null(w)) r^2 else r^2 * w) df <- object$df.residual rss/df } else scale^2 if (type != "terms") { if (p > 0) { if (missing(vcov.)){ XRinv <- if (missing(newdata) && is.null(w)) qr.Q(qr.lm(object))[, p1, drop = FALSE] else X[, piv] %*% qr.solve(qr.R(qr.lm(object))[p1, p1]) ip <- drop(XRinv^2 %*% rep(res.var, p)) } else{ V <- if (is.function(vcov.)) vcov.(object) else if (is.matrix(vcov.)) vcov. else stop("vcov. must be a function or a matrix") if (p < ncol(X)){ # rank-deficient case b <- coef(object) nms <- names(b[!is.na(b)]) X <- X[, nms] } ip <- diag(X %*% V %*% t(X)) } } else ip <- rep(0, n) } } if (type == "terms") { if (!missing(vcov.)) warning("vcov. argument not used for type='terms'") if (!mmDone) { mm <- model.matrix(object) mmDone <- TRUE } aa <- attr(mm, "assign") ll <- attr(tt, "term.labels") hasintercept <- attr(tt, "intercept") > 0L if (hasintercept) ll <- c("(Intercept)", ll) aaa <- factor(aa, labels = ll) asgn <- split(order(aa), aaa) if (hasintercept) { asgn$"(Intercept)" <- NULL avx <- colMeans(mm) termsconst <- sum(avx[piv] * beta[piv]) } nterms <- length(asgn) if (nterms > 0) { predictor <- matrix(ncol = nterms, nrow = NROW(X)) dimnames(predictor) <- list(rownames(X), names(asgn)) if (se.fit || interval != "none") { ip <- matrix(ncol = nterms, nrow = NROW(X)) dimnames(ip) <- list(rownames(X), names(asgn)) Rinv <- qr.solve(qr.R(qr.lm(object))[p1, p1]) } if (hasintercept) X <- sweep(X, 2L, avx, check.margin = FALSE) unpiv <- rep.int(0L, NCOL(X)) unpiv[piv] <- p1 for (i in seq.int(1L, nterms, length.out = nterms)) { iipiv <- asgn[[i]] ii <- unpiv[iipiv] iipiv[ii == 0L] <- 0L predictor[, i] <- if (any(iipiv > 0L)) X[, iipiv, drop = FALSE] %*% beta[iipiv] else 0 if (se.fit || interval != "none") ip[, i] <- if (any(iipiv > 0L)) as.matrix(X[, iipiv, drop = FALSE] %*% Rinv[ii, , drop = FALSE])^2 %*% rep.int(res.var, p) else 0 } if (!is.null(terms)) { predictor <- predictor[, terms, drop = FALSE] if (se.fit) ip <- ip[, terms, drop = FALSE] } } else { predictor <- ip <- matrix(0, n, 0L) } attr(predictor, "constant") <- if (hasintercept) termsconst else 0 } if (interval != "none") { tfrac <- qt((1 - level)/2, df) hwid <- tfrac * switch(interval, confidence = sqrt(ip), prediction = sqrt(ip + pred.var)) if (type != "terms") { predictor <- cbind(predictor, predictor + hwid %o% c(1, -1)) colnames(predictor) <- c("fit", "lwr", "upr") } else { if (!is.null(terms)) hwid <- hwid[, terms, drop = FALSE] lwr <- predictor + hwid upr <- predictor - hwid } } if (se.fit || interval != "none") { se <- sqrt(ip) if (type == "terms" && !is.null(terms) && !se.fit) se <- se[, terms, drop = FALSE] } if (missing(newdata) && !is.null(na.act <- object$na.action)) { predictor <- napredict(na.act, predictor) if (se.fit) se <- napredict(na.act, se) } if (type == "terms" && interval != "none") { if (missing(newdata) && !is.null(na.act)) { lwr <- napredict(na.act, lwr) upr <- napredict(na.act, upr) } list(fit = predictor, se.fit = se, lwr = lwr, upr = upr, df = df, residual.scale = sqrt(res.var)) } else if (se.fit) list(fit = predictor, se.fit = se, df = df, residual.scale = sqrt(res.var)) else predictor } car/R/ceresPlots.R0000644000176000001440000001661614140261763013534 0ustar ripleyusers# CERES plots (J. Fox) # last modified 9 October 2009 by J. Fox # modified 26 Nov 2009 by S. Weisberg # changed layout and point marking. # modified 15 Mar 2010 by S. Weisberg to make the following work: # m1 <- lm(longley) # ceresPlots(longley) # 14 April 2010: set id.n = 0. J. Fox # new args for showLabels 15 April S. Weisberg # modified 2 Sept 2010 by S. Weisberg, made colors, axes lables, and # arguments more consistent with other functions; ... passes args to plot # and boxplot. # 16 June 2011 allow layout=NA, in which case the layout is not set in this # function, so it is the responsibility of the user # 14 Sept 2012 use the ScatterplotSmoothers in car # 18 Sept 2012 restore smooth and span args # 20 Aug 2013 replace residuals.glm() with residuals(). John # 2017-02-11: consolidated id and smooth arguments. John # 2017-11-30: substitute carPalette() for palette(). J. Fox # 2019-11-14: change class(x) == "y" to inherits(x, "y") # 2018-07-13: made ceresPlots() generic. J. Fox # 2018-08-06: enabled spread and var for smoothers. J. Fox ceresPlots <- function(model, ...){ UseMethod("ceresPlots") } ceresPlots.default<-function(model, terms= ~ ., layout=NULL, ask, main, ...){ terms <- if(is.character(terms)) paste("~", terms) else terms vform <- update(formula(model), terms) if(any(is.na(match(all.vars(vform), all.vars(formula(model)))))) stop("Only predictors in the formula can be plotted.") mf <- attr(model.frame(model), "terms") terms <- attr(mf, "term.labels") # this is a list vterms <- attr(terms(vform), "term.labels") good <- NULL if (any(attr(terms(model),"order")>1)) { stop("CERES plots not available for models with interactions.")} for (term in vterms) if( inherits(model$model[[term]], "numeric") | inherits(model$model[[term]], "integer")) good <- c(good,term) nt <- length(good) if(length(good) < length(vterms)) warning("Factors skipped in drawing CERES plots.") vterms <- good if (nt == 0) stop("No plots specified") if (missing(main)) main <- if (nt == 1) "CERES Plot" else "CERES Plots" if (nt == 0) stop("No plots specified") if (nt > 1 & (is.null(layout) || is.numeric(layout))) { if(is.null(layout)){ layout <- switch(min(nt, 9), c(1, 1), c(1, 2), c(2, 2), c(2, 2), c(3, 2), c(3, 2), c(3, 3), c(3, 3), c(3, 3)) } ask <- if(missing(ask) || is.null(ask)) prod(layout)1)) { stop("ceres plot not available for models with interactions.") } .x<-xvars<-NULL for (xvar in terms){ if (is.null(model$contrasts[[xvar]])){ xvars<-c(xvars,xvar) xx[obs]<-fitted.values(loess(as.formula(paste("mod.mat[,'",xvar,"']~mod.mat[,'",var,"']",sep="")))) .x<-cbind(.x, xx) } } if (is.null(xvars)) stop("There are no covariates.") n.x<-length(xvars) mf<-na.omit(expand.model.frame(model, all.vars(formula(model)))) rownames(.x)<-all.obs mf$.x<-.x[obs,] aug.model <- update(model, . ~ . + .x, data=mf, subset=NULL) aug.mod.mat<-model.matrix(aug.model) coef<-coefficients(aug.model) k<-length(coef) posn<-k:(k-n.x+1) partial.res<-residuals(aug.model, "partial")[,var] + aug.mod.mat[,posn] %*% as.matrix(coef[posn]) xlab <- if(!missing(xlab)) xlab else var ylab <- if(!missing(ylab)) ylab else paste("CERES Residual(",responseName(model),")", sep="") plot(mod.mat[,var], partial.res, xlab=xlab, col=col, pch=pch, ylab=ylab, type="n", ...) if(grid){ grid(lty=1, equilogs=FALSE) box()} points(mod.mat[,var], partial.res, col=col, pch=pch) showLabels(mod.mat[,var], partial.res, labels=labels, method=id.method, n=id.n, cex=id.cex, col=id.col, location=id.location) if (line) abline(lm(partial.res~mod.mat[,var]), lty=2, lwd=lwd, col=col.lines[1]) if (is.function(smoother)) { smoother(mod.mat[, var], partial.res, col=col.lines[2], log.x=FALSE, log.y=FALSE, spread=smoother.args$spread, smoother.args=smoother.args) } } ceresPlot.glm<-function(model, ...){ ceresPlot.lm(model, ...) } car/R/S.R0000644000176000001440000013043114140261763011603 0ustar ripleyusers# Alternatives to `stats` functions for various reasons 12/26/2017 # Summarize.lm: Adds new argument vcov.=vcov to specify a covariance matrix. The default reproduces the # current output. The linearHypothesis function is used to compute the overall F-test. # print.Summarize.lm: new arguments: # header=TRUE prints or suppresses the header # resid.summary=TRUE prints or suppresses the residual summary # adj.r.squared=TRUE prints or suppresses printing of the adjusted r.squared # brief=FALSE if TRUE sets header=resid.summary=adj.r.squared=FALSE # In addition output is modified to include the vcov. argument if it is not set to vcov # Confint.lm: new argument vcov.=vcov where vcov. is either a matrix of the right size or # a fuction so that vcov.(object) returns an estmated covariance matrix. # 2016-12-27 For now, the override functions start with a Capital letter # 2017-02-10: Renamed using uc letters; introduced default methods. J. Fox # 2017-02-21: removed Vcov as it is not needed. Removed vcov=Boot and added an example with # b1 <- Boot(object) # Summarize(object vcov. = cov(b1$t)) # Confint(b1) # to get the same bootstrap and use bca method # Summarize adds vcov. argument # 2017-02-23: S. Weisberg added Summarize.glm and print.Summarize.glm # 2017-05-15: S. Weisberg added singular.ook=TRUE to call to linearHypothesis # 2017-06-15: S. Weisberg moved arguments from print.Summarize to Summarize # 2017-06-22: S. Weisberg added a 'Summarise' method that is the same as 'Summarize' # 2017-09-20: J. Fox added estimate and exponentiate arguments to Confint() # 2017-10-03: J. Fox fixed bug in Confint.default(), which didn't return its result # added Confint.polr(), Confint.multinom(), Summarize.multinom(), # print.Summarize.multinom() # 2017-10-04: J. Fox added S() generic and methods & tweaked some Summarize() and print() methods # 2017-10-10: S. Weisberg fixed bug in dispersion arg in Summarize.glm # 2017-10-11: J. Fox modified Confint.glm() to suppress message about profiling likelihood # 2017-10-12: J. Fox made changes to Confint.glm() et al. to handle vcov. and dispersion args consistently # 2017-10-25: J. Fox added terms and intercept args to S() and methods to print coefficients selectively # 2017-11-02: J. Fox added Summarize() methods for lme, lmer, and glmer objects # 2017-11-07,09: J. Fox added complete=FALSE to vcov.() calls # 2017-11-07: J. Fox added unexported formatCall() for improved formatting of calls # 2017-11-24: J. Fox made small improvements to output messages, etc. # 2017-11-29: J. Fox made fixes for vcov() and vcov.() calls. # 2017-12-27: J. Fox tweaked the Summarize() output for mixed models. # 2017-12-29: J. Fox added fit statistics to Summarize() output for various models. # 2018-01-15: S. Weisberg all Summmarize/Summarise methods renamed S # 2018-02-02: J. Fox fixed S.lm() and S.glm() output when vcov. arg not given. # 2018-02-07,08,12: J. Fox removed leading blank lines in formatCall() and elsewhere. # 2018-10-23: J. Fox made coefs2use() work with models without an intercept even if intercept arg is TRUE. # 2019-05-02: J. Fox fixed bug in Confint.polr() that exponentiated coefficients twice (reported by Thamron Keowmani). # 2019-05-02,13: J. Fox made several S() methods tolerant of model with 1 coefficient or # in the case of multinom models, 2 response levels(reported by Thamron Keowmani). # 2020-05-17: J. Fox added S.data.frame() # 2020-12-15: In Confint.glm, fixed but go vcov. works correctly. formatCall <- function(call){ call <- if (is.character(call)){ if (length(call) > 1) paste(call, collapse=" ") else call } else paste(deparse(call), sep = "", collapse = "") call <- gsub("\\s+", " ", call) call <- paste("Call:", call) call <- strwrap(call, width=getOption("width")) paren <- regexpr("\\(", call[1]) if (paren > 0 && length(call) > 1){ call[-1] <- paste0(paste(rep(" ", paren), collapse=""), call[-1]) } paste0(paste(call, collapse="\n"), "\n") } fitstats <- function(model){ logLik <- logLik(model) result <- c(logLik=as.vector(logLik), df=attr(logLik, "df"), AIC=AIC(model), BIC=BIC(model)) class(result) <- "fitstats" result } print.fitstats <- function(x, digits=2, ...){ x <- round(x, digits=digits) result <- format(x) result["df"] <- format(x["df"]) cat("\n") print(result, quote=FALSE) invisible(x) } S <- function(object, brief, ...){ UseMethod("S") } #Summarise <- function(object, brief, ...){ # UseMethod("S") #} S.default <- function(object, brief, ...) summary(object, ...) #S.glm <- function(object, ...) { # if(object$family$family == "gaussian" & object$family$link == "identity") # S.lm(object, ...) else summary(object, ...) #} S.lm <- function (object, brief=FALSE, correlation = FALSE, symbolic.cor = FALSE, vcov. = vcov(object, complete=FALSE), header=TRUE, resid.summary=FALSE, adj.r2=FALSE, ...) { z <- object p <- z$rank rdf <- z$df.residual if (p == 0) { r <- z$residuals n <- length(r) w <- z$weights if (is.null(w)) { rss <- sum(r^2) } else { rss <- sum(w * r^2) r <- sqrt(w) * r } resvar <- rss/rdf ans <- z[c("call", "terms", if (!is.null(z$weights)) "weights")] class(ans) <- "S.lm" ans$aliased <- is.na(coef(object)) ans$residuals <- r ans$df <- c(0L, n, length(ans$aliased)) ans$coefficients <- matrix(NA, 0L, 4L) dimnames(ans$coefficients) <- list(NULL, c("Estimate", "Std. Error", "t value", "Pr(>|t|)")) ans$sigma <- sqrt(resvar) ans$r.squared <- ans$adj.r.squared <- 0 ans$header <- header ans$resid.summary <- resid.summary ans$adj.r2 <- adj.r2 ans$brief <- brief ans$fitstats <- round(c(AIC=AIC(object), BIC=BIC(object)), digits=2) return(ans) } if (is.null(z$terms)) stop("invalid 'lm' object: no 'terms' component") if (!inherits(object, "lm")) warning("calling summary.lm() ...") Qr <- object$qr n <- NROW(Qr$qr) if (is.na(z$df.residual) || n - p != z$df.residual) warning("residual degrees of freedom in object suggest this is not an \"lm\" fit") r <- z$residuals f <- z$fitted.values w <- z$weights if (is.null(w)) { mss <- if (attr(z$terms, "intercept")) sum((f - mean(f))^2) else sum(f^2) rss <- sum(r^2) } else { mss <- if (attr(z$terms, "intercept")) { m <- sum(w * f/sum(w)) sum(w * (f - m)^2) } else sum(w * f^2) rss <- sum(w * r^2) r <- sqrt(w) * r } resvar <- rss/rdf if (is.finite(resvar) && resvar < (mean(f)^2 + var(f)) * 1e-30) warning("essentially perfect fit: summary may be unreliable") p1 <- 1L:p R <- chol2inv(Qr$qr[p1, p1, drop = FALSE]) # se <- sqrt(diag(R) * resvar) V <- getVcov(vcov., object) # V <- if(is.matrix(vcov.)) vcov. else # if(deparse(substitute(vcov.) == "Boot")) cov((b1 <- Boot(object))$t) #else # vcov.(object) se <- sqrt(diag(V)) est <- z$coefficients[Qr$pivot[p1]] tval <- est/se ans <- z[c("call", "terms", if (!is.null(z$weights)) "weights")] ans$residuals <- r ans$coefficients <- cbind(est, se, tval, 2 * pt(abs(tval), rdf, lower.tail = FALSE)) dimnames(ans$coefficients) <- list(names(z$coefficients)[Qr$pivot[p1]], c("Estimate", "Std. Error", "t value", "Pr(>|t|)")) ans$aliased <- is.na(coef(object)) ans$sigma <- sqrt(resvar) ans$df <- c(p, rdf, NCOL(Qr$qr)) if (p != attr(z$terms, "intercept")) { df.int <- if (attr(z$terms, "intercept")) 1L else 0L ans$r.squared <- mss/(mss + rss) ans$adj.r.squared <- 1 - (1 - ans$r.squared) * ((n - df.int)/rdf) # ans$fstatistic <- c(value = (mss/(p - df.int))/resvar, # numdf = p - df.int, dendf = rdf) # linearHypothesis computes overall F test allowing for alternative covariance matrices mat <- diag(p - df.int) if(df.int==1) mat <- cbind(0, mat) lh <- linearHypothesis(z, mat, vcov.=V, singular.ok=TRUE) ans$fstatistic <- c(value = lh$F[2], numdf = lh$Df[2], dendf = lh$Res.Df[2]) } else ans$r.squared <- ans$adj.r.squared <- 0 ans$cov.unscaled <- R dimnames(ans$cov.unscaled) <- dimnames(ans$coefficients)[c(1, 1)] if (correlation) { ans$correlation <- (R * resvar)/outer(se, se) dimnames(ans$correlation) <- dimnames(ans$cov.unscaled) ans$symbolic.cor <- symbolic.cor } if (!is.null(z$na.action)) ans$na.action <- z$na.action ans$vcov. <- if (missing(vcov.)) "" else deparse(substitute(vcov.)) ans$header <- header ans$resid.summary <- resid.summary ans$adj.r2 <- adj.r2 ans$brief <- brief ans$fitstats <- round(c(AIC=AIC(object), BIC=BIC(object)), digits=2) class(ans) <- "S.lm" ans } print.S.lm <- function(x, digits = max(3, getOption("digits") - 3), symbolic.cor = x$symbolic.cor, signif.stars = getOption("show.signif.stars"), ...) { header <- x$header resid.summary <- x$resid.summary adj.r2 <- x$adj.r2 brief <- x$brief if (brief) header <- resid.summary <- adj.r2 <- FALSE if (header) { cat(formatCall(x$call)) if(x$vcov. != ""){ cat("Standard errors computed by", x$vcov., "\n") } } resid <- x$residuals df <- x$df rdf <- df[2L] if (resid.summary) { cat('\n', if (!is.null(x$weights) && diff(range(x$weights))) "Weighted ", "Residuals:\n", sep = "") if (rdf > 5L) { nam <- c("Min", "1Q", "Median", "3Q", "Max") rq <- if (length(dim(resid)) == 2L) structure(apply(t(resid), 1L, quantile), dimnames = list(nam, dimnames(resid)[[2L]])) else { zz <- zapsmall(quantile(resid), digits + 1) structure(zz, names = nam) } print(rq, digits = digits, ...) } else if (rdf > 0L) { print(resid, digits = digits, ...) } else { cat("ALL", df[1L], "residuals are 0: no residual degrees of freedom!\n") } } if (length(x$aliased) == 0L) { cat("\nNo Coefficients\n") } else { if (header || resid.summary) cat("\n") if (nsingular <- df[3L] - df[1L]) cat("Coefficients: (", nsingular, " not defined because of singularities)\n", sep = "") else cat("Coefficients:\n") coefs <- x$coefficients if (!is.null(aliased <- x$aliased) && any(aliased)) { cn <- names(aliased) coefs <- matrix(NA, length(aliased), 4, dimnames = list(cn, colnames(coefs))) coefs[!aliased, ] <- x$coefficients } printCoefmat(coefs, digits = digits, signif.stars = signif.stars, na.print = "NA", ...) } cat("\nResidual standard deviation:", format(signif(x$sigma, digits)), "on", rdf, "degrees of freedom\n") if (nzchar(mess <- naprint(x$na.action))) cat(" (", mess, ")\n", sep = "") if (!is.null(x$fstatistic)) { cat("Multiple R-squared:", formatC(x$r.squared, digits = digits)) if (adj.r2) { cat(",\tAdjusted R-squared:", formatC(x$adj.r.squared, digits = digits)) } cat("\nF-statistic:", formatC(x$fstatistic[1L], digits = digits), "on", x$fstatistic[2L], "and", x$fstatistic[3L], "DF, p-value:", format.pval(pf(x$fstatistic[1L], x$fstatistic[2L], x$fstatistic[3L], lower.tail = FALSE), digits = digits), "\n") } print(x$fitstats) correl <- x$correlation if (!is.null(correl)) { p <- NCOL(correl) if (p > 1L) { cat("\nCorrelation of Coefficients:\n") if (is.logical(symbolic.cor) && symbolic.cor) { print(symnum(correl, abbr.colnames = NULL)) } else { correl <- format(round(correl, 2), nsmall = 2, digits = digits) correl[!lower.tri(correl)] <- "" print(correl[-1, -p, drop = FALSE], quote = FALSE) } } } cat("\n") invisible(x) } S.glm <- function (object, brief=FALSE, exponentiate, dispersion, correlation = FALSE, symbolic.cor = FALSE, vcov. = vcov(object, complete=FALSE), header=TRUE, resid.summary=FALSE, ...) { vcov.arg <- if (missing(vcov.)) "" else deparse(substitute(vcov.)) if (missing(exponentiate)) exponentiate <- object$family$link %in% c("log", "logit") # if(!is.null(dispersion)) vcov. <- "vcov" # ignore vcov. arg if dispersion is set if (!missing(dispersion) && !missing(vcov.)) stop("cannot specify both the dispersion and vcov. arguments") profile.likelihood <- missing(vcov.) && missing(dispersion) est.disp <- FALSE df.r <- object$df.residual if (missing(dispersion)) dispersion <- if (object$family$family %in% c("poisson", "binomial")) 1 else if (df.r > 0) { est.disp <- TRUE if (any(object$weights == 0)) warning("observations with zero weight not used for calculating dispersion") sum((object$weights * object$residuals^2)[object$weights > 0])/df.r } else { est.disp <- TRUE NaN } aliased <- is.na(coef(object)) p <- object$rank if (p > 0) { p1 <- 1L:p Qr <- object$qr coef.p <- object$coefficients[Qr$pivot[p1]] covmat.unscaled <- chol2inv(Qr$qr[p1, p1, drop = FALSE]) dimnames(covmat.unscaled) <- list(names(coef.p), names(coef.p)) # changed covmat <- if(is.matrix(vcov.)) vcov. else {if(!est.disp) dispersion * covmat.unscaled else vcov.(object)} # end change var.cf <- diag(covmat) s.err <- sqrt(var.cf) tvalue <- coef.p/s.err dn <- c("Estimate", "Std. Error") if (!est.disp) { pvalue <- 2 * pnorm(-abs(tvalue)) coef.table <- cbind(coef.p, s.err, tvalue, pvalue) dimnames(coef.table) <- list(names(coef.p), c(dn, "z value", "Pr(>|z|)")) } else if (df.r > 0) { pvalue <- 2 * pt(-abs(tvalue), df.r) coef.table <- cbind(coef.p, s.err, tvalue, pvalue) dimnames(coef.table) <- list(names(coef.p), c(dn, "t value", "Pr(>|t|)")) } else { coef.table <- cbind(coef.p, NaN, NaN, NaN) dimnames(coef.table) <- list(names(coef.p), c(dn, "t value", "Pr(>|t|)")) } df.f <- NCOL(Qr$qr) } else { coef.table <- matrix(, 0L, 4L) dimnames(coef.table) <- list(NULL, c("Estimate", "Std. Error", "t value", "Pr(>|t|)")) covmat.unscaled <- covmat <- matrix(, 0L, 0L) df.f <- length(aliased) } keep <- match(c("call", "terms", "family", "deviance", "aic", "contrasts", "df.residual", "null.deviance", "df.null", "iter", "na.action"), names(object), 0L) ans <- c(object[keep], list(deviance.resid = residuals(object, type = "deviance"), coefficients = coef.table, aliased = aliased, dispersion = dispersion, df = c(object$rank, df.r, df.f), cov.unscaled = covmat.unscaled, cov.scaled = covmat)) if (correlation && p > 0) { dd <- sqrt(diag(covmat.unscaled)) ans$correlation <- covmat.unscaled/outer(dd, dd) ans$symbolic.cor <- symbolic.cor } # add to value ans$fitstats <- fitstats(object) ans$vcov. <- vcov.arg ans$header <- header ans$resid.summary <- resid.summary ans$brief <- brief if (exponentiate) ans$exponentiated <- if (profile.likelihood) Confint(object, exponentiate=TRUE, silent=TRUE) else Confint(object, exponentiate=TRUE, silent=TRUE, vcov.=covmat) # end add class(ans) <- "S.glm" return(ans) } print.S.glm <- function (x, digits = max(3L, getOption("digits") - 3L), symbolic.cor = x$symbolic.cor, signif.stars = getOption("show.signif.stars"), ...) { header <- x$header resid.summary <- x$resid.summary brief <- x$brief if (brief) { header <- resid.summary <- FALSE x$exponentiated <- NULL } if (header) { cat(formatCall(x$call)) if(x$vcov. != ""){ cat("Standard errors computed by", x$vcov., "\n") } } if(resid.summary){ cat("Deviance Residuals: \n") if (x$df.residual > 5) { x$deviance.resid <- setNames(quantile(x$deviance.resid, na.rm = TRUE), c("Min", "1Q", "Median", "3Q", "Max")) } xx <- zapsmall(x$deviance.resid, digits + 1L) print.default(xx, digits = digits, na.print = "", print.gap = 2L) } if (length(x$aliased) == 0L) { cat("\nNo Coefficients\n") } else { if (header || resid.summary) cat("\n") df <- if ("df" %in% names(x)) x[["df"]] else NULL if (!is.null(df) && (nsingular <- df[3L] - df[1L])) cat("Coefficients: (", nsingular, " not defined because of singularities)\n", sep = "") else cat("Coefficients:\n") coefs <- x$coefficients if (!is.null(aliased <- x$aliased) && any(aliased)) { cn <- names(aliased) coefs <- matrix(NA, length(aliased), 4L, dimnames = list(cn, colnames(coefs))) coefs[!aliased, ] <- x$coefficients } printCoefmat(coefs, digits = digits, signif.stars = signif.stars, na.print = "NA", ...) } cat("\n(Dispersion parameter for ", x$family$family, " family taken to be ", format(x$dispersion), ")\n\n", apply(cbind(paste(format(c("Null", "Residual"), justify = "right"), "deviance:"), format(unlist(x[c("null.deviance", "deviance")]), digits = max(5L, digits + 1L)), " on", format(unlist(x[c("df.null", "df.residual")])), " degrees of freedom\n"), 1L, paste, collapse = " "), sep = "") if (nzchar(mess <- naprint(x$na.action))) cat(" (", mess, ")\n", sep = "") print(x$fitstats) # cat("AIC: ", format(x$aic, digits = max(4L, digits + 1L)), "\n\n", cat("\nNumber of Fisher Scoring iterations: ", x$iter, "\n", sep = "") correl <- x$correlation if (!is.null(correl)) { p <- NCOL(correl) if (p > 1) { cat("\nCorrelation of Coefficients:\n") if (is.logical(symbolic.cor) && symbolic.cor) { print(symnum(correl, abbr.colnames = NULL)) } else { correl <- format(round(correl, 2L), nsmall = 2L, digits = digits) correl[!lower.tri(correl)] <- "" print(correl[-1, -p, drop = FALSE], quote = FALSE) } } } cat("\n") if (!is.null(x$exponentiated)){ cat("Exponentiated Coefficients and Confidence Bounds\n") print(x$exponentiated) cat("\n") } invisible(x) } S.multinom <- function(object, brief=FALSE, exponentiate=FALSE, ...){ result <- summary(object, ...) result$brief <- brief result$fitstats <- fitstats(object) if (exponentiate) result$exponentiated <- Confint(object, exponentiate=TRUE) class(result) <- "S.multinom" result } print.S.multinom <- function (x, digits = max(3, getOption("digits") - 3), signif.stars = getOption("show.signif.stars"), ...) { if (!x$brief) cat(formatCall(x$call)) cat("\nCoefficients:\n") b <- x$coefficients se <- x$standard.errors z <- b/se p <- 2*pnorm(abs(z), lower.tail=FALSE) levels <- x$lev if (length(levels) == 2){ table <- cbind(b, se, z, p) colnames(table) <- c("Estimate", "Std. Error", "z value", "Pr(>|z|)") cat("\n ", levels[2], "\n") printCoefmat(table, signif.stars=signif.stars, digits=digits, ...) } else{ table <- abind(t(b), t(se), t(z), t(p), along=1.5) dimnames(table)[[2]] <- c("Estimate", "Std. Error", "z value", "Pr(>|z|)") for (level in levels[-1]){ cat("\n ", level, "\n") tab <- table[, , level] if (is.vector(tab)){ cnames <- names(tab) tab <- matrix(tab, nrow=1) colnames(tab) <- cnames rownames(tab) <- x$coefnames } printCoefmat(tab, signif.stars=signif.stars, digits=digits, ...) } } cat("\nResidual Deviance:", format(x$deviance, digits=digits, ...), "\n") print(x$fitstats) exponentiated <- x$exponentiated if (!is.null(exponentiated)){ cat("\nExponentiated Coefficients:\n") if (length(dim(table)) == 2) print(exponentiated, digits=digits, ...) else for (response in dimnames(table)[[3]]){ cat("\n ", response, "\n") print(exponentiated[, , response], digits=digits, ...) } } invisible(x) } S.polr <- function(object, brief=FALSE, exponentiate=FALSE, ...){ sumry <- summary(object, ...) sumry$brief <- brief sumry$fitstats <- fitstats(object) if (exponentiate){ sumry$exponentiated <- Confint(object, exponentiate=TRUE, ...) } class(sumry) <- c("S.polr", class(sumry)) sumry } print.S.polr <- function(x, digits = max(3, getOption("digits") - 3), signif.stars = getOption("show.signif.stars"), ...) { if (!x$brief) cat(formatCall(x$call)) table <- x$coefficients table <- cbind(table, 2*pnorm(abs(table[, 3]), lower.tail=FALSE)) n.par <- nrow(table) n.ints <- length(x$zeta) n.coefs <- n.par - n.ints coef.table <- table[1:n.coefs, , drop=FALSE] int.table <- table[(n.coefs + 1):n.par, , drop=FALSE] colnames(coef.table) <- colnames(int.table) <- c("Estimate", "Std. Error", "z value", "Pr(>|z|)") if (!x$brief) cat("\n") cat(" Coefficients:\n") printCoefmat(coef.table, digits=digits, signif.stars=signif.stars, ...) cat("\n Intercepts (Thresholds):\n") printCoefmat(int.table, digits=digits, signif.stars=signif.stars, ...) cat("\nResidual Deviance:", format(x$deviance), "\n") print(x$fitstats) if (!is.null(x$exponentiated)){ cat("\n Exponentiated Coefficients\n") print(x$exponentiated) } invisible(x) } S.lmerMod <- function(object, brief=FALSE, KR=FALSE, correlation=FALSE, ...){ sumry <- summary(object) coefs <- sumry$coefficients REML <- grepl("REML", sumry$methTitle) # the following code for no of groups and obs borrowed from print.merMod() dims <- object@devcomp$dims ngrps <- vapply(object@flist, nlevels, 0L) if (KR){ if (!REML) stop("KR tests available only for REML estimates") b <- coefs[, 1] vcov <- as.matrix(pbkrtest::vcovAdj(object)) coefs[, 2] <- sqrt(diag(vcov)) p <- length(b) coefs <- cbind(coefs, matrix(0, p, 2)) I.p <- diag(p) for (i in 1:p){ test <- pbkrtest::KRmodcomp(object, I.p[i, , drop=FALSE]) coefs[i, 3] <- sign(coefs[i, 1])*sqrt(pbkrtest::getKR(test, "Fstat")) coefs[i, 4] <- pbkrtest::getKR(test, "ddf") coefs[i, 5] <- pbkrtest::getKR(test, "p.value") } colnames(coefs) <- c("Estimate", "Std. Error", "t value", "df for t", "Pr(>|t|)") } else { coefs <- cbind(coefs, 2*pnorm(abs(coefs[, 3]), lower.tail=FALSE)) colnames(coefs)[3:4] <- c("z value", "Pr(>|z|)") vcov <- as.matrix(sumry$vcov) } result <- list(logLik=sumry$logLik, fixed.effects=coefs, random.effects=sumry$varcor, REML=REML, KR=KR, call=sumry$call, brief=brief, vcov=vcov, correlation=correlation, nobs=dims[["n"]], ngrps=ngrps, fitstats=fitstats(object)) class(result) <- "S.lmerMod" result } print.S.lmerMod <- function(x, digits=max(3, getOption("digits") - 3), signif.stars = getOption("show.signif.stars"), ...){ if (!x$brief) { cat(paste("Linear mixed model fit by", if (x$REML) "REML" else "ML", "\n")) cat(formatCall(x$call)) } if (x$KR) cat("\nEstimates of Fixed Effects with KR Tests\n") else cat("\nEstimates of Fixed Effects:\n") printCoefmat(x$fixed.effects, digits=digits, signif.stars=signif.stars) if (x$correlation) { # the following code adapted from print.summary.merMod() cor <- cov2cor(x$vcov) p <- ncol(cor) if (p > 1) { rn <- rownames(x$fixed.effects) rns <- abbreviate(rn, minlength = 11) cat("\nCorrelations of Fixed Effects:\n") cor <- matrix(format(round(cor, 3), nsmall = 3), ncol = p, dimnames = list(rns, abbreviate(rn, minlength = 6))) cor[!lower.tri(cor)] <- "" print(cor[-1, -p, drop = FALSE], quote = FALSE) } } cat("\nEstimates of Random Effects (Covariance Components):\n") print(x$random.effects, digits=digits) # cat(paste0("\nLog-likelihood (", if (x$REML) "REML) = " else "ML) = ", # format(x$logLik, digits=digits), "\n")) # the following code adapted from lme4:::.prt.grps() cat(sprintf("\nNumber of obs: %d, groups: ", x$nobs), paste(paste(names(x$ngrps), x$ngrps, sep = ", "), collapse = "; "), fill = TRUE) print(x$fitstats) invisible(x) } S.lme <- function(object, brief=FALSE, correlation=FALSE, ...){ sumry <- summary(object) coefs <- sumry$tTable colnames(coefs) <- c("Estimate", "Std.Error", "df", "t value", "Pr(>|t|)") REML <- sumry$method == "REML" result <- list(logLik=sumry$logLik, fixed.effects=coefs, random.effects=summary(sumry$modelStruct), REML=REML, call=sumry$call, brief=brief, vcov=sumry$varFix, sigma=sumry$sigma, dims=sumry$dims, correlation=correlation, fitstats=fitstats(object)) class(result) <- "S.lme" result } print.S.lme <- function(x, digits=max(3, getOption("digits") - 3), signif.stars = getOption("show.signif.stars"), ...){ if (!x$brief) { cat(paste("Linear mixed model fit by", if (x$REML) "REML" else "ML")) if (!is.null(x$call$data)) cat(", Data:", as.character(x$call$data)) cat("\n") } cat("\nFixed Effects:\n") if (!x$brief) cat(" Formula:", deparse(x$call$fixed), "\n\n") printCoefmat(x$fixed.effects, digits=digits, signif.stars=signif.stars, cs.ind=1:2) if (x$correlation) { # the following code adapted from print.summary.merMod() cor <- cov2cor(x$vcov) p <- ncol(cor) if (p > 1) { rn <- rownames(x$fixed.effects) rns <- abbreviate(rn, minlength = 11) cat("\nCorrelations of Fixed Effects:\n") cor <- matrix(format(round(cor, 3), nsmall = 3), ncol = p, dimnames = list(rns, abbreviate(rn, minlength = 6))) cor[!lower.tri(cor)] <- "" print(cor[-1, -p, drop = FALSE], quote = FALSE) } } cat("\n") print(x$random.effects, sigma=x$sigma, digits=digits) # cat(paste0("\nLog-likelihood (", if (x$REML) "REML) = " else "ML) = ", # format(x$logLik, digits=digits), "\n")) # the following adapted from print.summary.lme() dims <- x$dims cat("\nNumber of Observations:", dims[["N"]]) cat("\nNumber of Groups: ") Ngrps <- dims$ngrps[1:dims$Q] if ((lNgrps <- length(Ngrps)) == 1) { cat(Ngrps, "\n") } else { sNgrps <- 1:lNgrps aux <- rep(names(Ngrps), sNgrps) aux <- split(aux, array(rep(sNgrps, lNgrps), c(lNgrps, lNgrps))[!lower.tri(diag(lNgrps))]) names(Ngrps) <- unlist(lapply(aux, paste, collapse = " %in% ")) cat("\n") print(rev(Ngrps), ...) } print(x$fitstats) invisible(x) } S.glmerMod <- function(object, brief=FALSE, correlation=FALSE, exponentiate, ...){ if (missing(exponentiate)) exponentiate <- object@resp$family$link %in% c("log", "logit") sumry <- summary(object) coefs <- sumry$coefficients # the following code for no of groups and obs borrowed from print.merMod() dims <- object@devcomp$dims ngrps <- vapply(object@flist, nlevels, 0L) vcov <- as.matrix(sumry$vcov) exp <- if (exponentiate) Confint(object, exponentiate=TRUE, silent=TRUE) else NULL result <- list(logLik=sumry$logLik, fixed.effects=coefs, random.effects=sumry$varcor, call=sumry$call, brief=brief, vcov=vcov, correlation=correlation, nobs=dims[["n"]], ngrps=ngrps, exponentiate=exp, fitstats=fitstats(object)) class(result) <- "S.glmerMod" result } print.S.glmerMod <- function(x, digits=max(3, getOption("digits") - 3), signif.stars = getOption("show.signif.stars"), ...){ if (!x$brief) { cat("Generalized linear mixed model fit by ML\n") cat(formatCall(x$call)) } cat("\nEstimates of Fixed Effects:\n") printCoefmat(x$fixed.effects, digits=digits, signif.stars=signif.stars) if (x$correlation) { # the following code adapted from print.summary.merMod() cor <- cov2cor(x$vcov) p <- ncol(cor) if (p > 1) { rn <- rownames(x$fixed.effects) rns <- abbreviate(rn, minlength = 11) cat("\nCorrelations of Fixed Effects:\n") cor <- matrix(format(round(cor, 3), nsmall = 3), ncol = p, dimnames = list(rns, abbreviate(rn, minlength = 6))) cor[!lower.tri(cor)] <- "" print(cor[-1, -p, drop = FALSE], quote = FALSE) } } if (!is.null(x$exponentiate)){ cat("\nExponentiated Fixed Effects and Confidence Bounds:\n") print(x$exponentiate) } cat("\nEstimates of Random Effects (Covariance Components):\n") print(x$random.effects, digits=digits) # cat(paste0("\nLog-likelihood = ", format(x$logLik, digits=digits), "\n")) # the following code adapted from lme4:::.prt.grps() cat(sprintf("\nNumber of obs: %d, groups: ", x$nobs), paste(paste(names(x$ngrps), x$ngrps, sep = ", "), collapse = "; "), fill = TRUE) print(x$fitstats) invisible(x) } S.data.frame <- function(object, brief=FALSE, ...){ if (brief){ return(brief(object, ...)) } object <- strings2factors(object, verbose=FALSE) summary(object, ...) } Confint <- function(object, ...){ UseMethod("Confint") } Confint.default <- function(object, estimate=TRUE, level=0.95, vcov., ...) { if (missing(vcov.)) result <- confint(object, level=level, ...) else{ # vc <- if (is.function(vcov.)) vcov.(object) else vcov. vc <- getVcov(vcov., object, complete=FALSE) b <- coef(object) se <- sqrt(diag(vc)) p <- 1 - (1 - level)/2 z <- qnorm(p) result <- cbind(b - z*se, b + z*se) colnames(result) <- format.perc(c(1 - p, p), 3) } if (estimate){ result <- cbind(coef(object), result) colnames(result)[1] <- "Estimate" } result } Confint.lm <- function(object, estimate=TRUE, parm, level = 0.95, vcov.= vcov(object, complete=FALSE), ...) { if (!missing(vcov.)) cat("Standard errors computed by", deparse(substitute(vcov.)), "\n") cf <- coef(object) pnames <- names(cf) if (missing(parm)) parm <- pnames else if (is.numeric(parm)) parm <- pnames[parm] a <- (1 - level)/2 a <- c(a, 1 - a) fac <- qt(a, object$df.residual) pct <- format.perc(a, 3) ci <- array(NA, dim = c(length(parm), 2L), dimnames = list(parm, pct)) V <- getVcov(vcov., object, complete=FALSE) ses <- sqrt(diag(V))[parm] # ses <- sqrt(diag(if(is.matrix(vcov.)) vcov. else vcov.(object)))[parm] ci[] <- cf[parm] + ses %o% fac ci if (estimate){ ci <- cbind(coef(object), ci) colnames(ci)[1] <- "Estimate" } ci } Confint.glm <- function(object, estimate=TRUE, exponentiate=FALSE, vcov., dispersion, type=c("LR", "Wald"), ...){ type <- match.arg(type) silent <- list(...)$silent if (!missing(vcov.) && !missing(dispersion)) stop("cannot specify both vcov. and dispersion arguments") if (!missing(vcov.) && (is.null(silent) || !silent)) cat("Standard errors computed by", deparse(substitute(vcov.)), "\n") result <- if (!missing(vcov.)) # next line, bug fix 12/15/2020 Confint.default(object, estimate=FALSE, vcov.=getVcov(vcov., object, complete=FALSE), ...) else if (!missing(dispersion)) Confint.default(object, estimate=FALSE, vcov.=dispersion*summary(object)$cov.unscaled, ...) else if (type == "LR"){ suppressMessages(confint(object, ...)) } else Confint.default(object, estimate=FALSE) if (estimate){ result <- cbind(coef(object), result) colnames(result)[1] <- "Estimate" } if (exponentiate){ if (!object$family$link %in% c("log", "logit")) stop("exponentiated coefficients available only for log or logit link") if (is.null(silent) || !silent) cat("\nExponentiated Coefficients and Confidence Bounds\n") return(exp(result)) } else return(result) } Confint.polr <- function(object, estimate=TRUE, exponentiate=FALSE, thresholds=!exponentiate, ...){ dots <- list(...) level <- if (is.null(dots$level)) 0.95 else dots$level result <- suppressMessages(confint(object, ...)) if (!is.matrix(result)) { cnames <- names(result) result <- matrix(result, nrow=1) colnames(result) <- cnames rownames(result) <- names(coef(object)) } cnames <- colnames(result) if (estimate){ result <- cbind(coef(object), result) colnames(result)[1] <- "Estimate" } if (thresholds){ z <- qnorm(1 - (1 - level)/2) sumry <- suppressMessages(summary(object)$coefficients) sumry <- sumry[-(1:nrow(result)), ] b <- sumry[, 1] se <- sumry[, 2] sumry <- cbind(b - z*se, b + z*se) colnames(sumry) <- cnames if (estimate) { sumry <- cbind(b, sumry) } result <- rbind(result, sumry) } if (exponentiate) exp(result) else result } Confint.multinom <- function(object, estimate=TRUE, exponentiate=FALSE, ...){ result <- confint(object) levs <- object$lev n.levs <- length(levs) b.names <- object$vcoefnames if (n.levs == 2){ b <- coef(object) result <- cbind(b, result) colnames(result)[1] <- "Estimate" rownames(result) <- b.names } else if (estimate) { b <- object$wts b <- matrix(b, ncol=n.levs) b <- b[-1, , drop=FALSE] b <- b[ , -1, drop=FALSE] rownames(b) <- b.names colnames(b) <- levs[-1] result <- abind(b, result, along=2) dimnames(result)[[2]][1] <- "Estimate" } if (exponentiate) exp(result) else result } Confint.lme <- function(object, estimate=TRUE, level = 0.95, ...) { cf <- object$coefficients$fixed a <- (1 - level)/2 a <- c(a, 1 - a) fac <- qnorm(a) pct <- format.perc(a, 3) ci <- array(NA, dim = c(length(cf), 2L), dimnames = list(names(cf), pct)) ses <- sqrt(diag(vcov(object, complete=FALSE))) ci[] <- cf + ses %o% fac if (estimate){ ci <- cbind(cf, ci) colnames(ci)[1] <- "Estimate" } ci } Confint.lmerMod <- function(object, estimate=TRUE, level = 0.95, ...) { cf <- lme4::fixef(object) a <- (1 - level)/2 a <- c(a, 1 - a) fac <- qnorm(a) pct <- format.perc(a, 3) ci <- array(NA, dim = c(length(cf), 2L), dimnames = list(names(cf), pct)) ses <- sqrt(diag(as.matrix(vcov(object, complete=FALSE)))) ci[] <- cf + ses %o% fac if (estimate){ ci <- cbind(cf, ci) colnames(ci)[1] <- "Estimate" } ci } Confint.glmerMod <- function(object, estimate=TRUE, level = 0.95, exponentiate=FALSE, ...) { silent <- list(...)$silent cf <- lme4::fixef(object) a <- (1 - level)/2 a <- c(a, 1 - a) fac <- qnorm(a) pct <- format.perc(a, 3) ci <- array(NA, dim = c(length(cf), 2L), dimnames = list(names(cf), pct)) ses <- sqrt(diag(as.matrix(vcov(object, complete=FALSE)))) ci[] <- cf + ses %o% fac if (estimate){ ci <- cbind(cf, ci) colnames(ci)[1] <- "Estimate" } if (exponentiate){ if (!object@resp$family$link %in% c("log", "logit")) stop("exponentiated coefficients available only for log or logit link") if (is.null(silent) || !silent) cat("\nExponentiated Coefficients and Confidence Bounds\n") return(exp(ci)) } else return(ci) } # the following function is not exported coefs2use <- function(model, terms, intercept){ vform <- update(formula(model), terms) if(any(is.na(match(all.vars(vform), all.vars(formula(model)))))) stop("Only predictors in the formula can be used.") terms.model <- attr(attr(model.frame(model), "terms"), "term.labels") terms.vform <- attr(terms(vform), "term.labels") terms.used <- match(terms.vform, terms.model) mm <- model.matrix(model) model.names <- attributes(mm)$dimnames[[2]] model.assign <- attributes(mm)$assign use <- model.names[!is.na(match(model.assign, terms.used))] if (intercept && has.intercept(model)) c("(Intercept)", use) else use } # S <- function(model, terms, intercept, pvalues, digits, horizontal, ...){ # UseMethod("S") # } # # # S.default <- function(model, terms = ~ ., intercept=missing(terms), pvalues=FALSE, digits=3, horizontal=TRUE, ...){ # use <- coefs2use(model, terms, intercept) # sumry <- summary(model) # cols <- if (pvalues) c(1, 2, 4) else 1:2 # coefs <- sumry$coefficients[use, cols, drop=FALSE] # colnames(coefs) <- if (pvalues) c("Estimate", "Std. Error", "Pr(>|z|)") else c("Estimate", "Std. Error") # print(if (horizontal) t(coefs) else coefs, digits=digits) # invisible(sumry) # } # # S.lm <- function(model, terms = ~ ., intercept=missing(terms), pvalues=FALSE, digits=3, horizontal=TRUE, vcov.=vcov, ...){ # use <- coefs2use(model, terms, intercept) # sumry <- S(model, vcov.=vcov., ...) # cols <- if (pvalues) c(1, 2, 4) else 1:2 # coefs <- sumry$coefficients[use, cols, drop=FALSE] # colnames(coefs) <- if (pvalues) c("Estimate", "Std. Error", "Pr(>|t|)") else c("Estimate", "Std. Error") # print(if (horizontal) t(coefs) else coefs, digits=digits) # if (missing(terms)) cat("\n Residual SD =", format(sumry$sigma, digits=digits), # "on", model$df.residual, "df, R-squared =", format(sumry$r.squared, digits=digits)) # invisible(sumry) # } # # S.glm <- function(model, terms = ~ ., intercept=missing(terms), pvalues=FALSE, digits=3, horizontal=TRUE, vcov., dispersion, exponentiate, ...){ # if (!missing(vcov.) && !missing(dispersion)) # stop("cannot specify both the dispersion and vcov. arguments") # if (missing(exponentiate)) exponentiate <- model$family$link %in% c("log", "logit") # use <- coefs2use(model, terms, intercept) # sumry <- if (!missing(vcov.)) S(model, digits, vcov.=vcov., ...) # else if (!missing(dispersion)) S(model, digits, dispersion=dispersion, ...) # else summary(model, ...) # cols <- if (pvalues) c(1, 2, 4) else 1:2 # coefs <- sumry$coefficients[use, cols, drop=FALSE] # colnames(coefs) <- if (pvalues) c("Estimate", "Std. Error", "Pr(>|z|)") else c("Estimate", "Std. Error") # if (exponentiate){ # coefs <- cbind(coefs, exp(coefs[, 1])) # colnames(coefs)[if (pvalues) 4 else 3] <- "exp(Estimate)" # } # print(if (horizontal) t(coefs) else coefs, digits=digits) # if (missing(terms)) cat("\n Residual deviance =", format(model$deviance, digits=digits), # "on", model$df.residual, "df", # if (family(model)$family %in% c("binomial", "poisson")) "" # else (paste(", Est. dispersion =", format(sumry$dispersion, digits=digits)))) # invisible(sumry) # } # # S.polr <- function(model, terms = ~ ., intercept, pvalues=FALSE, digits=3, horizontal=TRUE, exponentiate=TRUE, ...){ # sumry <- summary(model) # coefs <- sumry$coefficients[ , 1:2] # if (pvalues) { # coefs <- cbind(coefs, 2*pnorm(abs(coefs[ , 1]/coefs[, 2]), lower.tail=FALSE)) # } # use <- if (missing(terms)) 1:nrow(coefs) else coefs2use(model, terms, FALSE) # coefs <- coefs[use, , drop=FALSE] # colnames(coefs) <- if (pvalues) c("Estimate", "Std. Error", "Pr(>|z|)") else c("Estimate", "Std. Error") # if (exponentiate){ # coefs <- cbind(coefs, exp(coefs[, 1])) # colnames(coefs)[if (pvalues) 4 else 3] <- "exp(Estimate)" # if (missing(terms)){ # n.thresholds <- length(model$zeta) # n.pars <- nrow(coefs) # coefs[(n.pars - n.thresholds + 1):n.pars , if (pvalues) 4 else 3] <- NA # } # } # print(if (horizontal) t(coefs) else coefs, digits=digits, na.print="") # if (missing(terms)) cat("\n Residual deviance =", format(model$deviance, digits=digits), # "on", model$df.residual, "df") # invisible(sumry) # } # # S.multinom <- function(model, terms = ~ ., intercept=missing(terms), pvalues=FALSE, digits=3, horizontal=TRUE, exponentiate=TRUE, ...){ # use <- coefs2use(model, terms, intercept) # sumry <- summary(model, ...) # b <- sumry$coefficients # se <- sumry$standard.errors # p <- 2*pnorm(abs(b/se), lower.tail=FALSE) # levels <- sumry$lev # labels <- if (pvalues) c("Estimate", "Std. Error", "Pr(>|z|)") else c("Estimate", "Std. Error") # if (exponentiate) labels <- c(labels, "exp(Estimate)") # if (length(levels) == 2){ # b <- b[use] # se <- se[use] # p <- p[use] # table <- if (pvalues) rbind(b, se, p) else rbind(b, se) # if (exponentiate) table <- rbind(table, exp(b)) # rownames(table) <- labels # cat("\n ", levels[2], "\n") # print(if (horizontal) table else t(table), digits=digits) # } # else{ # b <- b[, use, drop=FALSE] # se <- se[, use, drop=FALSE] # p <- p[, use, drop=FALSE] # table <- if (pvalues) abind(t(b), t(se), t(p), along=1.5) else abind(t(b), t(se), along=1.5) # if (exponentiate) table <- abind(table, t(exp(b)), along=2) # dimnames(table)[[2]] <- labels # for (level in levels[-1]){ # cat("\n ", level, "\n") # result <- if (horizontal) t(table[, , level]) else table[, , level] # if (dim(table)[1] == 1){ # if (horizontal) rownames(result) <- dimnames(table)[1] else { # result <- matrix(result, ncol=1) # colnames(result) <- dimnames(table)[1] # } # } # print(result, digits=digits) # } # } # if (missing(terms)) cat("\n Residual deviance =", format(model$deviance, digits=digits), # "fitting", length(b), "parameters") # invisible(sumry) # } car/R/ncvTest.R0000644000176000001440000000463014140261763013030 0ustar ripleyusers#------------------------------------------------------------------------------- # Revision history: # 2009-09-28 by J. Fox (renamed) # 2012-07-01 Rewritten by S. Weisberg. The 'data' argument is now gone # 2013-07-09 Works correctly if data arg is not set in the model # works correctly if the formula in 'lm' is an argument # 2014-11-06 Fixed conflicts with objects in base package. J. Fox # 2018-06-07 format p-value. J. Fox #------------------------------------------------------------------------------- # score test of nonconstant variance (J. Fox) ncvTest <- function(model, ...){ UseMethod("ncvTest") } ncvTest.lm <- function(model, var.formula, ...) { data <- getCall(model)$data model <- if (!is.null(data)){ data <- eval(data, envir=environment(formula(model))) update(model, formula(model), na.action="na.exclude", data=data) } else update(model, formula(model), na.action="na.exclude") sumry <- summary(model) residuals <- residuals(model, type="pearson") S.sq <- df.residual(model)*(sumry$sigma)^2/sum(!is.na(residuals)) .U <- (residuals^2)/S.sq if (missing(var.formula)) { mod <- lm(.U ~ fitted.values(model)) varnames <- "fitted.values" var.formula <- ~ fitted.values df <- 1 } else { form <- as.formula(paste(".U ~ ", as.character(var.formula)[[2]], sep="")) mod <- if(!is.null(data)){ data$.U <- .U lm(form, data=data) } else lm(form) df <- sum(!is.na(coefficients(mod))) - 1 } SS <- anova(mod)$"Sum Sq" RegSS <- sum(SS) - SS[length(SS)] Chisq <- RegSS/2 result <- list(formula=var.formula, formula.name="Variance", ChiSquare=Chisq, Df=df, p=pchisq(Chisq, df, lower.tail=FALSE), test="Non-constant Variance Score Test") class(result) <- "chisqTest" result } ncvTest.glm <- function(model, ...){ stop("requires lm object") } print.chisqTest <- function(x, digits=getOption("digits"), ...){ title <- if (!is.null(x$test)) x$test else "Chisquare Test" cat(title,"\n") if (!is.null(x$formula)) cat(x$formula.name, "formula:", as.character(x$formula), "\n") cat(paste0("Chisquare = ", format(x$ChiSquare, digits=digits), ", Df = ", x$Df, ", p = ", format.pval(x$p, digits=max(1, digits - 2)), "\n")) invisible(x) } car/R/recode.R0000644000176000001440000000461014140261763012641 0ustar ripleyusers# recode function (J. Fox) # 2019-11-14: change class(x) == "y" to inherits(x, "y") recode <- function(var, recodes, as.factor, as.numeric=TRUE, levels){ lo <- -Inf hi <- Inf recodes <- gsub("\n|\t", " ", recodes) recode.list <- rev(strsplit(recodes, ";")[[1]]) is.fac <- is.factor(var) if (missing(as.factor)) as.factor <- is.fac if (is.fac) var <- as.character(var) result <- var for (term in recode.list){ if (0 < length(grep(":", term))) { range <- strsplit(strsplit(term, "=")[[1]][1],":") low <- try(eval(parse(text=range[[1]][1])), silent=TRUE) if (inherits(low, "try-error")){ stop("\n in recode term: ", term, "\n message: ", low) } high <- try(eval(parse(text=range[[1]][2])), silent=TRUE) if (inherits(high, "try-error")){ stop("\n in recode term: ", term, "\n message: ", high) } target <- try(eval(parse(text=strsplit(term, "=")[[1]][2])), silent=TRUE) if (inherits(target, "try-error")){ stop("\n in recode term: ", term, "\n message: ", target) } result[(var >= low) & (var <= high)] <- target } else if (0 < length(grep("^else=", squeezeBlanks(term)))) { target <- try(eval(parse(text=strsplit(term, "=")[[1]][2])), silent=TRUE) if (inherits(target, "try-error")){ stop("\n in recode term: ", term, "\n message: ", target) } result[1:length(var)] <- target } else { set <- try(eval(parse(text=strsplit(term, "=")[[1]][1])), silent=TRUE) if (inherits(set, "try-error")){ stop("\n in recode term: ", term, "\n message: ", set) } target <- try(eval(parse(text=strsplit(term, "=")[[1]][2])), silent=TRUE) if (inherits(target, "try-error")){ stop("\n in recode term: ", term, "\n message: ", target) } for (val in set){ if (is.na(val)) result[is.na(var)] <- target else result[var == val] <- target } } } if (as.factor) { result <- if (!missing(levels)) factor(result, levels=levels) else as.factor(result) } else if (as.numeric && (!is.numeric(result))) { result.valid <- na.omit(result) opt <- options("warn"=-1) result.valid <- as.numeric(result.valid) options(opt) if (!any(is.na(result.valid))) result <- as.numeric(result) } result } Recode <- function (...) car::recode(...) car/R/durbinWatsonTest.R0000644000176000001440000000557314140261763014730 0ustar ripleyusers#------------------------------------------------------------------------------- # Revision history: # 2009-09-28 by J. Fox (renamed) #------------------------------------------------------------------------------- # generalized Durbin-Watson statistic (J. Fox) durbinWatsonTest <- function(model, ...){ UseMethod("durbinWatsonTest") } durbinWatsonTest.lm <- function(model, max.lag=1, simulate=TRUE, reps=1000, method=c("resample","normal"), alternative=c("two.sided", "positive", "negative"), ...){ method <- match.arg(method) alternative <- if (max.lag == 1) match.arg(alternative) else "two.sided" residuals <- residuals(model) if (any(is.na(residuals))) stop ('residuals include missing values') n <- length(residuals) r <- dw <-rep(0, max.lag) den <- sum(residuals^2) for (lag in 1:max.lag){ dw[lag] <- (sum((residuals[(lag+1):n] - residuals[1:(n-lag)])^2))/den r[lag] <- (sum(residuals[(lag+1):n]*residuals[1:(n-lag)]))/den } if (!simulate){ result <- list(r=r, dw=dw) class(result) <- "durbinWatsonTest" result } else { S <- summary(model)$sigma X <- model.matrix(model) mu <- fitted.values(model) Y <- if (method == "resample") matrix(sample(residuals, n*reps, replace=TRUE), n, reps) + matrix(mu, n, reps) else matrix(rnorm(n*reps, 0, S), n, reps) + matrix(mu, n, reps) E <- residuals(lm(Y ~ X - 1)) DW <- apply(E, 2, durbinWatsonTest, max.lag=max.lag) if (max.lag == 1) DW <- rbind(DW) p <- rep(0, max.lag) if (alternative == 'two.sided'){ for (lag in 1:max.lag) { p[lag] <- (sum(dw[lag] < DW[lag,]))/reps p[lag] <- 2*(min(p[lag], 1 - p[lag])) } } else if (alternative == 'positive'){ for (lag in 1:max.lag) { p[lag] <- (sum(dw[lag] > DW[lag,]))/reps } } else { for (lag in 1:max.lag) { p[lag] <- (sum(dw[lag] < DW[lag,]))/reps } } result <- list(r=r, dw=dw, p=p, alternative=alternative) class(result)<-"durbinWatsonTest" result } } durbinWatsonTest.default <- function(model, max.lag=1, ...){ # in this case, "model" is the residual vectors if ((!is.vector(model)) || (!is.numeric(model)) ) stop("requires vector of residuals") if (any(is.na(model))) stop ('residuals include missing values') n <- length(model) dw <- rep(0, max.lag) den <- sum(model^2) for (lag in 1:max.lag){ dw[lag] <- (sum((model[(lag+1):n] - model[1:(n-lag)])^2))/den } dw } print.durbinWatsonTest <- function(x, ...){ max.lag <- length(x$dw) result <- if (is.null(x$p)) cbind(lag=1:max.lag,Autocorrelation=x$r, "D-W Statistic"=x$dw) else cbind(lag=1:max.lag,Autocorrelation = x$r, "D-W Statistic" = x$dw, "p-value"= x$p) rownames(result) <- rep("", max.lag) print(result) cat(paste(" Alternative hypothesis: rho", if(max.lag > 1) "[lag]" else "", c(" != ", " > ", " < ")[which(x$alternative == c("two.sided", "positive", "negative"))], "0\n", sep="")) invisible(x) } dwt <- function(...) durbinWatsonTest(...) car/R/scatterplotSmoothers.R0000644000176000001440000003575314140261763015664 0ustar ripleyusers# Scatterplot Smoothers (J. Fox and S. Weisberg) # Sept 17, 2012 moved from scatterplot.R to scatterplotSmoothers.R # June 18, 2014 Fixed bug in gamLine so the smoother.arg link="linkname" works; thanks to Hani Christoph # 2014-08-19: Make sure that Matrix and MatrixModels packages are available to quantregLine(). # Can't substitute requireNamespace() for require() for gam and quantreg packages. John # 2014-11-21: Added 'offset' argument with default 0: offset= sigmaHat(model) for use with # marginal model plots. Fixed spread smooths as well # 2015-01-27: gam() and s() now imported from mgcv rqss(), qss(), and fitted.rqss() from quantreg. John # 2016-11-19: Added argument in smoother.args called 'evaluation'. The smoother will be evaluated # at evaluation equally spaced points in the range of the horizontal axis, with a default of 50. # 2017-02-16: explicitly copy mgcv::gam() and mgcv::s(), quantreg::qss() and quantreg::rqss(). John # 2017-04-17: fixed passing of arguments and use of default.arg. Changed default lwd and lty's # and names of args see scatterplot.Rd details # 2017-05-15: fixed spread=TRUE when log="xy". in quantregLine, changed IQR(x) to IQR(x, na.rm=TRUE) # 2017-06-29: Added defaults for col, log.x, and log.y arguments, and an empty smoother.args. # 2017-06-30: Changed default line widths and types for smoothers to make them more visible. # 2017-10-27: Change default lty.smooth to 1 as advertized in docs. # 2017-11-30: substitute carPalette() for palette(). J. Fox # 2018-06-25: The argument 'spread' has an alias 'var', with 'var' having precedence. S. Weisberg # Similarly, col.var, lty.var, lwd.var override col.spread, lty.spread, lwd.spread # 2018-08-23: gamLine tried to graph in linear predictor scale, not the response scale for glms. # 2020-09-23: fixed quantregLine() to work with development version 5.69 of the quantreg package. John # 2020-10-20: added style, alpha, border, and vertical smoother.args and shaded envelope. John default.arg <- function(args.list, arg, default){ if (is.null(args.list[[arg]])) default else args.list[[arg]] } loessLine <- function(x, y, col=carPalette()[1], log.x=FALSE, log.y=FALSE, var=FALSE, spread=var, smoother.args=NULL, draw=TRUE, offset=0) { lty.smooth <- default.arg(smoother.args, "lty.smooth", 1) lwd.smooth <- default.arg(smoother.args, "lwd.smooth", 2) col.smooth <- default.arg(smoother.args, "col.smooth", col) lty.spread <- default.arg(smoother.args, "lty.spread", 4) lwd.spread <- default.arg(smoother.args, "lwd.spread", 2) col.spread <- default.arg(smoother.args, "col.spread", col) # arg '*.spread' and '*.var' are aliased. Use the latter if present lty.spread <- default.arg(smoother.args, "lty.var", lty.spread) lwd.spread <- default.arg(smoother.args, "lwd.var", lwd.spread) col.spread <- default.arg(smoother.args, "col.var", col.spread) span <- default.arg(smoother.args, "span", 2/3) family <- default.arg(smoother.args, "family", "symmetric") degree <- default.arg(smoother.args, "degree", 1) iterations <- default.arg(smoother.args, "iterations", 4) evaluation <- default.arg(smoother.args, "evaluation", 50) style <- match.arg(default.arg(smoother.args, "style", "filled"), c("filled", "lines", "none")) if (style == "none") spread <- FALSE alpha <- default.arg(smoother.args, "alpha", 0.15) border <- default.arg(smoother.args, "border", TRUE) vertical <- default.arg(smoother.args, "vertical", TRUE) if (log.x){ x <- log(x) } if (log.y){ y <- log(y) } valid <- complete.cases(x, y) x <- x[valid] y <- y[valid] ord <- order(x) x <- x[ord] y <- y[ord] x.eval <- seq(min(x), max(x), length=evaluation) warn <- options(warn=-1) on.exit(options(warn)) # mean smooth fit <- try(loess(y ~ x, span=span, family=family, degree=degree, control=loess.control(iterations=iterations)), silent=TRUE) if (class(fit)[1] != "try-error"){ y.eval <- predict(fit, newdata=data.frame(x=x.eval)) if(draw) { lines(if(log.x) exp(x.eval) else x.eval, if(log.y) exp(y.eval) else y.eval, lwd=lwd.smooth, col=col.smooth, lty=lty.smooth) } out <- list(x=if(log.x) exp(x.eval) else x.eval, y=if(log.y) exp(y.eval) else y.eval) } else{ options(warn) warning("could not fit smooth") return()} # spread smooth, if requested if(spread) { res <- residuals(fit) pos <- res > 0 pos.fit <- try(loess(I(res^2) ~ x, span=span, degree=0, family=family, subset=pos, control=loess.control(iterations=1)), silent=TRUE) neg.fit <- try(loess(I(res^2) ~ x, span=span, degree=0, family=family, subset=!pos, control=loess.control(iterations=1)), silent=TRUE) if(class(pos.fit)[1] != "try-error"){ y.pos <- y.eval + sqrt(offset^2 + predict(pos.fit, newdata=data.frame(x=x.eval))) y.pos <- if (log.y) exp(y.pos) else y.pos if(draw && style == "lines") { lines(if(log.x) exp(x.eval) else x.eval, y.pos, lwd=lwd.spread, lty=lty.spread, col=col.spread) } else { out$x.pos <- if(log.x) exp(x.eval) else x.eval out$y.pos <- y.pos } } else{ options(warn) warning("could not fit positive part of the spread") } if(class(neg.fit)[1] != "try-error"){ y.neg <- y.eval - sqrt(offset^2 + predict(neg.fit, newdata=data.frame(x=x.eval))) y.neg <- if (log.y) exp(y.neg) else y.neg if(draw && style == "lines") { lines(if(log.x) exp(x.eval) else x.eval, y.neg, lwd=lwd.spread, lty=lty.spread, col=col.spread) } else { out$x.neg <- if(log.x) exp(x.eval) else x.eval out$y.neg <- y.neg } } else { options(warn) warning("could not fit negative part of the spread") } if (draw && style == "filled"){ if (vertical){ with(out, { good <- complete.cases(x.neg, x.pos, y.neg, y.pos) envelope(x.neg[good], x.pos[good], y.neg[good], y.pos[good], col=col.spread, alpha=alpha, border=border) }) } else { with(out, { good.neg <- !is.na(y.neg) good.pos <- !is.na(y.pos) envelope(x.neg[good.neg], x.pos[good.pos], y.neg[good.neg], y.pos[good.pos], col=col.spread, alpha=alpha, border=border) }) } } } if(!draw) return(out) } gamLine <- function(x, y, col=carPalette()[1], log.x=FALSE, log.y=FALSE, var=FALSE, spread=var, smoother.args=NULL, draw=TRUE, offset=0) { gam <- mgcv::gam s <- mgcv::s lty.smooth <- default.arg(smoother.args, "lty.smooth", 1) lwd.smooth <- default.arg(smoother.args, "lwd.smooth", 2) col.smooth <- default.arg(smoother.args, "col.smooth", col) lty.spread <- default.arg(smoother.args, "lty.spread", 4) lwd.spread <- default.arg(smoother.args, "lwd.spread", 2) col.spread <- default.arg(smoother.args, "col.spread", col) # arg '*.spread' and '*.var' are aliased. Use the latter if present lty.spread <- default.arg(smoother.args, "lty.var", lty.spread) lwd.spread <- default.arg(smoother.args, "lwd.var", lwd.spread) col.spread <- default.arg(smoother.args, "col.var", col.spread) fam <- default.arg(smoother.args, "family", gaussian) link <- default.arg(smoother.args, "link", NULL) evaluation <- default.arg(smoother.args, "evaluation", 50) style <- match.arg(default.arg(smoother.args, "style", "filled"), c("filled", "lines", "none")) if (style == "none") spread <- FALSE alpha <- default.arg(smoother.args, "alpha", 0.15) border <- default.arg(smoother.args, "border", TRUE) vertical <- default.arg(smoother.args, "vertical", TRUE) fam <- if(is.character(fam)) eval(parse(text=fam)) else fam link <- if(is.character(link)) make.link(link) else link k <- default.arg(smoother.args, "k", -1) bs <- default.arg(smoother.args, "bs", "tp") if (is.character(family)) family <- eval(parse(text=family)) weights <- default.arg(smoother.args, "weights", NULL) spread <- spread && identical(fam, gaussian) && is.null(link) if (log.x) x <- log(x) if (log.y) y <- log(y) valid <- complete.cases(x, y) x <- x[valid] y <- y[valid] ord <- order(x) x <- x[ord] y <- y[ord] x.eval <- seq(min(x), max(x), length=evaluation) w <-if (is.null(weights)) rep(1, length(y)) else weights[valid][ord] warn <- options(warn=-1) on.exit(options(warn)) fam1 <- if(is.null(link)) fam else fam(link) fit <- try(gam(y ~ s(x, k=k, bs=bs), weights=w, family=fam1)) if (class(fit)[1] != "try-error"){ y.eval <- predict(fit, newdata=data.frame(x=x.eval), type="response") if(draw)lines(if(log.x) exp(x.eval) else x.eval, if(log.y) exp(y.eval) else y.eval, lwd=lwd.smooth, col=col.smooth, lty=lty.smooth) out <- list(x=if(log.x) exp(x.eval) else x.eval, y=if(log.y) exp(y.eval) else y.eval) } else{ options(warn) warning("could not fit smooth") return()} if(spread) { res <- residuals(fit) pos <- res > 0 pos.fit <- try(gam(I(res^2) ~ s(x, k=k, bs=bs), subset=pos), silent=TRUE) neg.fit <- try(gam(I(res^2) ~ s(x, k=k, bs=bs), subset=!pos), silent=TRUE) if(class(pos.fit)[1] != "try-error"){ y.pos <- y.eval + sqrt(offset^2 + predict(pos.fit, newdata=data.frame(x=x.eval), type="response")) if(draw && style == "lines") { lines(if(log.x) exp(x.eval) else x.eval, if(log.y) exp(y.pos) else y.pos, lwd=lwd.spread, lty=lty.spread, col=col.spread) } else { out$x.pos <- if(log.x) exp(x.eval) else x.eval out$y.pos <- if(log.y) exp(y.pos) else y.pos } } else{ options(warn) warning("could not fit positive part of the spread") } if(class(neg.fit)[1] != "try-error"){ y.neg <- y.eval - sqrt(offset^2 + predict(neg.fit, newdata=data.frame(x=x.eval), type="response")) if(draw && style == "lines") { lines(if(log.x) exp(x.eval) else x.eval, if(log.y) exp(y.neg) else y.neg, lwd=lwd.spread, lty=lty.spread, col=col.spread) } else { out$x.neg <- if(log.x) exp(x.eval) else x.eval out$y.neg <- if(log.y) exp(y.neg) else y.neg } } else { options(warn) warning("could not fit negative part of the spread") } if (draw && style == "filled"){ if (vertical){ with(out, { good <- complete.cases(x.neg, x.pos, y.neg, y.pos) envelope(x.neg[good], x.pos[good], y.neg[good], y.pos[good], col=col.spread, alpha=alpha, border=border) }) } else { with(out, { good.neg <- !is.na(y.neg) good.pos <- !is.na(y.pos) envelope(x.neg[good.neg], x.pos[good.pos], y.neg[good.neg], y.pos[good.pos], col=col.spread, alpha=alpha, border=border) }) } } } if(!draw) return(out) } quantregLine <- function(x, y, col=carPalette()[1], log.x=FALSE, log.y=FALSE, var=FALSE, spread=var, smoother.args=NULL, draw=TRUE, offset=0) { if (!package.installed("Matrix")) stop("the Matrix package is missing") if (!package.installed("MatrixModels")) stop("the MatrixModels package is missing") if (!package.installed("SparseM")) stop("the SparseM package is missing") qss <- quantreg::qss rqss <- quantreg::rqss lty.smooth <- default.arg(smoother.args, "lty.smooth", 1) lwd.smooth <- default.arg(smoother.args, "lwd.smooth", 2) col.smooth <- default.arg(smoother.args, "col.smooth", col) lty.spread <- default.arg(smoother.args, "lty.spread", 4) lwd.spread <- default.arg(smoother.args, "lwd.spread", 2) col.spread <- default.arg(smoother.args, "col.spread", col) # arg '*.spread' and '*.var' are aliased. Use the latter if present lty.spread <- default.arg(smoother.args, "lty.var", lty.spread) lwd.spread <- default.arg(smoother.args, "lwd.var", lwd.spread) col.spread <- default.arg(smoother.args, "col.var", col.spread) style <- match.arg(default.arg(smoother.args, "style", "filled"), c("filled", "lines", "none")) if (style == "none") spread <- FALSE alpha <- default.arg(smoother.args, "alpha", 0.15) border <- default.arg(smoother.args, "border", TRUE) vertical <- default.arg(smoother.args, "vertical", TRUE) evaluation <- default.arg(smoother.args, "evaluation", 50) if (log.x) x <- log(x) if (log.y) y <- log(y) lambda <- default.arg(smoother.args, "lambda", IQR(x, na.rm=TRUE)) valid <- complete.cases(x, y) x <- x[valid] y <- y[valid] ord <- order(x) x <- x[ord] y <- y[ord] x.eval <- seq(min(x), max(x), length=evaluation) Data <- data.frame(x, y) if (!spread){ fit <- rqss(y ~ qss(x, lambda=lambda), data=Data) y.eval <- predict(fit, newdata=data.frame(x=x.eval)) y.eval <- if(log.y) exp(y.eval) else y.eval if(draw)lines(if(log.x) exp(x.eval) else x.eval, y.eval, lwd=lwd.smooth, col=col, lty=lty.smooth) else out <- list(x=if(log.x) exp(x.eval) else x.eval, y=y.eval) } else{ fit <- rqss(y ~ qss(x, lambda=lambda), data=Data) q1fit <- rqss(y ~ qss(x, lambda=lambda), tau=0.25, data=Data) q3fit <- rqss(y ~ qss(x, lambda=lambda), tau=0.75, data=Data) y.eval <- predict(fit, newdata=data.frame(x=x.eval)) y.eval.q1 <- predict(q1fit, newdata=data.frame(x=x.eval)) y.eval.q3 <- predict(q3fit, newdata=data.frame(x=x.eval)) y.eval <- if(log.y) exp(y.eval) else y.eval y.eval.q1 <- if(log.y) exp(y.eval.q1) else y.eval.q1 y.eval.q3 <- if(log.y) exp(y.eval.q3) else y.eval.q3 # adjust for offset y.eval.q1 <- y.eval - sqrt( (y.eval-y.eval.q1)^2 + offset^2) y.eval.q3 <- y.eval + sqrt( (y.eval-y.eval.q3)^2 + offset^2) if (draw) { lines(if(log.x) exp(x.eval) else x.eval, y.eval, lwd=lwd.smooth, col=col.smooth, lty=lty.smooth) } if(draw && style == "lines") { lines(if(log.x) exp(x.eval) else x.eval, y.eval.q1, lwd=lwd.spread, lty=lty.spread, col=col.spread) lines(if(log.x) exp(x.eval) else x.eval, y.eval.q3, lwd=lwd.spread, lty=lty.spread, col=col.spread) } else { x.eval <- if(log.x) exp(x.eval) else x.eval out <- list(x=x.eval, y=y.eval) out$x.neg <- x.eval out$y.neg <- y.eval.q1 out$x.pos <- x.eval out$y.pos <- y.eval.q3 } if (draw && style == "filled"){ if (vertical){ with(out, { good <- complete.cases(x.neg, x.pos, y.neg, y.pos) envelope(x.neg[good], x.pos[good], y.neg[good], y.pos[good], col=col.spread, alpha=alpha, border=border) }) } else { with(out, { good.neg <- !is.na(y.neg) good.pos <- !is.na(y.pos) envelope(x.neg[good.neg], x.pos[good.pos], y.neg[good.neg], y.pos[good.pos], col=col.spread, alpha=alpha, border=border) }) } } } if(!draw) return(out) } car/R/infIndexPlot.R0000644000176000001440000000654714140261763014016 0ustar ripleyusers# influence index plot written 9 Dec 09 by S. Weisberg # 21 Jan 10: added wrapper influenceIndexPlot(). J. Fox # 30 March 10: bug-fixes and changed arguments, S. Weisberg # 15 October 13: Bug-fix on labelling x-axis # 25 April 2016: For compatibility with Rcmdr, change na.action=exclude to na.action=na.omit SW. # 2016-07-23: add ... argument to call to lines(). J. Fox # 2017-02-12: consolidated id argument # 2017-11-30: substitute carPalette() for palette(). J. Fox # 2019-01-02: add lmerMod method and make lm method work for it. J. Fox # 2019-11-14: change class(x) == "y" to inherits(x, "y") influenceIndexPlot <- function(model, ...){ UseMethod("infIndexPlot") } infIndexPlot <- function(model, ...){ UseMethod("infIndexPlot") } infIndexPlot.lm <- function(model, vars=c("Cook", "Studentized", "Bonf", "hat"), id=TRUE, grid=TRUE, main="Diagnostic Plots", ...){ id <- applyDefaults(id, defaults=list(method="y", n=2, cex=1, col=carPalette()[1], location="lr"), type="id") if (isFALSE(id)){ id.n <- 0 id.method <- "none" labels <- id.cex <- id.col <- id.location <- NULL } else{ labels <- id$labels if (is.null(labels)) labels <- row.names(model.frame(model)) id.method <- id$method id.n <- if ("identify" %in% id.method) Inf else id$n id.cex <- id$cex id.col <- id$col id.location <- id$location } # Added for compatibility with Rcmdr if(inherits(na.action(model), "exclude")) model <- update(model, na.action=na.omit) # End addition what <- pmatch(tolower(vars), tolower(c("Cook", "Studentized", "Bonf", "hat"))) if(length(what) < 1) stop("Nothing to plot") names <- c("Cook's distance", "Studentized residuals", "Bonferroni p-value", "hat-values") # check for row.names, and use them if they are numeric. op <- par(mfrow=c(length(what), 1), mar=c(1, 4, 0, 2) + .0, mgp=c(2, 1, 0), oma=c(6, 0, 6, 0)) oldwarn <- options()$warn options(warn=-1) xaxis <- as.numeric(row.names(model.matrix(model))) options(warn=oldwarn) if (any (is.na(xaxis))) xaxis <- 1:length(xaxis) on.exit(par(op)) outlier.t.test <- pmin(outlierTest(model, order=FALSE, n.max=length(xaxis), cutoff=length(xaxis))$bonf.p, 1) nplots <- length(what) plotnum <- 0 for (j in what){ plotnum <- plotnum + 1 y <- switch(j, cooks.distance(model), rstudent(model), outlier.t.test, hatvalues(model)) plot(xaxis, y, type="n", ylab=names[j], xlab="", xaxt="n", tck=0.1, ...) if(grid){ grid(lty=1, equilogs=FALSE) box()} if(j==3) { for (k in which(y < 1)) lines(c(xaxis[k], xaxis[k]), c(1, y[k]), ...)} else { points(xaxis, y, type="h", ...)} points(xaxis, y, type="p", ...) if (j == 2) abline(h=0, lty=2 ) axis(1, labels= ifelse(plotnum < nplots, FALSE, TRUE)) showLabels(xaxis, y, labels=labels, method=id.method, n=id.n, cex=id.cex, col=id.col, location=id.location) } mtext(side=3, outer=TRUE ,main, cex=1.2, line=1) mtext(side=1, outer=TRUE, "Index", line=3) invisible() } infIndexPlot.lmerMod <- function(model, ...){ infIndexPlot.lm(model, ...) } car/R/leveragePlots.R0000644000176000001440000001016114140261763014212 0ustar ripleyusers# Leverage plots (J. Fox) # last modified 9 October 2009 by J. Fox # modified 25 November for layout and marking points only # changed 'vars' to 'terms' 16 March 2010 SW # 14 April 2010: set id.n = 0. J. Fox # 15 August 2010 S. Weisberg, added col.lines and col arguments # 5 Sept 2010 J. Fox, pass ... down to plot() and points() etc. # 16 June 2011 allow layout=NA, in which case the layout is not set in this # function, so it is the responsibility of the user # 25 April 2016: checks na.action for compatibility with Rcmdr. SW # 2017-02-12: consolidate id argument. J. Fox # 2017-11-09: made consistent with vcov() in R 2.5.0. J Fox # 2017-11-30: substitute carPalette() for palette(). J. Fox # 2019-11-14: change class(x) == "y" to inherits(x, "y") # these functions to be rewritten; simply renamed for now leveragePlots <- function(model, terms= ~ ., layout=NULL, ask, main, ...){ # Added for compatibility with Rcmdr if(inherits(model$na.action, "exclude")) model <- update(model, na.action=na.omit) # End addition terms <- if(is.character(terms)) paste("~",terms) else terms vform <- update(formula(model),terms) terms.model <- attr(attr(model.frame(model), "terms"), "term.labels") terms.vform <- attr(terms(vform), "term.labels") good <- terms.model[match(terms.vform, terms.model)] nt <- length(good) if (nt == 0) stop("No plots specified") if (missing(main)) main <- if (nt == 1) "Leverage Plot" else "Leverage Plots" nr <- 0 if (nt > 1 & (is.null(layout) || is.numeric(layout))) { if(is.null(layout)){ layout <- switch(min(nt, 9), c(1, 1), c(1, 2), c(2, 2), c(2, 2), c(3, 2), c(3, 2), c(3, 3), c(3, 3), c(3, 3)) } ask <- if(missing(ask) || is.null(ask)) prod(layout)1)) { stop("C+R plots not available for models with interactions.")} nt <- length(vterms) if (nt == 0) stop("No plots specified") if (missing(main)) main <- if (nt == 1) "Component + Residual Plot" else "Component + Residual Plots" if (nt > 1 & (is.null(layout) || is.numeric(layout))) { if(is.null(layout)){ layout <- switch(min(nt, 9), c(1, 1), c(1, 2), c(2, 2), c(2, 2), c(3, 2), c(3, 2), c(3, 3), c(3, 3), c(3, 3)) } ask <- if(missing(ask) || is.null(ask)) prod(layout)1)) { stop("C+R plots not available for models with interactions.") } if (!is.null(model$contrasts[[var]])){ partial.res<-residuals(model,"partial") .x<-model.frame(model)[,var] boxplot(partial.res[,var]~.x, xlab=xlab, ylab=ylab, ...) return(invisible()) } .x<-if (df.terms(model, var)>1) predict(model, type="terms", term=var) else model.matrix(model)[,var] if (order==1){ # handle first-order separately for efficiency partial.res<-residuals(model,"partial") plot(.x, partial.res[,var], type="n", xlab=xlab, ylab=ylab, ...) if(grid){ grid(lty=1, equilogs=FALSE) box()} points(.x, partial.res[,var], col=col, pch=pch) if (line) abline(lm(partial.res[,var]~.x), lty=2, lwd=lwd, col=col.lines[1]) if (is.function(smoother)) { smoother(.x, partial.res[,var], col=col.lines[2], log.x=FALSE, log.y=FALSE, spread=smoother.args$spread, smoother.args=smoother.args) } showLabels(.x, partial.res[,var], labels=labels, method=id.method, n=id.n, cex=id.cex, col=id.col, location=id.location) } else { if (df.terms(model, var) > 1) stop(paste("Order", order, "C+R plot not available for a term with > 1 df:", var)) aug.model<-update(model, as.formula(paste(".~.-",var,"+poly(",var,",",order,")"))) partial.res<-residuals(aug.model, "partial") last<-ncol(partial.res) plot(.x, partial.res[,last], xlab=xlab, ylab=ylab, type="n", ...) if(grid){ grid(lty=1, equilogs=FALSE) box()} points(.x, partial.res[,last], col=col, pch=pch) if (line) abline(lm(partial.res[,last]~.x), lty=2, lwd=lwd, col=col.lines[1]) if (is.function(smoother)) { smoother(.x, partial.res[, last], col=col.lines[2], log.x=FALSE, log.y=FALSE, spread=smoother.args$spread, smoother.args=smoother.args) } showLabels(.x, partial.res[,last], labels=labels, method=id.method, n=id.n, cex=id.cex, col=id.col, location=id.location) } } car/R/wcrossprod.R0000644000176000001440000000152514140261763013607 0ustar ripleyusers# added 2010-06-22; by M. Friendly, modified by J. Fox wcrossprod <- function(x, y, w) { if (is.vector(x)) x <- as.matrix(x) if (!missing(y)){ if (is.vector(y)) y <- as.matrix(y) if (nrow(x) != nrow(y)) stop("x and y not conformable") } if (missing(w)) { if (missing(y)) return(crossprod(x)) else return(crossprod(x, y)) } else if (length(w)==1 || (is.vector(w) && sd(w) < sqrt(.Machine$double.eps))) { if (missing (y)) return(w[1]*crossprod(x)) else return(w[1]*crossprod(x, y)) } else { if (is.vector(w)) { if (length(w) != nrow(x)) stop("w is the wrong length") if (missing(y)) return(crossprod(x, w*x)) else return(crossprod(x, w*y)) } else { if (nrow(w) != ncol(w) || nrow(w) != nrow(x)) stop("w is the wrong dimension") if (missing(y)) return(crossprod(x, w %*% x)) else return(crossprod(x, w %*% y)) } } } car/R/subsets.R0000644000176000001440000000361214140261763013071 0ustar ripleyusers# Plot optimal subsets regressions -- output from regsubsets # function in leaps package # last modified 2015-01-27 by J. Fox subsets <- function(object, ...){ # if (!require(leaps)) stop("leaps package missing") UseMethod("subsets") } subsets.regsubsets <- function(object, names=abbreviate(object$xnames, minlength=abbrev), abbrev=1, min.size=1, max.size=length(names), legend="interactive", statistic=c("bic", "cp", "adjr2", "rsq", "rss"), las=par("las"), cex.subsets=1, ...) { sumry <- summary(object) incidence <- sumry$which if (object$xnames[1] == "(Intercept)"){ if (missing(names)) names <- names[-1] incidence <- incidence[, -1] } statistic <- match.arg(statistic) stat <- switch(statistic, bic = sumry$bic, cp = sumry$cp, adjr2 = sumry$adjr2, rsq = sumry$rsq, rss = sumry$rss) subset.size <- as.numeric(rownames(incidence)) select <- subset.size >= min.size & subset.size <= max.size subset.size <- subset.size[select] stat <- stat[select] incidence <- incidence[select, ] plot(c(min.size, max.size), range(stat), type="n", xlab="Subset Size", ylab=paste("Statistic:", statistic), las=las, ...) for (i in seq(along=stat)){ adj <- if (subset.size[i] == min.size) 0 else if (subset.size[i] == max.size) 1 else .5 text(subset.size[i], stat[i], do.call("paste", c(as.list(names[incidence[i,]]),sep='-')), cex=cex.subsets, adj=adj) } if (!is.logical(legend)){ legend(if (!is.na(charmatch(legend[1], "interactive"))) locator(1) else if (is.character(legend)) legend else if (is.numeric(legend) && length(legend == 2)) list(x=legend[1], y=legend[2]) else stop("improper legend argument"), legend=apply(cbind(names, names(names)), 1, function(x) do.call("paste", c(as.list(x), sep=": "))), xpd=TRUE) return(invisible(NULL)) } else { Abbreviation <- names return(as.data.frame(Abbreviation)) } } car/R/residualPlots.R0000644000176000001440000003617514140261763014245 0ustar ripleyusers# Modified Nov. 24, 2009 by S. Weisberg to use showLabels # rather than showExtremes # 11 & 20 January 2010: changed lty=3 to lty=1 for fitted curve. J. Fox # 14 April 2010: set id.n = 0. J. Fox # 15 April 2010; rewrite showLabels # 25 May 2010 added grid() to plots, S. Weisberg # 15 August 2010, fixed so col= works correctly with plot, but not Boxplot # 15 August 2010, deleted pch= argument, as it wasn't used # 17 January 2011, allow spline terms; plot against # predict(model, type="terms")[[term.name]] # 1 February 2011 default for AsIs changed to TRUE # 31 March 2011 tukeyNonaddTest updated to check that yhat^2 is not # a linear combination of other predictors (as in 1-way anova). # 6 April 2011 omit printing lack-of-fit if no lack-of-fit test is possible # 16 June 2011 allow layout=NA, in which case the layout is not set in this # function, so it is the responsibility of the user # 10 Feb 2013: adjusted colinearity check in tukeyNonaddTest # 21 March 2013: fixed nonconstant variance test with missing values for glms # 11 July 2013: wording changes # 11 July 2013: 'groups' arg for residualPlot and residualPlots. # 19 July 2014: type='rstudent' fixed # 7 October 2014: trapped error resulting from groups= when n<3 # 25 April 2016: checks for na.action=na.exclude and changes it to na.omit for compatibility with Rcmdr. sw # 2017-02-13: consolidated id and smooth arguments. John # 2017-11-30: substitute carPalette() for palette(). J. Fox # 2019-11-14: change class(x) == "y" to inherits(x, "y") # 2018-08-06: enabled spread and var for smoothers. J. Fox residualPlots <- function(model, ...){UseMethod("residualPlots")} residualPlots.default <- function(model, terms= ~ . , layout=NULL, ask, main="", fitted=TRUE, AsIs=TRUE, plot=TRUE, tests=TRUE, groups, ...){ mf <- if(!is.null(terms)) termsToMf(model, terms) else NULL # Added for compatibility with Rcmdr if(inherits(model$na.action, "exclude")) model <- update(model, na.action=na.omit) # End addition groups <- if (!missing(groups)) { termsToMf(model, as.formula(paste("~", deparse(substitute(groups)))))$mf.vars[, 2, drop=FALSE] } else { if(is.null(mf$mf.groups)) NULL else mf$mf.groups[, 2, drop=FALSE] } mf <- mf$mf.vars vform <- update(formula(model), attr(mf, "terms")) if(any(is.na(match(all.vars(vform), all.vars(formula(model)))))) stop("Only regressors in the formula can be plotted.") terms <- attr(mf, "term.labels") # this is a list vterms <- attr(terms(vform), "term.labels") # drop interactions (order > 1) vterms <- setdiff(vterms, terms[attr(mf, "order") > 1]) # keep only terms that are numeric or integer or factors or poly good <- NULL for (term in vterms) if( (AsIs == TRUE & inherits(model$model[[term]], "AsIs")) | inherits(model$model[[term]], "numeric") | inherits(model$model[[term]], "integer") | (inherits(model$model[[term]], "factor") & is.null(groups)) | inherits(model$model[[term]], "matrix") | inherits(model$model[[term]], "poly")) good <- c(good, term) nt <- length(good) + fitted nr <- 0 if (nt == 0) stop("No plots specified") if (nt > 1 & plot == TRUE & (is.null(layout) || is.numeric(layout))) { if(is.null(layout)){ layout <- switch(min(nt, 9), c(1, 1), c(1, 2), c(2, 2), c(2, 2), c(3, 2), c(3, 2), c(3, 3), c(3, 3), c(3, 3)) } ask <- if(missing(ask) || is.null(ask)) prod(layout)|Test stat|)") return(if(tests == FALSE | !is.null(groups)) invisible(ans) else if(all(is.na(ans))) warning("No possible lack-of-fit tests") else printCoefmat(ans, has.Pvalue=TRUE, na.print="")) } else invisible(NULL) } residualPlots.lm <- function(model, ...) { residualPlots.default(model, ...) } residualPlots.glm <- function(model, ...) { residualPlots.default(model, ...) } residualPlot <- function(model, ...) UseMethod("residualPlot") residualPlot.default <- function(model, variable = "fitted", type = "pearson", groups, plot = TRUE, linear = TRUE, quadratic = if(missing(groups)) TRUE else FALSE, smooth=FALSE, id=FALSE, col = carPalette()[1], col.quad = carPalette()[2], pch=1, xlab, ylab, lwd = 1, lty = 1, grid=TRUE, key=!missing(groups), ...) { id <- applyDefaults(id, defaults=list(method="r", n=2, cex=1, col=carPalette()[1], location="lr"), type="id") if (isFALSE(id)){ id.n <- 0 id.method <- "none" labels <- id.cex <- id.col <- id.location <- NULL } else{ labels <- id$labels if (is.null(labels)) labels <- names(na.omit(residuals(model))) id.method <- id$method id.n <- if ("identify" %in% id.method) Inf else id$n id.cex <- id$cex id.col <- id$col id.location <- id$location } smoother.args <- applyDefaults(smooth, defaults=list(smoother=loessLine, span=2/3, var=FALSE, col=carPalette()[3]), type="smooth") if (!isFALSE(smoother.args)) { smoother <- smoother.args$smoother col.smooth <- smoother.args$col smoother.args$smoother <- smoother.args$col <- NULL if (is.null(smoother.args$spread)) smoother.args$spread <- smoother.args$var } else smoother <- NULL string.capitalize <- function(string) { paste(toupper(substring(string, 1, 1)), substring(string, 2), sep="")} # if(missing(labels)) # labels <- names(residuals(model)[!is.na(residuals(model))]) ylab <- if(!missing(ylab)) ylab else paste(string.capitalize(type), "residuals") column <- match(variable, names(model$model)) # Added for compatibility with Rcmdr if(inherits(model$na.action, "exclude")) model <- update(model, na.action=na.omit) # End addition if(is.na(column) && variable != "fitted") stop(paste(variable, "is not a regressor in the mean function")) horiz <- if(variable == "fitted") predict(model) else model$model[[column]] lab <- if(variable == "fitted") { if(inherits(model, "glm")) "Linear Predictor" else "Fitted values"} else variable lab <- if(!missing(xlab)) xlab else lab if(class(horiz)[1] == "ordered") horiz <- factor(horiz, ordered=FALSE) ans <- if(inherits(horiz, "poly")) { horiz <- horiz[ , 1] lab <- paste("Linear part of", lab) c(NA, NA)} else if (inherits(horiz, "matrix")) { horiz <- try(predict(model, type="terms"), silent=TRUE) if(inherits(horiz, "try-error")) stop("Could not plot spline terms") warning("Splines replaced by a fitted linear combination") horiz <- horiz[ , variable] c(NA, NA) } else if (inherits(horiz, "factor")) c(NA, NA) else residCurvTest(model, variable) # are there groups if(!missing(groups)){ if(is.data.frame(groups)){ groups.name <- names(groups)[1] groups <- groups[, 1, drop=TRUE] } else groups.name <- deparse(substitute(groups)) groups <- if(class(groups)[1] == "factor") groups else factor(groups, ordered=FALSE) if(key){ mar3 <- 1.1 + length(levels(groups)) op <- par(mar=c(5.1, 4.1, mar3, 2.1)) on.exit(par(op)) } colors <- if(length(col) >=length(levels(groups))) col else carPalette() col <- colors[as.numeric(groups)] pchs <- if(length(pch) >= length(levels(groups))) pch else 1:length(levels(groups)) pch <- pchs[as.numeric(groups)] } theResiduals <- switch(type, "rstudent"=rstudent(model), "rstandard"=rstandard(model), residuals(model, type=type)) if(plot==TRUE){ if(inherits(horiz, "factor")) { idm <- if(is.list(id.method)) { lapply(id.method, function(x) if(x[1]=="xy") "y" else x)} else { if(id.method[1] == "xy") "y"} Boxplot(theResiduals, horiz, xlab=lab, ylab=ylab, labels=labels, id.method=idm, id.n=id.n, id.cex=id.cex, id.col=id.col, id.location=id.location, ...) abline(h=0, lty=2) } else { plot(horiz, theResiduals, xlab=lab, ylab=ylab, type="n", ...) if(grid){ grid(lty=1, equilogs=FALSE) box()} points(horiz, theResiduals, col=col, pch=pch, ...) if(linear){ if(missing(groups)){abline(h=0, lty=2, lwd=2)} else { for (g in 1:length(levels(groups))) try(abline(lm(theResiduals ~ horiz, subset=groups==levels(groups)[g]), lty=2, lwd=2, col=colors[g]), silent=TRUE) }} if(quadratic){ new <- seq(min(horiz), max(horiz), length=200) if(missing(groups)){ if(length(unique(horiz)) > 2){ lm2 <- lm(theResiduals ~ poly(horiz, 2)) lines(new, predict(lm2, list(horiz=new)), lty=1, lwd=2, col=col.quad) }} else { for (g in 1:length(levels(groups))){ if(length(unique(horiz)) > 2){ lm2 <- lm(theResiduals~poly(horiz, 2), subset=groups==levels(groups)[g]) lines(new, predict(lm2, list(horiz=new)), lty=1, lwd=1.5, col=colors[g]) }}}} if(is.function(smoother)) if(missing(groups)){ smoother(horiz, theResiduals, col.smooth, log.x=FALSE, log.y=FALSE, spread=smoother.args$spread, smoother.args=smoother.args)} else for (g in 1:length(levels(groups))){ sel <- groups == levels(groups)[g] smoother(horiz[sel], theResiduals[sel], colors[g], log.x=FALSE, log.y=FALSE, spread=smoother.args$spread, smoother.args=smoother.args)} if(key & !missing(groups)){ items <- paste(groups.name, levels(groups), sep= " = ") plotArrayLegend("top", items=items, col.items=colors, pch=pchs) } showLabels(horiz, theResiduals, labels=labels, method=id.method, n=id.n, cex=id.cex, col=id.col, location=id.location) } } invisible(ans)} residCurvTest <- function(model, variable) {UseMethod("residCurvTest")} residCurvTest.lm <- function(model, variable) { if(variable == "fitted") tukeyNonaddTest(model) else { if(is.na(match(variable, attr(model$terms, "term.labels")))) stop(paste(variable, "is not a term in the mean function")) else { xsqres <- qr.resid(model$qr, model.frame(model)[[variable]]^2) r <- residuals(model, type="pearson") m1 <- lm(r ~ xsqres, weights=weights(model)) df.correction <- sqrt((df.residual(model)-1) / df.residual(m1)) test <- summary(m1)$coef[2, 3] * df.correction c(Test=test, Pvalue=2 * pt(-abs(test), df.residual(model)-1)) }}} residCurvTest.glm <- function(model, variable) { if(variable == "fitted") c(NA, NA) else { if(is.na(match(variable, attr(model$terms, "term.labels")))) stop(paste(variable, "is not a term in the mean function")) else { newmod <- paste(" ~ . + I(", variable, "^2)") m2 <- update(model, newmod, start=NULL) c(Test= test<-deviance(model)-deviance(m2), Pvalue=1-pchisq(test, 1)) }}} residCurvTest.negbin <- function(model, variable) { if(variable == "fitted") c(NA, NA) else { if(is.na(match(variable, attr(model$terms, "term.labels")))) stop(paste(variable, "is not a term in the mean function")) else { newmod <- paste(" ~ . + I(", variable, "^2)") m2 <- update(model, newmod, start=NULL) c(Test= test<-m2$twologlik - model$twologlik, Pvalue=1-pchisq(test, 1)) }}} tukeyNonaddTest <- function(model){ tol <- model$qr$tol qr <- model$qr fitsq <- predict(model, type="response")^2 fitsq <- qr.resid(qr, fitsq/sqrt(sum(fitsq^2))) if(sd(fitsq) < tol) { return(c(Test=NA, Pvalue=NA)) } else { r <- residuals(model, type="pearson") m1 <- lm(r ~ fitsq, weights=weights(model)) df.correction <- sqrt((df.residual(model) - 1)/df.residual(m1)) tukey <- summary(m1)$coef[2, 3] * df.correction c(Test=tukey, Pvalue=2*pnorm(-abs(tukey))) } } residualPlot.lm <- function(model, ...) { residualPlot.default(model, ...) } residualPlot.glm <- function(model, variable = "fitted", type = "pearson", plot = TRUE, quadratic = FALSE, smooth=TRUE, ...){ residualPlot.default(model, variable=variable, type=type, plot=plot, quadratic=quadratic, smooth=smooth, ...) } car/R/brief.R0000644000176000001440000003475414140261763012503 0ustar ripleyusers# added 2017-11-19 by J. Fox # 2017-11-20: made S() methods brief() methods. J. Fox # 2017-11-22: fixed brief.lm() and brief.glm() for models with aliased coeffs. J. Fox # 2017-11-22: fixed bugs in brief.data.frame(), improved brief() and brief.list(). J. Fox # 2017-12-15--21: tweaks to brief.data.frame. J. Fox # 2017-12-19: added head, tail args to brief.data.frame() # 2018-02-10: tweak brief.glm() output formatting # 2018-12-26: Changed the argument for brief.lm from vcov.=vcov to just vcov. If arg is # missing set vcov. = vcov(object, complete=FALSE) to match brief.glm # 2020-10-07: added brief.tbl() to cope with changes to tibbles. brief <- function(object, ...){ g <- options("max.print"=.Machine$integer.max) on.exit(options(g)) UseMethod("brief") } brief.matrix <- function(object, rows=if(nr <= 10) c(nr, 0) else c(3, 2), ...){ nr <- nrow(object) brief.data.frame(object, rows, ...) } brief.data.frame <- function(object, rows=if(nr <= 10) c(nr, 0) else c(3, 2), cols, head=FALSE, tail=FALSE, elided=TRUE, classes=inherits(object, "data.frame"), ...){ pad <- function(x, right=TRUE){ nch <- nchar(x) maxch <- max(nch) if (classes) maxch <- max(maxch, 3) if (right) paste0(x, strrep(" ", maxch - nch)) else paste0(strrep(" ", maxch - nch), x) } find.max.cols <- function(object, first, last, end=2){ ncol <- ncol(object) nrow <- nrow(object) rows <- if (nrow > first + last) c(1:first, (nrow - last + 1):nrow) else 1:nrow nrows <- length(rows) object <- object[rows, , drop=FALSE] for(i in 1:(ncol - end)){ res <- capture.output( if ((i + end) < ncol) cbind(object[ , c(1:i, (ncol - end + 1):ncol), drop=FALSE], ". . .") else object[ , c(1:i, (ncol - end + 1):ncol), drop=FALSE]) if (length(res) > nrows + 1) { i <- i - 1 break } } if (i < 1){ i <- 1 end <- end - 1 } c(i, end) } if (!isFALSE(head)){ rows <- if (isTRUE(head)) c(6, 0) else c(head, 0) } if (!isFALSE(tail)){ rows <- if (isTRUE(tail)) c(0, 6) else c(0, tail) } xx <- object dim <- dim(object) nr <- nrow(object) nc <- ncol(object) first <- rows[1] last <- rows[2] if (missing(cols)){ cols <- find.max.cols(object, first, last) } first.c <- cols[1] last.c <- cols[2] if ((first.c + last.c) == 0 || (first + last) == 0) { stop("nothing to show") return(invisible(xx)) } e.rows <- nr - (first + last) e.cols <- nc - (first.c + last.c) cat(dim[1], "x", dim[2], class(object)[1]) if (elided && e.rows + e.cols > 0){ cat(" (") if (e.rows > 0) cat(e.rows, "rows") if (e.rows > 0 && e.cols > 0) cat(" and ") if (e.cols > 0) cat(e.cols, "columns") cat (" omitted)") } cat("\n") if (length(elided) == 1) elided <- rep(elided, 2) force(classes) char <- is.character(object) rnms <- rownames(object) if (is.null(rnms)) { rnms <- paste0("[", 1:nr, ",]") rnames <- FALSE } else rnames <- TRUE nch <- nchar(rnms) mch <- max(nch[if (last == 0) 1:first else c(1:first, (nr - last + 1):nr)]) rnms <- if (rnames) paste0(rnms, sapply(pmax(mch - nch, 0), function(x) paste0(rep(" ", x), collapse=""))) else paste0(sapply(pmax(mch - nch, 0), function(x) paste0(rep(" ", x), collapse="")), rnms) rownames(object) <- rnms if (is.null(colnames(object))) { colnames(object) <- paste0("[,", 1:nc, "]") } object <- as.data.frame(object) if (nr - (first + last) > 0) object <- object[c(1:first, (nr - last + 1):nr), ] elided.cols <- FALSE if (nc - (first.c + last.c) > 0) { elided.cols <- TRUE object.left <- if (first.c > 0) cbind(object[, 1:first.c, drop=FALSE], rep("", nrow(object))) else matrix(rep("", nrow(object))) object <- if (last.c > 0) cbind(object.left, object[, (nc - last.c + 1):nc, drop=FALSE]) else object.left colnames(object)[first.c + 1] <- ". . ." } col.classes <- paste0("[", substring(sapply(object, class), 1, 1), "]") for (j in 1:ncol(object)){ if (is.numeric(object[, j])) { object[, j] <- format(object[, j]) object[, j] <- pad(object[, j], right=FALSE) } else if (is.factor(object[, j])) { object[, j] <- droplevels(object[, j]) levels(object[, j]) <- pad(levels(object[, j])) } else if (is.character(object[, j])) object[, j] <- pad(object[, j]) } cnms <- colnames(object) object <- format(object) if (classes) { if (nc - (first.c + last.c) > 0) col.classes[first.c + 1] <- "" object <- rbind(col.classes , object) rownames(object)[1] <-"" first <- first + 1 nr <- nr + 1 } if (first - classes > 0) { print(object[1:first, ], quote=char && !elided.cols) if (nr - (first + last) > 0) { cat(". . .") nch <- nchar(cnms) cnms <- sapply(nch, function(x) paste0(rep(" ", x), collapse="")) colnames(object) <- cnms if (last > 0) print(object[(first + 1):(first + last), ], quote=char && !elided.cols) } } else{ object[1 + classes, ] <- rep("", ncol(object)) rownames(object)[1 + classes] <- ". . ." print(object, quote=char && !elided.cols) } invisible(xx) } brief.function <- function(object, rows=c(5, 3), elided=TRUE, ...){ first <- rows[1] last <- rows[2] fn <- format(object) nr <- length(fn) if (nr <= first + last) print(fn) else { cat(paste0(deparse(substitute(object)), " <- ", paste(fn[1:first], collapse="\n"))) cat(paste0("\n\n. . . ", if (elided) paste0("(", nr - first - last, " lines omitted)"), "\n\n")) cat(paste(fn[(nr - last + 1):nr], collapse="\n")) cat("\n") } invisible(object) } brief.list <- function(object, rows=c(2, 1), elided=TRUE, ...){ xx <- object first <- rows[1] last <- rows[2] nr <- length(object) if (nr <= first + last) print(object) else{ cat(length(object),"element list") if (is.null(names(object))){ names(object) <- 1:nr } for (i in 1:first){ cat(paste0("\n[[", names(object[i]), "]]\n")) brief(object[[i]], elided=elided) } cat(paste0("\n. . . ", if (elided) paste0("(", nr - first - last, " list elements omitted)"), "\n")) for (i in (nr - last + 1):nr){ cat(paste0("\n[[", names(object[i]), "]]\n")) brief(object[[i]], elided=elided) } } invisible(xx) } brief.vector <- function(object, rows=c(2, 1), elided=TRUE, ...){ first <- rows[1] last <- rows[2] result <- capture.output(object) nr <- length(result) if (nr <= first + last) print(object) else{ cat(length(object),"element", class(object)[1], "vector") cat("\n", paste0(result[1:first], "\n")) cat(paste0("\n. . . ", if (elided) paste0("(", nr - first - last, " lines omitted)"), "\n")) cat("\n", paste0(result[(nr - last + 1):nr]), "\n") } invisible(object) } # brief.vector() isn't a method and isn't exported brief.integer <- brief.numeric <- brief.character <- brief.vector brief.factor<- function(object, rows=c(2, 1), elided=TRUE, ...){ first <- rows[1] last <- rows[2] result <- capture.output(object) levels <- result[length(result)] result <- result[-length(result)] nr <- length(result) if (nr <= first + last) print(object) else{ cat(length(object),"element factor") cat("\n", paste0(result[1:first], "\n")) cat(paste0("\n. . . ", if (elided) paste0("(", nr - first - last, " lines omitted)"), "\n")) cat("\n", paste0(result[(nr - last + 1):nr]), "\n") cat(levels) } invisible(object) } # methods for statistical models brief.default <- function(object, terms = ~ ., intercept=missing(terms), pvalues=FALSE, digits=3, horizontal=TRUE, ...){ sumry <- summary(object) if (is.atomic(object) || is.atomic(sumry) || is.null(sumry$coefficients) || !is.matrix(sumry$coefficients)){ if (is.vector(object)) brief.vector(object, ...) else if (is.list(object)) brief.list(object, ...) else stop("no appropriate method for object of class '", class(object), "'") return(invisible(object)) } use <- coefs2use(object, terms, intercept) cols <- if (pvalues) c(1, 2, 4) else 1:2 coefs <- sumry$coefficients[use, cols, drop=FALSE] colnames(coefs) <- if (pvalues) c("Estimate", "Std. Error", "Pr(>|z|)") else c("Estimate", "Std. Error") print(if (horizontal) t(coefs) else coefs, digits=digits) invisible(sumry) } brief.lm <- function(object, terms = ~ ., intercept=missing(terms), pvalues=FALSE, digits=3, horizontal=TRUE, vcov., ...){ use <- coefs2use(object, terms, intercept) sumry <- S(object, vcov.=vcov., ...) cols <- if (pvalues) c(1, 2, 4) else 1:2 coefs <- sumry$coefficients if (!is.null(aliased <- sumry$aliased) && any(aliased)) { cn <- names(aliased) coefs <- matrix(NA, length(aliased), 4, dimnames = list(cn, colnames(coefs))) coefs[!aliased, ] <- sumry$coefficients } coefs <- coefs[use, cols, drop=FALSE] n.aliased <- sum(is.na(coefs[, 1])) if (n.aliased > 0) cat(n.aliased, if(n.aliased > 1) "coefficients" else "coefficient", "not defined because of singularities\n\n") colnames(coefs) <- if (pvalues) c("Estimate", "Std. Error", "Pr(>|t|)") else c("Estimate", "Std. Error") print(if (horizontal) t(coefs) else coefs, digits=digits) if (missing(terms)) cat("\n Residual SD =", format(sumry$sigma, digits=digits), "on", object$df.residual, "df, R-squared =", format(sumry$r.squared, digits=digits), "\n") invisible(sumry) } brief.glm <- function(object, terms = ~ ., intercept=missing(terms), pvalues=FALSE, digits=3, horizontal=TRUE, vcov., dispersion, exponentiate, ...){ if (!missing(vcov.) && !missing(dispersion)) stop("cannot specify both the dispersion and vcov. arguments") if (missing(exponentiate)) exponentiate <- object$family$link %in% c("log", "logit") use <- coefs2use(object, terms, intercept) sumry <- if (!missing(vcov.)) S(object, digits, vcov.=vcov., ...) else if (!missing(dispersion)) S(object, digits, dispersion=dispersion, ...) else summary(object, ...) cols <- if (pvalues) c(1, 2, 4) else 1:2 coefs <- sumry$coefficients if (!is.null(aliased <- sumry$aliased) && any(aliased)) { cn <- names(aliased) coefs <- matrix(NA, length(aliased), 4, dimnames = list(cn, colnames(coefs))) coefs[!aliased, ] <- sumry$coefficients } coefs <- coefs[use, cols, drop=FALSE] n.aliased <- sum(is.na(coefs[, 1])) if (n.aliased > 0) cat(n.aliased, if(n.aliased > 1) "coefficients" else "coefficient", "not defined because of singularities\n\n") colnames(coefs) <- if (pvalues) c("Estimate", "Std. Error", "Pr(>|t|)") else c("Estimate", "Std. Error") if (exponentiate){ coefs <- cbind(coefs, exp(coefs[, 1])) colnames(coefs)[if (pvalues) 4 else 3] <- "exp(Estimate)" } print(if (horizontal) t(coefs) else coefs, digits=digits) if (missing(terms)) cat(paste0("\n Residual deviance = ", format(object$deviance, digits=digits), " on ", object$df.residual, " df", if (family(object)$family %in% c("binomial", "poisson")) "\n" else (paste0(", Est. dispersion = ", format(sumry$dispersion, digits=digits), "\n")))) invisible(sumry) } brief.polr <- function(object, terms = ~ ., intercept, pvalues=FALSE, digits=3, horizontal=TRUE, exponentiate=TRUE, ...){ sumry <- summary(object) coefs <- sumry$coefficients[ , 1:2] if (pvalues) { coefs <- cbind(coefs, 2*pnorm(abs(coefs[ , 1]/coefs[, 2]), lower.tail=FALSE)) } use <- if (missing(terms)) 1:nrow(coefs) else coefs2use(object, terms, FALSE) coefs <- coefs[use, , drop=FALSE] colnames(coefs) <- if (pvalues) c("Estimate", "Std. Error", "Pr(>|z|)") else c("Estimate", "Std. Error") if (exponentiate){ coefs <- cbind(coefs, exp(coefs[, 1])) colnames(coefs)[if (pvalues) 4 else 3] <- "exp(Estimate)" if (missing(terms)){ n.thresholds <- length(object$zeta) n.pars <- nrow(coefs) coefs[(n.pars - n.thresholds + 1):n.pars , if (pvalues) 4 else 3] <- NA } } print(if (horizontal) t(coefs) else coefs, digits=digits, na.print="") if (missing(terms)) cat("\n Residual deviance =", format(object$deviance, digits=digits), "on", object$df.residual, "df") invisible(sumry) } brief.multinom <- function(object, terms = ~ ., intercept=missing(terms), pvalues=FALSE, digits=3, horizontal=TRUE, exponentiate=TRUE, ...){ use <- coefs2use(object, terms, intercept) sumry <- summary(object, ...) b <- sumry$coefficients se <- sumry$standard.errors p <- 2*pnorm(abs(b/se), lower.tail=FALSE) levels <- sumry$lev labels <- if (pvalues) c("Estimate", "Std. Error", "Pr(>|z|)") else c("Estimate", "Std. Error") if (exponentiate) labels <- c(labels, "exp(Estimate)") if (length(levels) == 2){ b <- b[use] se <- se[use] p <- p[use] table <- if (pvalues) rbind(b, se, p) else rbind(b, se) if (exponentiate) table <- rbind(table, exp(b)) rownames(table) <- labels cat("\n ", levels[2], "\n") print(if (horizontal) table else t(table), digits=digits) } else{ b <- b[, use, drop=FALSE] se <- se[, use, drop=FALSE] p <- p[, use, drop=FALSE] table <- if (pvalues) abind(t(b), t(se), t(p), along=1.5) else abind(t(b), t(se), along=1.5) if (exponentiate) table <- abind(table, t(exp(b)), along=2) dimnames(table)[[2]] <- labels for (level in levels[-1]){ cat("\n ", level, "\n") result <- if (horizontal) t(table[, , level]) else table[, , level] if (dim(table)[1] == 1){ if (horizontal) rownames(result) <- dimnames(table)[1] else { result <- matrix(result, ncol=1) colnames(result) <- dimnames(table)[1] } } print(result, digits=digits) } } if (missing(terms)) cat("\n Residual deviance =", format(object$deviance, digits=digits), "fitting", length(b), "parameters") invisible(sumry) } brief.tbl <- function(object, ...){ print(object, ...) } car/R/avPlots.R0000644000176000001440000002106314140261763013031 0ustar ripleyusers# October 23, 2009 avPlots by S. Weisberg. avPlot by John Fox # 13 January 2010: changed default id.n=3. J. Fox # 13 March 2010: added intercept argument. J. Fox # 14 April 2010: set id.n = 0. J. Fox # 22 April 2010: modified id.n S. Weisberg # 10 May 2010: added gridlines # 25 May 2010: changed default color scheme # 5 June 2011: made several modifications, slightly adapting code contributed by M. Friendly (J. Fox): # added ellipse, ellipse.args arguments # added main argument to avPlot.lm # return x and y residuals invisibly # 16 June 2011 allow layout=NA, in which case the layout is not set in this # function, so it is the responsibility of the user # 22 Sept 2013 added argument marginal.scale to set xlim and ylim according to xlim and # ylim of marginal plot (S. Weisberg) # 16 May 2016 added argument id.location to set location of labels (S. Weisberg) # 2017-11-30: substitute carPalette() for palette(). J. Fox # 2018-07-13: made avPlots() generic. J. Fox # 2021-04-24: added pt.wts and cex args. J. Fox avPlots <- function(model, ...){ UseMethod("avPlots") } avPlots.default <- function(model, terms=~., intercept=FALSE, layout=NULL, ask, main, ...){ terms <- if(is.character(terms)) paste("~",terms) else terms vform <- update(formula(model),terms) if(any(is.na(match(all.vars(vform), all.vars(formula(model)))))) stop("Only predictors in the formula can be plotted.") terms.model <- attr(attr(model.frame(model), "terms"), "term.labels") terms.vform <- attr(terms(vform), "term.labels") terms.used <- match(terms.vform, terms.model) mm <- model.matrix(model) model.names <- attributes(mm)$dimnames[[2]] model.assign <- attributes(mm)$assign good <- model.names[!is.na(match(model.assign, terms.used))] if (intercept) good <- c("(Intercept)", good) nt <- length(good) if (nt == 0) stop("No plots specified") if (missing(main)) main <- if (nt == 1) paste("Added-Variable Plot:", good) else "Added-Variable Plots" if (nt == 0) stop("No plots specified") if (nt > 1 & (is.null(layout) || is.numeric(layout))) { if(is.null(layout)){ layout <- switch(min(nt, 9), c(1, 1), c(1, 2), c(2, 2), c(2, 2), c(3, 2), c(3, 2), c(3, 3), c(3, 3), c(3, 3)) } ask <- if(missing(ask) || is.null(ask)) prod(layout)> stream xQMo0W<75K*FfFÒeDzQRʢ~/ =>_ua!>fp9Cxs, |DnK8[ee.gIAմ]JYK(i ]F*;gKG[G&D y)q> stream 2021-11-02T21:02:44+01:00 2021-11-02T21:02:44+01:00 UnknownApplication Untitled endstream endobj 11 0 obj << /Filter /FlateDecode /Length 107 >> stream x+T03T0A(Ue`hb$.YeE\ ƖfF uzF 0i\(Y*&Ʀ Y* 2 ҋ,"{endstream endobj 12 0 obj << /BitsPerComponent 1 /ColorSpace /DeviceGray /DecodeParms << /Columns 518 /K -1 >> /Filter /CCITTFaxDecode /Height 600 /Interpolate true /Subtype /Image /Width 518 /Length 612 >> stream &l/ g =< O< =A< xO< A< xO< =A< xO=A< xO=AxA< xOAxA< xO=xAxA=xOAxAxOAxAxAzxAxAmaXamaXaaXamaXaa[ aXaa[ aXal,0[ aXal,0[ aXal,0[ ,5Xal,0 ,5Xal,0 ,5[ ,0 ,5[ ,0 -0 k ,0 -0 k ,0 -0 k ,endstream endobj 13 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /DecodeParms << /Colors 3 /Columns 259 /Predictor 15 >> /Filter /FlateDecode /Height 300 /Interpolate true /SMask 12 0 R /Subtype /Image /Width 259 /Length 21098 >> stream xXSIIQ ĂuŮ(^~uEW,k]{﨨^QlEJgŐHBw}Xr3$͜o\)P(R}J*2n~vme^ *x Cʹ UB%z5YOSTUBR266~1N*6\P`yj* 5UBR%j*B@K 8<+T GK 8<T bF,PP vĆT#푫F <1 Z8[g': 5*L.5TkD5e*AtD Vt.aSOa@ e*A8e G@%J&JCC@ KCP "$M]PPNP%GH5b*?e BMUC̓JCUCC١J TeK 4X*#T X&*h%T/K 84X UB'MTj/9z %TwKЬ]g46k,`cr=~&rme{䒋]e^|yfxȨգ8=tk_R+X <-~=v&>*~y_J@\J8[{n[슳6\HC9*AKU/ib+ Fc8tOM>u%5 ]l`WK W"_K~| ߑ{o { K墄jo ~c3fɹ\ ƛo%#)c<&/•U'Xj%d]p}qťWv>h| ?#GZ\ ˈG 5/Z~kg`\E9ý| UBț+rʁ ʪc _g?b#a99Gik7jHQYQn8=kM6k]ed26֭۸.P%̃@J]Zt_AW{֞[\o?h *@H԰yz鮱J؍c; eUBJѮ~|{>nxkG : 4'7].n"AJ'M-6ßӬPKܬ܌/ ߂z> +H]%yqT8j+Z* "Uo͙:dJk|FSO~ra($3 |Q*tHmйt+b$%u5*I$?粆 ,6o޽XU*5m~t=33E55&sx_cЎyVC&⌲3TuVq:@Pj:O [99P }<x\'aҥ _KxN&1Gx.5b\h$kJ(Gr 'B IOa;v ,IK 2y5L~ K.ѳz:;9򄉳{]=[l C)?Z VBP^B~NTr2i}= _iP;s_^x=C.%m*\`6|G|8`3 AS=:!%*dAbt 0`>hr!@ʿ͛!Z_6ۍr|ZVw>W^txxᯢt8ׯCЩO: KPXwkUƑO 9}K>ȑr!!&s>'9uZ7n`i11ay|  !i~ SS,,;eOعӲ1 /n?㲸^^*FoPx: LuYO.w-[67RRϟO1B"+ tT,9n*AdB3Ç9vv \~g0gS rIhdm-@FfP݀佩s 8͓'Ou]r˓5N/mZiL))s禿ppN׮E>?z,v>*UxȃW2O\I8={`Á-az;?1YhLm,ڰذfeXrdi8pfBp賃_f}:Uy=ڹu뛛e<_9ؾ~;vRh 4QJ1k s:7=zwנAI&IS(갢&YIw$}u֠y[8q#t.q\oUQP Mq6tś7˒͠J5*A +}8iQ g><9ov+ z cL.Woذn2SG-!! @.5ں~Vַb()>kF Am7l+W3J8r2 SCIK+xLӯ@'XZY-ٺu…hP mm{ݻG~[6n|P" CvLa10Zn5*P% tSqqd´9*6h>\3V"{GyV'Ī|e!0kwqqC,%s%%i'y[ڭ󟗘ISëW\$彵:TF4UBYz=()>쇧75#,OϚ=8pT'j1a 6\t9&|~RAY&޽K`pйfoD : `wYSup)~3RԄ=&y/X/IC.,a:wǚNF ::ZFrA_$Hw!&Uh4iSX ''7u5}d;3g,5g^I :qxСA^chΓtu Pk[OANNJ:)?K6[la%ª+Y'L{ ~,m |mԨEddVc1wj?s.綽A䀱1u%qW*AD+W_8jllV.fd\FHY9g2Te+(`g4I!)m H~G3pm:{6 ZA<'ky;QgӞ6ъe}7uDa"Z*AD!=DqT4_?7= jպ;VsY[ǪJ\n㜉;l`UF2nbgб}Btu cc36o.oeRki'xcZ=F[NlcUku*AD!._sa͎aÇΞ]KFklF?庬sR0bڵӯ'(zmwbdO=*50(/ﺬ,yr \nut:Z} `8Y-us O>o<KfڀM UJqwŋp(`M5hp!#>`9_@ڵ?geebU5`䤦ht=>>$s*Їe{a$EIuf&6sI e44L:\'-+/`/#'= i+_5+W~|/UJ(7pkz1\z9kHf53#zUCRԢs>-j TG:5?^9pENnY? 6>ɰ"RNJ͚3d9kr`΁\iNwڒX /- & ;7k;,e?}Zs77.Z|e!P% dH ?S %2,*hԆΞ]voث"l7 صu>}tێy-&yzoS2 :  #-԰l3eIIɮXB7k{.5t^a/5>xY#\Wo|l01 |_k\^txo_U+0m_W3JuMc;w33hޜljQQdҷ>Հ+|֭^dB`^SV\Ygߘ@⢑u0~iiYjs2ɊsJy7nC < ˤj7u*Y_]2GWX&1T'U_QQ^JJFJ*43ό.e`t}FDVqV1a_\k>W/۷\j1M~ 9+Y`׆``-L @ϵ:!J 2!i(`qƎ7WTUN]$R"IpGvEO/-Y*;M G:+ k4,Sgg=9vc*Vysuޭ60`l| cƛҪU?_Ě>PI{n+- ¯Σ,,H+@` f߫?-n}`cgxB8Vk2i[) n/X8h;Jc jG&0NPD cǒ,vHی5]ӃӡcGR HojQP(MJ p .dcH5 & ;Gj=q߆-l4;9~`/gjj35ƽRRM_𝎙Ox6ĩBs&Lr}h,t 9H )(b>%ρAeԩpIW % j2 =N1%Qa_*  n&^sxx#QE{|y~\ H1ZI]k ^/J߹E̟OxxƲm[-`nfFԢ[ڪ]ltWWXu edt횃Uvr(42bt㺽{ƶmjyyӸs^ϥtLNl3|X]iXQ\l&P%uqq ?;hr9He{c ^d0|6m jZV/$C 2@C̫Bƌq,{IEr0N884:th߾}`?+%%t 6HnEϝsus}j9U,.]"d8({~z:)q T#%B ^C ~2:Ϟ%/-ڲe9sd$֬Yo۶nce;EwC922$%™`lge'-̨;.,a^$]m P5|W'..ݛc(K,.}`jjjiiJڿzjJprrڼy3<Ϻ.0fKR_'zW1~ E[U*i2®CDv 5JkWo\+JHϼr.mӆ{Sŋ [8y*1\)`k5kklll eF;vسǧ}-"}1_2tkaA10(Ą,%!cmMhR!}#˾aIVoqtNIQB*>'70+&yb"YiDg2k s ޽~O9vH`` ҳ?y>aΜ9w.iC6Oz䮾}K>k=b='yCTm??'y|F FAzv.M-wަg%CoDy D͟_yP-z醇WԳ b09ssĊ 5bTy3Yܹ_&Deczn 9`n際[jJ`=s_8 ]׈Νfu\z9 )Jx oWEMMyܸ 8uI/-u8%Kk\N448B]M5xsV~Nfp_$?Wde bk02"AX`EM Bʒ늽N 69[wܙ+ϟ7GXńC;=AUPY%OGG'"ԨQ$4%>۷U4iRk:Nd{Z}3oۄ{fstu%ϓ[_ٯ\ܹCq$Ņu&Oj*YީGr(5-@21Oϟޫ׀M3]s[ dҤ?Q?p72V0 r$ӧn% ^ aÆ֩SMp^ޥk砋ܻwoLsraY:}:YAﲡPRI'FX0'<*b=~ k3:WT/v2MYExF&|R”)ut//x⩓'8.\FkgD( ,uɿٳؼ줉GGǾ}OcE/9HO'v" Ý;wyigguZ0ѐNFV G(TBX?i .]"g2.! 1lk }ZYl֬5:QQQ}0Rz)vS ii阘%~Sڵ;7Uds۶&c l`` //M˗//\o_.pCWr~\^& 4 ٺ%cl͹dħOˢ/yhM߷-*{gO)]~5>~9O>" |y"J@{իW->i҄?[iˆ Tu&S^V6(c`2+ eUU:YsSSS>t<8?Z]Nx<;9TP?vġ7oJ:wkbRR''N RPP I(^%g"m/N:5`]*XBπv.]Hb @]rA%,YBVDی'ӗ.MN~z{w?xcK=IjI6zTRJ"=fLF4={>x9s~=D{e7UBU#| 9`c|ubƼ<[^M?͍0-[ w%ɲ,v횳jU}z6o*r{ɓ'Jfr2ֿp=ȈY }Nݻݹ}yLJVЪUљ** u nn֯_:yr\q#]\&M w%ɢ a>6wժ]O{zzz<{ָ%vfwdJ  "a…^xKNdv$ȳN_MPH$[:xo~pBs;؊.AojkKR?LZ1cj~c+Ww ڷ'%VC ,B3O9V7o^lnJJ@cx̞Runnn%!??^0o^E"ӧIwmӆ/UB#D jϞ=cbb\]] Jkqm􂖖;¶mXW2Zҏw݋/ݻoDn-d7GSRQaK&5`ݸ1Yd&q|"ӧ×/};t3#|zӧa6xq`U0]x|<\2ҥK ͝7o~JʁS~.K;3eē4Jݺ jҤIcXΟ?ziifx'6$kZ'S=Y|t~H[d"L)\]I6IulʕXАlذsG3* rsQER-xU҈G>n݂Y֭ɴWvƧO$|&!88;gu޽[ZZ:!!ɓׯӀ^\f'튉z L:T!YJ` #w)~}Fo޼񣇇nd[q(ݻ^LLP˖;2۶%n|B{b8޵+LLV߽{k`}p{11Fhv6^"#lSf {0w( ~%[9%7ji07'{hiCY(__?O'OH)Wl^ #Qǿn䓙I&qo?6{WFXKQu蛹&˛4!wG9%!ӄ 'N,zaocǎmt"b oV~><ݑiU]68% (aa&""ݻ YB/ʊ("<<"44,..Ϥ,v1 9zܾώw{t /^2dH {r쉳gqx6b>>#8Į֟2eJlJ9;;؜9sÇ8ЍͅNoI/]%!J֔s b73pڵzzz%O$J]~qqnKv)Nl3b9&رKH*JHHǏ{=N*9ڸ1\Ndz޽Oܿ#˗ctڥK=;gϞ=MSV7KD~RG}cy"l(u\re-::`FQk֬~UTԢ{IxqNV,@^r#?  OOWgU>}gz^^{,XKڶmkaam&&&HؠgxR ECCou; .\DdIJJBwWKK "I H<<Gak:kٰ^T33f[?? bbj))5x3׼;ve>>>~~~tԉw&[\ \$Z # BZMǦcq b͛7k)ԲbNZYY /[\WwedAϏ:2Ξu~[mZի@NN.==ݻwAٳ3qΝ;,[ C5 Ϝ93x`m~7hŋ0aИ߬D6=zLPW\mPy3r*ADr!PP }:Yfn6Ώ?;kܸ M2,Z$#334u6Gٻwϟ۵kš5kƍǻs®'V|C^!So߆d j@P&0Ȁo-V*VQ[ѼM˖-7o4,gQXёxko D5*d4اrVG^^^7nDCoffvm;;;J8|0jW (!IbL|_'&2_4H}JSSPx\z]_ J(VšJdPl?kdzAVVm-?Jieedɒׯ_6jܹsC s<l%m1>SObT܈jjjTTK#|Ux1U?O051xv=4hТEА<|ΥKrľ,,Ʉ|3m۶o߾s!!!oܮ^4w* ` A?FK$A[7f }¸q-Z]\\ƌ3sLmӎxdذaηb_xB?<=FgV偁Q]vos^}euIIŜxjJ`C#2nrϊ ^董:TxFdHbK~0lgf?n1u:IO=lN7"Dh% L=g|s[prrl!ң ^ Ȩ`ڠO5t*i=<88c綠X,_ 7E (5dY9 k/lsu+ڤic7u9]k "-XzG&u9tP n^׽ilck쮔vzB=`K}귨_Y=6:E ;F>H0ia5F8j(!%-{^k L ٵ;?gysK%8B*ЅБVP4ҙux1rYRǠNr\2Hޗ%KY'hH+ETTuv+uu;G;j5*%!%#%CP!/♪i"Hvįukk׶^3nqHǻ>|{vvOM I"S.\tU™o66m9c$^"'ڌʲ|)ǔF:*mR; 6ܾN;F`ol874!2K4j0::zDjovTծN1`}ukЋ" ŏ BESPU:??=uB]懼iغ|-!ߛwh~`ځA$Q[AGZk+Wr:=qޡWY=ϼ{1 Y蒱g L^DGZk-:z>:M?}qNnN}X9㉘_C4!2i!ox=ZkХCnVyҖ4F L V8sb2[lY?`}?;1VRAtQǠcCC4AU}K6$e?!\ [$Б֪xY9,n/{Mzm5^&/3S3XT %i4u—CSۮ/tisOEc:;7+/.`?[KuU!`qj#]džf$gfaj4!2[ @̓` [6 5e甅 76^fMmET{%#š\[ ;={aCڏۯsK6tiեF5;t*9.yꞩK:-QTV\z}隞k_wII"SF47d21a1JJK.Yuf}͍MǙ?W2-_j@4.;anŹ{hgMMLUTQT J`#i#uX?s}c lƦ͋/wqu $oTjHHTm~{z-lbd蒡7eu+7lK-Aq|%d:#mÁ nǟ߂ %yicxߔ}99sOutUm t%%|T$H ljy9'=v wM~mq2)Mil-WM?=E`#F _P%Nb}fisl1#+nqP^I}{# UHʪ;k˭UwV%&ߑ94QP%GyiHIK ޷v-C3ï_ VT BSi&L|h֡> /W [ 1 2 1 ] /Info 3 0 R /Root 2 0 R /Size 15 /ID [<4abcf54912d1a230b7e2ea45e57b1575>] >> stream xcb&F~ c$@g<򓉁P1f l$B~ endstream endobj startxref 24064 %%EOF car/inst/doc/embedding.R0000644000176000001440000000446614140314544014644 0ustar ripleyusers### R code from vignette source 'embedding.Rnw' ################################################### ### code chunk number 1: embedding.Rnw:11-16 ################################################### library(knitr) library(effects) library(car) render_sweave() options(width=80, digits=4, useFancyQuotes=FALSE, prompt=" ", continue=" ") ################################################### ### code chunk number 2: embedding.Rnw:38-40 ################################################### m2 <- lm(prestige ~ education, data=carData::Prestige) car::ncvTest(m2, ~ income) ################################################### ### code chunk number 3: embedding.Rnw:43-48 (eval = FALSE) ################################################### ## f3 <- function(meanmod, dta, varmod) { ## m3 <- lm(meanmod, dta) ## car::ncvTest(m3, varmod) ## } ## f3(meanmod=prestige ~ education, dta=carData::Prestige, varmod ~ income) ################################################### ### code chunk number 4: embedding.Rnw:57-67 ################################################### f4 <- function(meanmod, dta, varmod) { assign(".dta", dta, envir=.GlobalEnv) assign(".meanmod", meanmod, envir=.GlobalEnv) m1 <- lm(.meanmod, .dta) ans <- car::ncvTest(m1, varmod) remove(".dta", envir=.GlobalEnv) remove(".meanmod", envir=.GlobalEnv) ans } f4(prestige ~ education, carData::Prestige, ~income) ################################################### ### code chunk number 5: embedding.Rnw:74-82 (eval = FALSE) ################################################### ## fc <- function(dta, formula, terms) { ## if (!require("effects")) stop("effects package unavailable") ## print(m1 <- lm(formula, dta)) ## Effect(terms, m1) ## } ## form <- prestige ~ income*type + education ## terms <- c("income", "type") ## fc(carData::Duncan, form, terms) ################################################### ### code chunk number 6: embedding.Rnw:90-101 ################################################### fc.working <- function(dta, formula, terms) { if (!require("effects")) stop("effects package unavailable") assign(".dta", dta, env=.GlobalEnv) print(m1 <- lm(formula, .dta)) e1 <- Effect(terms, m1) remove(".dta", envir=.GlobalEnv) e1 } form <- prestige ~ income*type + education terms <- c("income", "type") fc.working(carData::Duncan, form, terms) car/inst/doc/embedding.pdf0000644000176000001440000014713014140314544015210 0ustar ripleyusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 2592 /Filter /FlateDecode /N 43 /First 327 >> stream xZ[s۶~?oMg:8c'#Q6Oe? (&JiG" owPF$ќ(A4C %F) $$nK n&PB; ](",r'N9DZ)a"Cϐ(n#J C%#(`,$PE@DhbDbab58 @jM rhP10ܤ!dnI1 DZ Ē0r%i-MP+I_%"ΣiG0`&΀}L1kr?*sc3޽~xa67N ੡e f^zA Av<`Qͫ@P!?yh;U/ЄrLϿ 2rL.w#S :* = 6wkH4%Ko}AUZi>`U ކ֧DnȪ"h߸-?q4Odk +8WKuuMu׵:W= ?_o?ܹEG'x%C%ԇV Th!8e]džibC i3eШX8˛: HD¢z$G"\'u05m 0# %ӳ^a䫫 Dk  խiĄHX Fk4؏qo?<p08FGO\XhƊ=}EB r~Z퓡#GWy*>@>gf``tQAl};+H[m9H7i'5e#ߡ59t`eOvy1}V2BWMT<]T:2Ku.xѬ"ydo0sd_~ϑ}0ѳOJ+HX:!qΓ> stream 2021-11-02T21:02:44+01:00 2021-11-02T21:02:44+01:00 TeX Untitled endstream endobj 46 0 obj << /Filter /FlateDecode /Length 5057 >> stream x\Is\q}r4ڗ ›DH:H>4A6 @s\ÝK-YÀ3cS%+/ọFjss݅MWq2ڻgvlfsu.wj29gj9^siZwoa,qnrWװ5sJ[{ Ai#1jMu}_P!k\"U^ ƧěAqnwhqF/c~$ q1 D鰡&q@U~<|ެCRZ 뾽=,HV7\maX;?(hKJh℁>1@bͷeqK` ~yzýF'N1pNP"VZAyI0;61T" \[X|4kKdPRN:(T87QJHH:CaHSiH/ 48 pj!t8 b@.&=4C* H Q9z$ֿ]R/Lbl:w |Є4!ƈMvIokz{vp!3*>@ˆhp)Մ^pA펥e\MZw<)NeC;R\SWkF R9іcxvVM'hܴUUpŨO ]h,4:;Y[BO'v =0}hէ˼DG`ptH "+!5m!rE%FÒb~Y+ Q 3Dn? wۉK7}B iNM:zfBBkD(tUM~,~t˺ |6š v2YQ=9"j(HO9Q6r#ŠO>a(qˆ6l=Ğ/C.L"5)3ZÀP *(&֓+זzgChÑi;"SlQl!SW*CYt;T+ oK(tC7zxS!$Z0`OexD6}XvFEu.fN"@|wqh93uPO4ヘ8!M=,tM^x}6"rRg"<7bgK@6@MDo:7YbyݑNj9TS,?kC9z|i3E9 v&aڞ.U+bDpBXLN}yO I LxH}5tt_TG 4gEapW7z<:x _22W9nfz-lj1ǂ8b6ۮtbp?B5:ę`:XD2]:(b#Ȋ#ޝUíwt0TnWflww=@erEQ#X qjI,'Ls`חɂ%|e(lbzURllхr;s0غ\fndIh .$nUӁ%0b~m}zX[jb< , Wt^8**cu}ϬB?sVK`O\$A!tO^".0trW:7x#>؂Ff|-RЋMujަCk/_nᠬf,2E}~;lv#ZI82]Ɖ{CyZ̻3NS"uG/D ~{)N~ bBS`<^7T !0\UzC:R*u7h"b&a ?%݁۠U ES^x*zSG:br+zrF XWFgb\fF1UkE=Ho~_%K Dhֽ2vtw,솻AAƬM?ř<MY eQrKbg=,bSc!_L9ϛQ<m$9]B,n,}X#)0 yC4Grtu^0دsuQ|L)tÙC*p(Jyx;Kj%'ya51htsA:wu9j]kZMk=.0n[FOov>, ы'}>qe|zK?[jO3BW?ų_7 s?ժ~5H}k%\¶Džώ?;f@+ɕKDžs84nqﻁIu]u‚^>ɨҔd:|Runo,]OfdžX6r.RUs)xA=lZp\!+n2[LEGNXbPTrk\,_ps/AXzNܹ()hbk. ,U,Y嚿Ế3_]]‚|P\WSH#=~]븻xW)+y E+ kspIS!XDZ5>ko3il]a4;Bc](*y9;l4u1bboZ# ݵt#~Z2% Oۭ][%URr%'ɍ2IsO:*ֹB*~:EO%5˓`F>==PӲbP3T䜧~|?(FHQ?c)Xމ"ʇEIsM;!GdE\0S&zxpEά B0E%_)aޑ; {T|C߻Iy]F6@D| ЕE>t=|3?2Y4~[.fAK0 u&g%Ш~wPEendstream endobj 47 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1857 >> stream xU}Pg%*RVv7=!T+z8E@ZGAX /g#@XAZٳgҗ?n7ӹnޙ=4E4- ~Z&Fe@oOn>2]̆.@|Ծq(Mg3L)Z_\RV``bNV+TFF2J/i:Ec4)iƌUrrrT}fr򕊜Vd$)"F6Nx\ed5(}&3ÿ,cJٞMEQ۩T GR8j#z-T$>/qOt8ݫkBV"Y޳nc䝌 <2q5^F !%nSOdYft3sV[Zngj8%`,`oDIW/vkte,q?/Є#/W G'DuTp -=NHlvHH$=}\ '#\x{tjkY5%:WuԖ7h +rWg$]03, `Xb84zc2oB1!tA7p9@6b>vzQS] KU}[McͥVkyg& ˦Znаa=#\|yBzVOmal(OsC|\;&*!vw''Y_b't=QuCO.WZ}[q}uѾχ\89Va=ZRbChtحa+oft|ˁi\Lj '#e>cL BU]628gLƜ]Ji.K1?B}f&20#7=%RNH^n3zZ},%VK!(Aٞ16kkqNU8FYIus]'}+Qlm|ȡa %ad) $ $໸` -GdʱO•rDt e߄Kt`m?;(CnK߸uB6*,3[̐7=HJ6NtOPi!J`0?Q ⤞Œ`+*tBԂ>8ĭZZr*'G*7nr9MvI#! 6"O)ѧGPQG/ୈr2猛:KVSl5mfgO^ ;%+"`ǡ]Jȶ~A3yQL@G~fʏu|SϚ/A+.d5ͤ[?AAzd`f%,Ez-\1c#U]ERqfװ7SsP_e-6}^p}|<>s)BDendstream endobj 48 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 949 >> stream xMmL[eǟKlD0Pm/0VŠRK[F{rKIfў2ZtPʋl&]Pe"eύ7&vO9s(= *1; ?HلX|RCV:\1 llD m%\Ykcv3۷3/Yf69Ivj*lcUwmr&{-3.`e*foa0C`^6YfEvpF;oLf*dDыh7*E{"CȂUi?,D  "RBk ʜ8 . Bg6͸)DۖYL]m;x x. P:&危׺pKMTk#4 +r ˼3b24XYPzy47}m>(kwC{;2xYsfrv@LUMEp*eɻK |Y0EOMGG"_ULMu0wͥ;|a> stream x]An@ E0$RMɢUd0"d'颋gSN8yLּnt_g cVVy7iYqxkr`۫RI8nsliNjetj'J MJ A#'ThZVJFjoUJ)( @#T0D8H|`p @kF qEa [%ЭN t)v+,Yz%PDM䍢("Bd1"fFEż6;evظ}h<~*/Πendstream endobj 50 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3065 >> stream xW TSg~1ȴ:;{t*b]PhEqA&$!jva Y ,)eNKQ]F:m3휙3̙9坼srI@ ED69{xB3cƇPЖ @ . i)g.[$$xy˂_$ Tqfdo&O/OU(dϝ\BfsRyKCsQl\)N ^-(#2{n&͔(iX.!bD*_ O۝)NNIM۔uV<|5ubJn[(ۈt4Z%ݱei jr)7"~fb+ay/Wጄl2ih2 <#@"opf[$n9[@N#uDţtѳ)> Q~?>D;_i tp[_^GtÑ椶!"b;v/cw HE}FW2JPp[e-K0F$S@+40q\r >46y mrWF_ǚ%n;dvL֫Ø\k耛ȑI.4Tu|eO_#Gh:}E^=$BOoK (U/ VNA{k jM^NQ1јQ(~jʺͅڕQ|La1׹:.vt19d4,:U|In5<׍z0Gst4ٿov=i X/ȯ M%/+OHc48\vj߼Vf$flhH|ɒ#yQN {~{64;aWQ\)g?cҐzUNvnvxŽSSκztUȧGar^!REFS^mDt&%2pZ},@4`(<Ȯ2ˡ⮒>8~za Hzb%:2[G2 ^!7*?-x$DS)ZJ46kZEP Z+4h lԔFDeY?ǚ27F>DE;vVk(btFyH(c_Jxuy ?E$O3{#®vu곷߬s9V<: )asZ띪ԭI{̆jk׼Ցl/b K06vmڝvVj(34Ͻlk !ߥueuꮚ^_58p]3=@݄Y|ؽWI2JyD?M_uWe0.wU}-1aw64蓵}qIvLܳ?M'0BkTGoO |{{qi {_CV21lt\5b>dL/XjASҒmxwr j3SǢV[ǜ&0b*1KuEW6Zk#0m0,k-qչGzϡ|$C"FĭNds.lރ o?rD1qqnfǰ'O7 zP|?Daseq)3:^ϓ(勻e7"jYяVi\͘KǻJ@yV]^ZWGelf gޯf_Z1XgM#͇XSq2&Y[ $I^N̕Z[Yn-cJKM` *w::JkZ+FEt>2^#dfnhVa$yt:x)_ٹ{A}C!ſKpg,L]ǹNµ: X + #IRLJmfIDzUtrl'O 0g1'/XdHD;x*h?@Df Uo{qoBnZN{5 {faRೃp5O/ ڃ-y.izu@}4jWc ٜ TzZ$<">=py wdwE@eGTendstream endobj 51 0 obj << /Filter /FlateDecode /Length 174 >> stream x3636U0P0Q54Q0P01WH1230!U`dlT032L,ɥPRTʥTɥTƥ\r;;66@\9y@-vv\. j yXw?#O4ulxpm?zĠ@endstream endobj 52 0 obj << /Filter /FlateDecode /Length 193 >> stream x3632W0P0Q0R06C.=Cɹ\ Ff`A#K  RN\ %E\@u\@E\N \.@3c݀}o]s~Nin^1PC[f:>ݫ#}AP`á6 R?|N푘J}02pz*rg;}endstream endobj 53 0 obj << /Filter /FlateDecode /Length 171 >> stream x]1 EwN HPdX%C1C2 t-zfp=FU@:d,9U 7t3.]Ȟs%N%`vBU[R5|wIdis0K 6f̕xk}7Vendstream endobj 54 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1407 >> stream xmSiPSW}^[+ע# "ŭŎH\X"`P *Qd-)D:XGP{G#Lܹw99~4%hfk 0K@hh7HgxNF$ŘC}Raҥ& +V-R, ZOWR48C:=yPDkR"`urѸ8.]XK^`˜jHQlWպ,u"B1(ĥc-;LZ&uƇktzC\|:i;EͦRԧT RRjBI<)ek^rzcҘlрP*BBF L`<(8HR޼VbjJe0\.^q Cf/?"F{/Wng[b/l=%'V*\8bòu(wo?YqJ<\r27]Ɓ1TtQ“sUb 0XxK CJ,q~[Cۍ-- bw?OXڝ^vC;vFb1>sj)Ctv;X{XޞUxU8t"==Jzogbl(Cm=_YQwܥo͑m;UGcEnMYvf[FT^B_f#}nw d8M&`i ;%_%Ąu|*Fs(EBNanF\PV< OʂvfkkoiiK3ᄗw} !tl9#UNYuV}v?DC.ڜ_I8Ib;p*I ^ dZhQ<m(˅|z37C28m6u[{MmSqsFX*[d!K,8=P齯곡$$D߲-+8"4 پ)GCcKg_1I >OOXVS^ >(7r:Z*̍',? y|:79=3 L@)f! 8 nqBٛG*sl]:XM<}pFH=DfTeD&߫4z4YY喽FTPC>k97Ŝ7le6d\W#D= GkXJx~(!qUI$H})`H)/kŻendstream endobj 55 0 obj << /Filter /FlateDecode /Length 405 >> stream x]n@{70n,Y8DQ( E>38E9~vgOϧiuNZԯ2֔.SQo~L_ҚRl/p7^K}>_6嵝rqxX8Eip ۧ(UV>J=)`"Q%`DUU`PG Ba%"A 5ip(78Bu +G1S:cZt[<]5a8忿2/UB6_endstream endobj 56 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 4149 >> stream xW TS׺>1sx* u*uh<2IB D2O Ch(RT[mw[[jmہ޻z{ŰVoKDl~_@L?w\;^`W#kHNFR5k2r|AjYSm]u\epBDu,eΚHalmnE/O۴gFz)9~ƒ N~ga14,k!ñ.vvAJN52wKN/>Lr]_;3)TJ+{Ô`!i\5g^V\^05L@Kѕ%e Ņ,!nR)h ; !0{J(G4'B.0SzK*v@ JԻV8"! dFlO^%_6g; }; # 4}K$s4 2UM!V2C~b M='bAZݬa#gF@ оut0K(G"(pVrAf^V'kL=[k[^rg^\3c_j[+x[`8Q,Gc{s-E>o$ DD)_Y{n #ZT\G>U;hc4+ǠTDS2z}0LzcppձZM\Bo}t3Kϛ0=9;mC23&)nV] 6ܩ8n⎻RɈIp.,M/! ?Pqε@!>M]%oXrقS*loiy%lq){۷P llP;VjwB c $bwtTݽ h%,NUGO6MFRsz_Q*~X ߯O}u tCǕ9d}jA:jMn8 -ɷk43!E,4Y%r-)v@tak2v5\diVRZxxlc䄝NP.=wÆ6I۸m)5 /^oW;*6 Cˉ,,+/Mo#*vҼ2gu{mZlۘ[7]CΫͱoUԯt`)kXgpe qJQTf+6jaTEBwël4nyT^ZHMKOK\3B\C369kAWd_Gf.%]\*.H竜M9L72OUgdQx<*R 몪ԕhm(icm̳K_ŐhY!zx*;'d)?dž]JYC&5Yw]p(r( eYy&-Q^H{#Seu"y|IJ#m&j8D[O= C$Ad}U#\we >A:o>o;r1 zu *u}JSdR'Mؗmt9"R\GXq8hhÃ'o1d<{d?b/S~2_@=Um4LyÞmǧodO/%?)dda5MdB*,3jR4i!/$Ž4hnw+ ѯ3;1;h2lsz2Bflsv!oxY8Y ( U}X3T@ BJ=t1Li9p!Ku_粲Lg&M!u-F>Dv 8Cγ2&'a (]?Y=YدO7sRl~ M@FD-dy^gd@:7ϳܾS_W}rAt6p7MїO0/ q~G*Ң]iJHTUҚf!DYÿ?)c|u:2\lѠY5t.ݜUad㮐؈҈zkQQq{|I 2g9DFOQV*J&1/=*9z eXpA3^Z+൨|_`i|\KhJMWu̟ (G | c% ܤa"\.uMp.trZ KaLO^&k/҈~g]TXtNj|4KDsvcHyp8բΝ'?aq`*aGM&CWEc8Y >6C{MN9YTq曕\vrvD{Jm2-V1رJ--8@pp p#f{I,_lz0$SQ̘J+B'DźEW>1<\!#>@\]]>0 Rgendstream endobj 57 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 556 >> stream xcd`ab`ddds T~H3a!conn? }O=D19(3=DA#YS\GR17(391O7$#57QOL-Tа())///K-/JQ(,PJ-N-*KMQp+QKMU;ML:)槤1000%&30381pB |?xU%}D?{A/myˌnE ,W"ȧ84Z~)rYj򻳳uϖ5}.ݫwffvg\^z7oVUv[Xxqkgo1ݚ|L޽̃k9/^{Rn5|X]Gb3~y#;肚)uݥMr-5Ufn[Ȝ];{z25X6k1~K{wpagrqTp~endstream endobj 58 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 325 >> stream xcd`ab`ddds T~H3a!Sk7s7넾G ~"ȘW_PYQ`hii`d``ZXX('gT*hdX뗗%i(gd(((%*&s JKR|SRYt^}י1y#no~\~r]O9V=׋翛}}5۟'Wgq>7<_s.wt3\Xpso/)nxendstream endobj 59 0 obj << /Filter /FlateDecode /Length 483 >> stream x]n@D{~@x75N"A(h0ErJbݷ=<=}^{{_:֗emvZ9[sx6llu߇z9~3ަ c݇6+y.M]ʟo\ǣckw,X]Ǔ\,ڳ,hG٩Xl-mلuŢr4i7>t÷>8'xVЬBc} A0o7 Yü! k7d xao5 yCA0/Oc)Zdžiߖ[魖jendstream endobj 60 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 5587 >> stream xXyXS׶?1sJz*h Vs-Lgg L$YId@PLkVۊ:}Z}{;s|s~k(A,Z~ 1<ۃ,b [ʇ6{cD0mAyE1IaIfNs,_/!D:y$9M0L"{ LjC?<)a$i}p|xgpҘhZ`M(&*V* ; GS5=:fQlxtĀIA!awxoyޝZK}@A a5ISBM-ʑMfp)JKAllGzucfs3x!NC`Hf ;b`wqj##e#쳅:aߛoR,ǖwC#Ϣ3jwV٥ʂH<;!iK஍*&QԴ+T]CǙbI.RkDG([]uF9QEҭڋUJf,E,lT`g9fm`]@F A Z4u`"{{ jK{o\fA4sdkjen,/53F , l^%͉0[ 5۟~jhG F?8g!! d ߭28'7f-޲ h޳wOqTPSZ+@V-]SQx{`< Mf4`q_@P<[T   Խ1e˟!K 0hȯSa-5" ko# w7>$\̌۷6#jklRiZЁm1.Y^ʂfݡG/2*E9͚b]PEQ/>\BI&Ƽ*%梛,Dc5 (< j +;iweqMu@* P%Ce245E6q« !ty)<'Q3:2#g[}qձ^! ZHA]h0-"E\*`S924#Y8~}Q J2J>%&֐s=1[繆)JUI$v!8O4TU?ғ2|Q%BB`ݣ[LРN4B^q?)rvg(`ɞ]rϰ:Hx)^TR2#C1f4Ԁe<ƙ8Z,PE9Ma7qOoT;#@&Vra2d%Z|Πb[3$!O|g}Bל9tbO3 Oáϭ-ͼjK*2bT ewZ|VHڤ1MݖjJ gDBYi IcFƮXhTW5[z#$i$ L?Hu3WMkiZXteыFZ.,;;%[5M~"y畒DZShuqӧ k0!B>;#7Ʒn*DCuܯ7Y@Tb K#~͂P3Y2AXR[Jj-Uk7TݰH o-L玩+5K#ȏYULn2;}V9`>2)sI=ڠHPy , MysNK I7,]@ʜ[h ƔX!IEtvk?sDyTRbYzĞs.@!4&*ޤlj0GpgGF7EEAAH䢧LFh4 rM,#N+h4tH:ϴw&c NB,&m?MSʒH4kW!MYay_Ih]fdPB3t-4#q^ cƽ<-cD8c'-m|@ϼ7G?Baį.dg(J.l [!Q VROURSG̠S~_0"? 7Gr0$Rџtl[Hl?4J;,*J "M耹lr_DjkXpOMk%j/ӷ.4}G G4- ҫZv HX+!==k󡘌,Y*|qXAi9$lkPء~Nj=|y2%,v9!LMꓚZB˖W0Of\>IF}sʹ)}ճr=8Mxkhϩ /~iwGRҳQ 3]gkcƬ}\Q83.r׹[wRѣjUe╁7jMqjyGOmb`!$^_V\w%&_%{ǟd aHMwHA !O&wlRK+-&] d2o =?(DN( Sձ䘘HWРjx.| 2&;K;֡[H" bȘF:!UE2H,<9X$Ϥ R1xSXΔӼ`#ZYFҭ\Yp'#|0,_{"%}>TrZ L7᧤ +w@lׄ)xŊ#J?GKV0kNh`Ne۟TŮ뿿01:w&)J]Z:R{T7\g,o;QH1J7ۗ*]8cLOyg[T|bdZ?K~w΀JB K;vTZUhW 7$ysfhwBh rK%y?ak{xbIMj+Hd}h!FZ' -S ?AO`W¶V-4J!kw - dhd끆|AdyN\$Ig,xOK'&Fss|rРć6sADn^<Ӆzɘ{ -@k}Y4HQ/pJH#[[>ol-qJy 0ᦴꚚO7tOC`g/*M(7wcRՀٞظ֊"NUUbzrr&+/'o١[ȣWyݸjuqxλ6`Q0- ߋ {?tﲿ g q#fσ wFs.'tIF触 y[l|lLY܃OFC1B3OT a5eU If>Dr5{[jDtd&E9)\bү Eq*g!߻Vx}9##a[fzvݔd TJ|q5"d,- |w\Az~i%bנ?7w ?%:/:=u|8sV`OIg+PUxedT ;$޶l2~{i߂OD-fcZcuW { G뫯 zVШ^G(6țEC~vPmu,2y+TW٢m ! Z% )"I'AfYFWѻ0"D[xyU\"S-$bD+԰,o SHbyU0$鐤zcjfsB%sK{6/Z#3by3fq8}zƧË+Noy.sO?C?*;%SV`&hģQ}f7Ev7<ϋ{7j,QXKlyKި*l4ǗKS2 Io;##D0 ے|?,`'#NYhfsImV^շu+m!yGOIDjf>1eOe3O<`YT PB_ q }ðg (h1#endstream endobj 61 0 obj << /Filter /FlateDecode /Length 497 >> stream x]An0D>n`$7MɢAD^Dgwft[7?>}Z.nsۭ/˴6^.pxt>a 럏uw> stream xX TS׺>!prT ;{o VpQ*B @d3̐ J^JUgN }{eV{f@ q\`w7Ma0+ï,Y7aea$B(HSH"Ҡ@o/tt\6~s4ho,?WBHVdN aQ%ҀUo͵=1Ke}v7k$,"Z/w4\&bm:i,5Fo{n [9s_p ,]щ '> $>$ b Il% /b;B!vkub=@nbb#DˈC!b"1" 11!hb aCvTb0'nA> wnT?EWٔv̤1Ac;ghjWix_MxcBY&d>aRxVZ f ɞ)k \ CSoM[Q^ƅаzT=>Mգ)g}`)>3$3XO488oyJc+wPl,ů/ 3j3lVX\05}Nw׮ݼuajg ~Yrw TH?Ψ3:Aܸ[QNnx#0=jBI2fSrCÒ_`6w;9q͈jG:q1,=\+8A%}+/,m<üXr+@E?#oEh+~ڤ.  CJ/o*2rf@M`K`X,8Is'"vc>pԛ'gOW@D4{OxC:)(,UY^o4Nr=ƣ7 _9ʕʯh= fc8nŃS=f9ǒmElhh1rf=֊ 6"?~T3Ïl>FƢFr^QK f` gLnglA /=LVTQ5ڊm˷oTld_ ȑ7{L#(#ˍE"%jfD$HtȮBm}fBKr+x4IR?.r>c!3N$v*d|$EgLҐ^pƢؑP3{rGQST{USCey^xLnJI\*A("zMBsyÞ>p)ZS#j(EJy9),nng:r ז7ud10+K]UkYI.O1g+n?1SpJlP>E@7JAOsG)Uǖ@>)G1 hqo'/F*+V~Aa+.V =7A v2:YZ=Rm_@jCjc43@ԠBTJ)qH{\f OLZB.gD-]sS iOP2XET/~6~:X{J kVxEY9:bOE#zY"| w5(.U3D&iQ9u$F:wk~=M QftsPHqWS_ŞiX0g< OZ7-W}fߓn\Ɍ{7t E')s"4ēdi 4BSKr\~hdƟLD H4:e7@- BQS939 :#qT6zd ZVu.t:zEoR+^6>BQ'ʪ 'ɻ_f&h_PEwP;v/f4i 3c՚TmpۤL'5/N  T~GXb٨8Ղ6 #9/cm۳~˰uXr[6& [}Ogg?t6/va >"B[}Mq64+?PADU*i:۲5i&h7_XQ֮^2<c")>9:l* ,%:{Pf _Cqz{P[QR( %%i(f`B\}쳪V-[WQzh=3g0LȽ 'hW` lARvaGɽ|=_OMǟGl{QD2gRS7FH$IMtccMM#[wAݘ-|B3a/ېJS vvV䗵1GWy[Azw5RhD*J©ʷĿ;u&-Di YƯ}k7omW,p(j2i86PGXD?LG8ʷpu.PYt\?N1X^eΐ̈́iCbs`7eMU5B+K݌W heA曔K\ x9I˺T;Gy=|Z/f)|(?r0g5?J# Scݠ+CC*|)a[컩{Ͳ=2c6gg0Pyп5!T:Q\73Sn:n#BL?=:z81(D⮾Γž.;oEa~ $*Q{!(Lm)xݸCpr.iCv(0 ϥ:'(ſ~%>UoyqqJ\E nC`~WQ\7tmd8ރmqwba˝- 1KD#Qm%M(S2YXx rC3cOsPHIGJ*%_^{HíW`╛Z-F/8>hoC|6*D2HJ+k,mIAirQ^OZ]WdWڂQprxkv$+"5JEv284 15! 2PQ&RGj\Q]2 nkCmEMJl]0cU19}W|bƁLE:S֟>3O|BmYP{C99GKy$yyV~+!;C#[Ե,׽iBD" BJY)NU&1ZA(NQ)(/bi|i<l69x#'8ka*9 n0f ó۽73,7;[69]U|2+,Uʢ!~3KFwΕ]OJKOKe$*@RPP*$ɕHAŗW0͍e *L.M,MF PU KhM7@-<trlSE- a`$w F+%ٖZH(IS)d -0zXwm 9;:ES&kWHZwih+e%<3\kp<ϰ3#6T(Ƀ.KڪlTF⫚LPϯA(:6 Oix avq?}Ww/|~Jp ]/ae+> stream x]n@D{~@q Hh0ErNbx;oqwxzy~Y[{_˯zke~Km/uY㩝r$mܚӷqg-?󝿏oGrT߷}\_ks|u]]Ǔx.I]cvcvG%a.bNE5!9FR1b]$쳋 !9FRęs&L4g_^]AE ='}{yPf0/ 3C>Lx.4."ǀb+1ghϠ+ / 3gE8‚!M(d 6aQ&l2 ڄBFAQ(h6 mF!M(dV)xN]^]ogі}͏ɏEdY]7u/:aiendstream endobj 64 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 4221 >> stream xXiXS׺1dQ[QժuVq!!)$$2$$L PA#ċ&b31xBl%KbxXAL'VYD,XK0D81HDb1A&! G߈V"v/vU 8E&ZD g­? xs =12"i;(aЁApp 4D:䧡ˇ;{X>p;q1W\X'Y =,B,`#&} 0ˁ `r1/InC;B"gۛϜ;RcQb,mV0l)h@CW~p  %Wv˛ڼl±ӃA$& .9C{%mGðEצmbs| %O :שjf Οʝw|Pn]3f=r s~rC 9B !g7 'p Ha,# 3B#d_fxph@՘oҝvl)3h0 ǔoճG]l*Jl fٌH'f~{uh+5 Vz敀UINxp?᳤Q/ZJ9VGy``Q "Aϒ0^>t/QuZWPد`|G<o!( %a6ʮqg rQ-:E mNtn4ims`{|~W`JjUW_V*YX̨_'„(Vrd DI\m ^A/mX<DP| R2b;XϜ{x(_=7lWd]`^' y˔!71FzqvۡBUJyT83Ox_bU tWV;l buHec=ceL?u;du1z]F>w[q7p^ϗ?"lI}5A3I! zp`Z "^ @5r%XbD(-*tـRJ$1JncE"Z>YS(OٵwV<5|_W#1'dAc,^Եf{鶯'qVVfٙ5 :x9[ RT=/[NyLUeu`Iher')U,©>ًF96h 6 I@á$|. }gA$MNA׼:)v1= DA\]0< ]Ca.ELr!laݪV1@x{*4(7J]l'2P/4cj;ìcxi@K:+NPocyсpXd.alj'[aZ6@O\yyc@ݽ Ǿ$7=H9ύ.э^QT$ZZ4塙FCx9G8xWdŝs$1yՊȞ=jqf#{*)d5Yܷ|=Y`@,/a{M GCއ߅&/=w.z1nVI=4Urj@GFь>=cmBχP}3k [͸P%O@ZAcrSF=v`" vZ1`n {}Ѧ=I*5<^-V,sYz/gsc[]2ާAGGr0T$s4vwo2 Ry;Ӣ7h,)+_a]lۡ>k+,N^IB*:hya&O&[}EHoq)\ ks]@(&DQ P? "BQ&zNSUb. ;z/L"h4P ZoШ4pUl(vKZ AQhAT,@a+u?G7(52ȍR[Lf(;B%sxմ5UV#_j+(oM}[mS[q]. y|/Hq=ojpuE61&+~5G(jsb#Ah Y8FcXCYiT#a<Ã&ZvB5 RVyNuNJIOU|6v~ }|8޾LJS҄BP{{(/߃?<ue '!k}(}8>[SUY][vT*r.~'g=,.UZIE᎕"ƴA0 Mm&`]fq.ǠV2 \//ݣه&(U*p]5{ϰ:*B&RqPe I^4| f܁xݼߦ=1 fߖe̗ Ouw0_%:5>7mKm+nhkkˁ9mrxofnBr&O,4F\0N #xp |ڸ봣X+U3rt)(:Y]I%9R9(*R8Ov4jV)뤵ݶkZ} @pp9@",@/&9h Ipei3ؒQ(I@ DhmALr=Ylq>c\Tly?bġj DC; ۚ,nw0O:]= 㷡 Omyx+l*L!ӔJ%JU I<#]xS5R+p`[Z _VITP?0@f@X(" ΋endstream endobj 65 0 obj << /Filter /FlateDecode /Length 169 >> stream x3232T0P0Q54T02U06SH123!U`d`T012L,ɥPRTʥTɥTƥ`ȥ 45KM jw)+jtQP[$.4oi_0p 8\=p:endstream endobj 66 0 obj << /Filter /FlateDecode /Length 179 >> stream x3631Q0P0U0R02S02VH1230!U`d`T022L(rU()*Mr{q;8+)h\nn@n.P9?47ΎEAmpm]/}MSLJ:l:|[> stream x]1 EwN HPdX%C!2 t-zfpFDj,ۂ:lԜj Gt7)].2KF9 HWU3F@%0ɥ(jڋMiLI@`ܙ+Xk{0Vendstream endobj 68 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2419 >> stream x Pg{hn wM`D&%QQ@ 8s8}Fs5rzY%Aݘf-n@jJ5S_ GB 8l XNs!K- sW\{*j=P(ԝ EJN*YN+ӈ}b}_\,_,PZ!U'JF&UH48T h>/4䗖.MOO_"Q[R]XIIi8ZR#,QHؖo*ErFj%AQ_SӤI!pb1Al!$D(F;5DXK#o+b31xOH$w;"8DZ{FRjG isS.[8wlUǑb2g>Q{BH TT6ldN8 Ӯڨ0Ȣ7or={8kn7etM ӡX=`{`)$>`p6Ēګ~[w N1o=2 g_&!"a*Irl6hoܼn"Q pgDwy,5wN } %q}J,TpKIlv#v<';-CAVFiN<;DsV1Gp-X<;F74 Jx' u-;wjY8;?bC$ ݈WZXZ~ٛdƔ|#C;\R>]tj(_sܢÂQT0J" 5@UV23}I^J@(X>e=h+~/{8AXGǥD.]y.)-1f YNeBnmյF`̰bػ#?Yl~ihU1Mpj=wh T2|t@5ۆZa&fnڰ/$,YDGb j;qc ڣ ! vA3XXמuPC. +RwؾXr|ŧNzCaZ-SLQ/\ dVzҌH 僱O2FE:teèi0TyhΌXm$;}U(ae K ŸӨo݆V;JR}RyFy)^huf Ҷj褭i,ytêr>yn7:v[;d_#%Rk NnNZM]Wu=1g' ^RS\Szy!#-hth{YG{~_w6L>2߷/' g$O&ˆ¯a0ba9+e0 *ϩ`1֠Cic oe~­SU>kJo060->0us=ւ>-Zmb/c"O~Vٽ~/fŐbAm*>@P  6e]%jO 'S %6(fKsb;&cV,DD9(VE@$/SwQh4UT/jn8̧ ź"ȤYMumY=%)q7>k־"3$1-֌c g(ḒѤ̛ h k3Z[6kMRR @WEiCHEAC憋Icb M2%+ԩD#\i/vpSNMG2E$L;- ÛEԵB,Z3Gn(6g9l~]W$:~Lǫw6RjdJs ?+Im?_)`doXs˽%٣{mP^ɪr'@vCl!SŸsC*S^Q^i=y5K{|;&Yɣ|sxzɹIY`DA2(!f|Ja} nh#ù>p%oe[Ocg ?h>7=$dNnlem?#l[;X4r2y[ȵYԺua7f/j{mhKNgΫ,4~zO?+15E0Ք1nif.XRM\g1./:[ Ōrendstream endobj 69 0 obj << /Filter /FlateDecode /Length 3462 >> stream x\[o\ ~7#ܼ9=KAؗ>Y-^R:G4ϝep 4{y[׹iqϭPغabѢ^@xٿڛҤjF]2ֹu[orar#rkEfdR' rkɰۅS1fvJL{ʹʬ"0iQ a璙͙`-1 HhoiI_6OŜ_3zL0\gu]ym8~YEѺs `oF8AeZ+8ʭn@¢ V~_~ XM'bTc\A0bh͸%NnwЏG}TߜԲַÃyIAߩh50Zy7[\CF9[pwN^8{k=!-ރeq頵b,%{!kǜHΙ0N[\Feк~U`*Ӝ<, [>guO#[ Ћ<_J#p8m2+Z>\؀E@qD^vXۀFI^,%/{ $/|rN葜лt$x40rEK <N '%{z01(0  Bʯ%2tmGyӲ-@e]Y$}E8< X8XL.F:c]9A Y]x0ylc)p6;p[; ::aj)L"BO.kgQyM:(yVjEw5eHq:ۘ2(`1j! Hi+dP97Ip(A80EV%2QƓW|D#BH@Nxg+U9" [)0yo1Ȣ]]w<z3PtaZ ڦ"aK16) op= 1=j]A[ MlOie WEo*WIn"F+ͱvQ(9)fhbꈪVbyUι0Ui[օRu&_ !Д~5 =}ҴOl'/ڐ:}h.BaZI+$*~WObͧ?J˭?2Ϥ#2V g^MVώ/Hb%$'6=;;carț:}x* ?dXsWdb%V\ Rd /{Sawc1S^Ԋ6ss ѿ0S-j FZn၃mw[s1$OܔQþcUl N7ʚYX9ϖ,bo3;%r7)ܒ^EO;3[rZȯX^5xL"GiJ&ӝ<+(gPr"%8*18:^*s&¿ mrXG%' !كN1U''VwO{Ď]/t<8JE]aq$2/$/γ-c>{i쐔:لnUϚD+Z /{-c~Ip|}b)1B5T?7Dl]1D祙 ~=\!x?Fp ؜ĩ=Ǚ8Ԥ&H]F$< &bx?,aMM|p@ݹǖMx ٱFxNydN=:]3?|C::̬ smEd0 .g D!tq8^mI2)OёcQE$h! ~#Fqa@;dLlBH%Й֪ ?OAt?b6Gy jS*9VM{"@B8dirxyM]Rְ Jt(2Kz lR k /jɈ1[Luh0K oFch ODeK1zX` Dtl1g;Nk]ތc~KSpg543i Nz<%%U+p: Ʃ^>Q S[:$b+{;$tu>MFoRrCRx2Ol7}_"8?t3oS'V AAo\`ғ2f$}R%&%9)#Z03 =XS\zpaPD^V/FhpQ)˛EDOy/ne)CҭOdnj^F5nP ዉ+Dx|+TR|i" }P~M<՟aDay2I|<GhUS;h˝8o^g[A! rh?.*ծKZ@Zܸ+J+i[[d <xMM'_ inz-niŚ0uk4j&,Qڼk<+X&oX#Y&cp}l$B'675hI3JWX_fӵ 6\K:[PkS_?rHs^Wک更vtw_dt*ds6y!ǦQ1~zKcg>VRyXݞx~k6K"({TM$ѲBbh' ֆѱ-jtKѠsV/ 0 ǫeNV8s}2o@c;g͡4ŝpćb\,{ո;W>wd[F%nBxCRk6-69a+PO_s|*e^FR )2GWj;2+F,?Zr}\'DJ1Ox&K^+碟n!nE<4ij:ΧL-3q}v|So$~po?k^rendstream endobj 70 0 obj << /Filter /FlateDecode /Length 150 >> stream x313T0P04W0#S#C.=C(ɹ\ `1#S a"rN\ %E\ \@U\N \.@3c݀}o]s~Nin^ڎzqu ,#endstream endobj 71 0 obj << /Filter /FlateDecode /Length 159 >> stream x]O10 PBVUAp$6|/`,@L4[ub,,O\r)x@w|^ڼ :MWHAL3O*g fhpB h. X/ S;endstream endobj 72 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2352 >> stream xVkPSg>1e+4f힓ZׅVmmk-eAB"  NoB ׄHE,7R@K[TWl3;{_{;|?wy,,jbV&d>寛XVZ("lX5X԰e߇Y,Y>I&)( {%E"TI 桌!+)j+Q({}zPRMV^d~HQ?\TQT^UTF&US"=t}$$JEQ9?EVXT.0l]T$/PT $Kat,Ď`Gd9 bLX`eVfMvQQvNgze._\zWQAYW"?cLJ,ZV!1ڇ-P@H6ub7Ne09Fe2] TYfwD8րա Lz/h Xx,Q-J:]@uvO~p {^UJ>F]@jDz?;5`9e"(Eo s OޛA3Qg *7Hi汼c" =1;r!kk5Bnu#hKbw ( Pt=Pf^nw=qm|#D+O?C8i\.u4,WD -w KQB+^LX4^}pΚCw'ë1hlnt4Ch6x"ƍWl>,5ȺrA1u&c{]hF9y91'_]5k=ы=gW\'r`3ۢ vm[ ^b_}}P6wB7#XoSe󂊸`}*6/u]x&"KYc{W]7{uBlõ=ӫ?E} O^Uta!/L_g&mNK=}a vpjr]#B蝜Z-&h'or1ɤ5/{?.|+:PDKO\v~KGv9ko9{j^JYIc X5Yy饹Dq+3 j4 "OBo.tE":>:'gE^zJM+ 4^Mo7J>]c3%8eo&r+!<\=X0Kh-?>Ng݃_l.AdpPfj&: JZz٬+NkNBdhkfU5vxp)kV5KA f0/,<1<,!QHӾg*/lL'oyۜ2Y:HwGG']dc;v iAz2€pL-/_U U2 N@]ЁN֔ kn}q|b61Sl;:%5qw>:^I|Yf_\s^/~r胔8u?3#k2xibכvQdLDR`u..X: ;7\׀b`R"V< fJS3018D#jYnz 7|3F ԳLp.9r7hGytن]Atp75ڣ9Q6׫3HmI JqB++InMisx"?D7q1`[]%VAf"ǻ?^ ^c5:1= /8r9F̈́6Y);mDOR^Qf_| 륖z a wK?}MϗR/ TÎS'yP=ՋkQkW֮Űendstream endobj 73 0 obj << /Filter /FlateDecode /Length 2284 >> stream xZKs蒡~"˩\]ɥDRr~tlkT) ~~\ 5l&dz73UF?Gg,g_8O"yPseH1ͽ B7_^5%V5Ji \s\óe mN*u\Mj$,*&%k ^g3A%&$).%];l԰Š="f4#BWy[Ϊ/{HG2z)Mʘ'X5OwSV(5LƃJڃN:5 PK-+TQ)4PVJjWȝv)vJJsrhoM0x"T4+hV(`L'£OGŨ:,4!= H ݣ> ޫzTJL4E[4,`=˛J]3NsQjPEc[Mfl3X&+^L0ob%趏y>2YNIn;|p5 c),tR'>W)/=Ks(dHa1cFȭ״1e\ð#ňo\-lPVtk@±[ '[|1: ,ꖁP)S F P%E$̋If_)C,E7T&6wύqLkBI.FTk/r&R#d​@}wgfO T8+ Lv@}.:2Gћv-j%67׺F!asfjYU-1ȶn'qFbE@r N .Q ܆P&˾Xu2,P}e9aq1JMwTiVa='gCa+.;Wa9"Ua#'l`DD dFX.|5 k8S.)@oL!z=0aicpJr) <'3ޯQEU y~*]&YbU^,. :eIcFE+* mW:7 6+i͘P*CkATX]ݻM4W(+%/ZaZr`*=`>Bd!;TJ3l𱾕)ʈ\4,c2#׶.KEڇA%hxwc\P ߖG"(?#^`Q0;-jˬFƇKQj_Pm05 xנ*:Ft1 s \b_*hLpY# Q e(cC7+ nkdK4 <ͧ }_>mL*cB5]=gA4@46a/d̆14ڹ\ ηuBX˦2w)eØqΏ0Z5yFbC}P9Hdw<2;)b{,Q;J}v\z#xC0Lr/s% X!?+5No_ =uI*H0Gr٣W1mrY]46XNpiRbI?xԮ-UsYK]KbBssE O&x~P?2vx>gM_?f#Cfkv! C1' +3&?̼Xξ_ependstream endobj 74 0 obj << /Filter /FlateDecode /Length 159 >> stream x]O10 * 0~ 8ʀ0%!tpw'0^G#8|QcYZ`ٲcay⢼M2䳽M}diZB g]U1 R L8/h0O%ES$qEsT2~Χ_S9endstream endobj 75 0 obj << /Type /XRef /Length 125 /Filter /FlateDecode /DecodeParms << /Columns 4 /Predictor 12 >> /W [ 1 2 1 ] /Info 3 0 R /Root 2 0 R /Size 76 /ID [<3b0d636438ad9d9b1298753779b89767>] >> stream xcb&F~ c^טX&$8f > $xAo D|l7] !by BHX @, !p# "@!uHq@ DBT1 endstream endobj startxref 52427 %%EOF car/inst/doc/embedding.Rnw0000644000176000001440000001221314140261762015201 0ustar ripleyusers\documentclass{article} \usepackage{url,Sweave} %\VignetteIndexEntry{Using car functions inside user functions} \newcommand{\R}{{\normalfont\textsf{R}}{}} \newcommand{\car}{\texttt{car}} \newcommand{\effects}{\texttt{effects}} \newcommand{\code}[1]{\texttt{#1}} \usepackage[authoryear,round]{natbib} \bibliographystyle{plainnat} <>= library(knitr) library(effects) library(car) render_sweave() options(width=80, digits=4, useFancyQuotes=FALSE, prompt=" ", continue=" ") @ \title{Using \car{} and \code{effects} Functions in Other Functions} \author{John Fox\footnote{Department of Sociology, McMaster University} \&{} Sanford Weisberg\footnote{ School of Statistics, University of Minnesota}} \date{\today} \SweaveOpts{concordance=TRUE} \begin{document} \maketitle \begin{abstract} The \car{} package \citep{FoxWeisberg19} provides many functions that are applied to a fitted regression model, perform additional calculations on the model or possibly compute a different model, and then return values and graphs. In some cases, users may wish to write functions that call functions in \car{} for a particular purpose. Because of the scoping rules used in \R{}, several functions in \car{} that work when called from the command prompt may fail when called inside another function. We discuss how users can modify their programs to avoid this problem. \end{abstract} Some users of the \code{car} and \code{effects} package have found it convenient to write their own functions that call the functions in \code{car} or \code{effects}. While this will generally occur as expected, in some instances calls to \code{car} or \code{effects} functions will fail because the results of an input fitted model may not be available inside a user-written function. This brief note describes how this problem can be solved. For an illustration of the problem, the function \code{car::ncvTest} \citep[Sec.~8.5.1]{FoxWeisberg19} computes tests for non-constant variance in linear models as a function of the mean, the default, or any other linear function of regressors, even for regressors not part of the mean function. For example, <<>>= m2 <- lm(prestige ~ education, data=carData::Prestige) car::ncvTest(m2, ~ income) @ This fits \texttt{prestige} as a linear function of \texttt{education}, and tests for nonconstant variance as a function of \texttt{income}, another regressor in the data set \texttt{Prestige}. Embedding this in a function fails: <>= f3 <- function(meanmod, dta, varmod) { m3 <- lm(meanmod, dta) car::ncvTest(m3, varmod) } f3(meanmod=prestige ~ education, dta=carData::Prestige, varmod ~ income) @ \begin{Schunk} \begin{Soutput} Error in eval(data, envir = environment(formula(model))) : object 'dta' not found \end{Soutput} \end{Schunk} The arguments \code{dta} and \code{meanmod} are defined in the environment of the function, but the call to \code{lm} looks for them in the global environment, and they are therefore invisible when \code{lm} is called. A solution is to copy \code{dta} to the global environment. <<>>= f4 <- function(meanmod, dta, varmod) { assign(".dta", dta, envir=.GlobalEnv) assign(".meanmod", meanmod, envir=.GlobalEnv) m1 <- lm(.meanmod, .dta) ans <- car::ncvTest(m1, varmod) remove(".dta", envir=.GlobalEnv) remove(".meanmod", envir=.GlobalEnv) ans } f4(prestige ~ education, carData::Prestige, ~income) @ The \code{assign} function copies the \code{dta} and \code{meanmod} arguments to the global environment where \code{ncvTest} will be evaluated, and the \code{remove} function removes them before exiting the function. This is an inherently problematic strategy, because an object assigned in the global environment will replace an existing object of the same name. Consequently we renamed the \code{dta} argument \code{.dta}, with an initial period, but this is not a \emph{guarantee} that there was no preexisting object with this name. The functions \code{effects::Effect} and \code{effects::predictorEffect} may fail similarly when embedded in user-written functions because of scoping. Assigning arguments to the global environment as illustrated with the \code{car::ncvTest} function can again be applied. The following function will fail: <>= fc <- function(dta, formula, terms) { if (!require("effects")) stop("effects package unavailable") print(m1 <- lm(formula, dta)) Effect(terms, m1) } form <- prestige ~ income*type + education terms <- c("income", "type") fc(carData::Duncan, form, terms) @ \begin{Schunk} \begin{Soutput} Error in is.data.frame(data) : object 'dta' not found \end{Soutput} \end{Schunk} Assigning \code{.dta} to the global environment solves the problem: <<>>= fc.working <- function(dta, formula, terms) { if (!require("effects")) stop("effects package unavailable") assign(".dta", dta, env=.GlobalEnv) print(m1 <- lm(formula, .dta)) e1 <- Effect(terms, m1) remove(".dta", envir=.GlobalEnv) e1 } form <- prestige ~ income*type + education terms <- c("income", "type") fc.working(carData::Duncan, form, terms) @ Assigning \code{formula} to the global environment is not necessary here because it is used by \code{lm} but not by \code{Effect}. \bibliography{embedding} \end{document} car/inst/CITATION0000644000176000001440000000124414140261763013166 0ustar ripleyuserscitHeader("To cite the car package in publications use:") citEntry(entry = "Book", title = "An {R} Companion to Applied Regression", edition = "Third", author = personList(as.person("John Fox"), as.person("Sanford Weisberg")), year = "2019", publisher = "Sage", address = "Thousand Oaks {CA}", url = "https://socialsciences.mcmaster.ca/jfox/Books/Companion/", textVersion = paste("John Fox and Sanford Weisberg (2019).", "An {R} Companion to Applied Regression, Third Edition.", "Thousand Oaks CA: Sage.", "URL: https://socialsciences.mcmaster.ca/jfox/Books/Companion/") )