plotmo/0000755000176200001440000000000014567113416011574 5ustar liggesusersplotmo/NAMESPACE0000644000176200001440000001125214567064051013014 0ustar liggesusersimportFrom(plotrix, thigmophobe.labels) importFrom(Formula, Formula) export(plotmo) export(plotres) export(plot_gbm) export(plot_glmnet) # by convention, the prefix "plotmo_" is for # standard functions and "plotmo." is for methods # (but check.index is a historical name) export(check.index) export(plotmo.convert.na.nresponse) export(plotmo.pairs) export(plotmo.pint) export(plotmo.predict) export(plotmo.prolog) export(plotmo.residtype) export(plotmo.singles) export(plotmo.type) export(plotmo.x) export(plotmo.y) export(plotmo.y.default) export(plotmo_cum) export(plotmo_fitted) export(plotmo_nresponse) export(plotmo_predict) export(plotmo_prolog) export(plotmo_resplevs) export(plotmo_response) export(plotmo_rinfo) export(plotmo_rsq) export(plotmo_standardizescale) export(plotmo_type) export(plotmo_y) S3method(plotmo.convert.na.nresponse, default) S3method(plotmo.convert.na.nresponse, rq) S3method(plotmo.convert.na.nresponse, rqs) S3method(plotmo.pairs, C5.0) S3method(plotmo.pairs, default) S3method(plotmo.pairs, gbm) S3method(plotmo.pairs, GBMFit) S3method(plotmo.pairs, gpe) S3method(plotmo.pairs, parties) S3method(plotmo.pairs, party_plotmo) S3method(plotmo.pairs, pre) S3method(plotmo.pairs, randomForest) S3method(plotmo.pairs, rpart) S3method(plotmo.pairs, train) S3method(plotmo.pairs, WrappedModel) S3method(plotmo.pint, default) S3method(plotmo.pint, earth) S3method(plotmo.pint, Gam) S3method(plotmo.pint, gam) S3method(plotmo.pint, glm) S3method(plotmo.pint, lm) S3method(plotmo.pint, quantregForest) S3method(plotmo.pint, rq) S3method(plotmo.pint, rqs) S3method(plotmo.predict, bagging) S3method(plotmo.predict, biglm) S3method(plotmo.predict, boosting) S3method(plotmo.predict, bruto) S3method(plotmo.predict, clm) S3method(plotmo.predict, cosso) S3method(plotmo.predict, cv.glmnet) S3method(plotmo.predict, default) S3method(plotmo.predict, defaultm) S3method(plotmo.predict, gbm) S3method(plotmo.predict, GBMFit) S3method(plotmo.predict, glmnet) S3method(plotmo.predict, glmnet.formula) S3method(plotmo.predict, lars) S3method(plotmo.predict, lda) S3method(plotmo.predict, list) S3method(plotmo.predict, mvr) S3method(plotmo.predict, nn) S3method(plotmo.predict, party_plotmo) S3method(plotmo.predict, qda) S3method(plotmo.predict, quantregForest) S3method(plotmo.predict, rpart) S3method(plotmo.predict, rq) S3method(plotmo.predict, rqs) S3method(plotmo.predict, svm) S3method(plotmo.predict, WrappedModel) S3method(plotmo.prolog, C5.0) S3method(plotmo.prolog, cv.glmnet) S3method(plotmo.prolog, default) S3method(plotmo.prolog, gbm) S3method(plotmo.prolog, GBMFit) S3method(plotmo.prolog, glmnet) S3method(plotmo.prolog, model_fit) S3method(plotmo.prolog, parties) S3method(plotmo.prolog, party) S3method(plotmo.prolog, pre) S3method(plotmo.prolog, train) S3method(plotmo.prolog, WrappedModel) S3method(plotmo.prolog, xgb.Booster) S3method(plotmo.residtype, default) S3method(plotmo.residtype, rpart) S3method(plotmo.residtype, train) S3method(plotmo.singles, C5.0) S3method(plotmo.singles, cv.glmnet) S3method(plotmo.singles, default) S3method(plotmo.singles, gbm) S3method(plotmo.singles, GBMFit) S3method(plotmo.singles, glmnet) S3method(plotmo.singles, parties) S3method(plotmo.singles, party_plotmo) S3method(plotmo.singles, pre) S3method(plotmo.singles, randomForest) S3method(plotmo.singles, rpart) S3method(plotmo.singles, train) S3method(plotmo.singles, WrappedModel) S3method(plotmo.type, bruto) S3method(plotmo.type, clm) S3method(plotmo.type, cosso) S3method(plotmo.type, default) S3method(plotmo.type, fda) S3method(plotmo.type, knn3) S3method(plotmo.type, lars) S3method(plotmo.type, lda) S3method(plotmo.type, nnet) S3method(plotmo.type, qda) S3method(plotmo.type, rpart) S3method(plotmo.type, train) S3method(plotmo.type, tree) S3method(plotmo.type, varmod) S3method(plotmo.x, default) S3method(plotmo.x, gbm) S3method(plotmo.x, GBMFit) S3method(plotmo.x, mars) S3method(plotmo.x, varmod) S3method(plotmo.y, default) S3method(plotmo.y, gbm) S3method(plotmo.y, GBMFit) S3method(plotmo.y, lognet) S3method(plotmo.y, mrelnet) S3method(plotmo.y, multnet) S3method(plotmo.y, varmod) importFrom("grDevices", "as.graphicsAnnot", "col2rgb", "gray", "xy.coords") importFrom("graphics", "abline", "axis", "box", "grid", "image", "legend", "lines", "mtext", "par", "plot", "points", "polygon", "rect", "segments", "strheight", "strwidth", "text", "xinch", "yinch") importFrom("stats", "approx", "coef", "cor.test", "density", "deviance", "df.residual", "formula", "getCall", "hatvalues", "loess", "lowess", "median", "model.matrix", "na.omit", "na.pass", "pnorm", "predict", "qqline", "qqnorm", "quantile", "rnorm", "sd", "update", "weighted.mean") importFrom("utils", "assignInMyNamespace", "head", "str") plotmo/.Rinstignore0000644000176200001440000000001313275315113014063 0ustar liggesusersslowtests plotmo/README.md0000644000176200001440000001072213725236714013057 0ustar liggesusers[![version](https://www.r-pkg.org/badges/version/plotmo)](https://cran.r-project.org/package=plotmo) [![downloads](https://cranlogs.r-pkg.org/badges/plotmo)](https://cran.r-project.org/package=plotmo) ## The plotmo package: Plotting model surfaces After building a regression or classification model, it's often useful to plot the model response as the predictors vary. These model surface plots are helpful for visualizing "black box" models. The [plotmo]( https://CRAN.R-project.org/package=plotmo) package makes it easy to generate model surfaces for a wide variety of [R]( https://www.r-project.org) models, including [rpart]( https://CRAN.R-project.org/package=rpart), [gbm]( https://CRAN.R-project.org/package=gbm), [earth]( https://CRAN.R-project.org/package=earth), and many others. ## An example model surface Let's generate a [randomForest]( https://CRAN.R-project.org/package=randomForest) model from the well-known ozone dataset. (We use a random forest for this example, but any model could be used.) ```r library(earth) # for the ozone1 data data(ozone1) oz <- ozone1[, c("O3", "humidity", "temp")] # simple dataset for illustration library(randomForest) mod <- randomForest(O3 ~ ., data=oz) ``` We now have a model, but what does it tell us about the relationship between ozone pollution (O3) and humidity and temperature? We can visualize this relationship with `plotmo`: ```r library(plotmo) plotmo(mod) ``` ![](inst/README-figures/plotmo-randomForest.png) From the plots, we see that ozone increases with humidity and temperature, although humidity doesn't have much effect at low temperatures. ## Some details The top two plots in the above figure are generated by plotting the predicted response as a variable changes. Variables that don't appear in a plot are held fixed at their median values. Plotmo automatically creates a separate plot for each variable in the model. The lower interaction plot shows the predicted response as two variables are changed (once again with other variables if any held at their median values). Plotmo draws just one interaction plot for this model, since there are only two variables. ## Partial dependence plots We can generate `partial dependence` plots by specifying `pmethod="partdep"` when invoking `plotmo`. In partial dependence plots, the effect of the background variables is averaged (instead of simply holding the background variables at their medians). Partial dependence plots can be very slow, but they do incorporate more information about the distribution of the response. ## Plotting model residuals The `plotres` function is also included in the `plotmo` package. This function shows residuals and other useful information about the model, if available. Using the above model as an example: ```r plotres(mod) ``` which gives ![](inst/README-figures/plotres-randomForest.png) Note the "<" shape in the residuals plot in the lower left. This suggests that we should transform the response before building the model, maybe by taking the square or cube-root. Cases 53, 237, and 258 have the largest residuals and perhaps should be investigated. This kind of information is not obvious without plotting the residuals ## Miscellaneous More details and examples may be found in the package vignettes: - [Plotting regression surfaces with `plotmo`](http://www.milbo.org/doc/plotmo-notes.pdf) - [Plotting model residuals with `plotres`](http://www.milbo.org/doc/plotres-notes.pdf) The package also provides a few utility functions such as `plot_glmnet` and `plot_gbm`. These functions enhance similar functions in the [glmnet](https://CRAN.R-project.org/package=glmnet) and [gbm](https://CRAN.R-project.org/package=gbm) packages. Some examples: ![](inst/README-figures/plotres-glmnet-gbm.png) ## Which models work with plotmo? Any model that conforms to standard S3 model guidelines will work with `plotmo`. Plotmo knows how to deal with logistic, classification, and multiple response models. It knows how to handle different `type` arguments to `predict` functions. Package authors may want to look at [Guidelines for S3 Regression Models](http://www.milbo.org/doc/modguide.pdf). If `plotmo` or `plotres` doesn't work with your model, contact the `plotmo` package maintainer. Often a minor tweak to the model code is all that is needed. [Stephen Milborrow]( http://www.milbo.users.sonic.net/index.html) plotmo/man/0000755000176200001440000000000014334575431012350 5ustar liggesusersplotmo/man/plotmo.misc.Rd0000644000176200001440000000614114566103176015105 0ustar liggesusers\name{plotmo.misc} \alias{check.index} \alias{plotmo.convert.na.nresponse} \alias{plotmo.pairs.default} \alias{plotmo.pairs} \alias{plotmo.pint} \alias{plotmo.predict} \alias{plotmo.prolog} \alias{plotmo.residtype} \alias{plotmo.singles.default} \alias{plotmo.singles} \alias{plotmo.type} \alias{plotmo.x} \alias{plotmo.y.default} \alias{plotmo.y} \alias{plotmo_cum} \alias{plotmo_fitted} \alias{plotmo_nresponse} \alias{plotmo_predict} \alias{plotmo_prolog} \alias{plotmo_resplevs} \alias{plotmo_response} \alias{plotmo_rinfo} \alias{plotmo_rsq} \alias{plotmo_standardizescale} \alias{plotmo_type} \alias{plotmo_y} \title{Ignore} \description{ Miscellaneous functions exported for internal use by \code{earth} and other packages. You can ignore these. } \usage{ # for earth plotmo_fitted(object, trace, nresponse, type, ...) plotmo_cum(rinfo, info, nfigs=1, add=FALSE, cum.col1, grid.col, jitter=0, cum.grid="percentages", ...) plotmo_nresponse(y, object, nresponse, trace, fname, type="response") plotmo_rinfo(object, type=NULL, residtype=type, nresponse=1, standardize=FALSE, delever=FALSE, trace=0, leverage.msg="returned as NA", expected.levs=NULL, labels.id=NULL, ...) plotmo_predict(object, newdata, nresponse, type, expected.levs, trace, inverse.func=NULL, ...) plotmo_prolog(object, object.name, trace, ...) plotmo_resplevs(object, plotmo_fitted, yfull, trace) plotmo_rsq(object, newdata, trace=0, nresponse=NA, type=NULL, ...) plotmo_standardizescale(object) plotmo_type(object, trace, fname="plotmo", type, ...) plotmo_y(object, nresponse=NULL, trace=0, expected.len=NULL, resp.levs=NULL, convert.glm.response=!is.null(nresponse)) \method{plotmo.pairs}{default}(object, x, nresponse, trace, all2, ...) \method{plotmo.singles}{default}(object, x, nresponse, trace, all1, ...) \method{plotmo.y}{default}(object, trace, naked, expected.len, ...) # plotmo methods plotmo.convert.na.nresponse(object, nresponse, yhat, type="response", ...) plotmo.pairs(object, x, nresponse, trace, all2, ...) plotmo.pint(object, newdata, type, level, trace, ...) plotmo.predict(object, newdata, type, ..., TRACE) plotmo.prolog(object, object.name, trace, ...) plotmo.residtype(object, ..., TRACE) plotmo.singles(object, x, nresponse, trace, all1, ...) plotmo.type(object, ..., TRACE) plotmo.x(object, trace, ...) plotmo.y(object, trace, naked, expected.len, nresponse=1, ...) } \arguments{ \item{\dots}{-} \item{add}{-} \item{all1}{-} \item{all2}{-} \item{convert.glm.response}{-} \item{cum.col1}{-} \item{cum.grid}{-} \item{delever}{-} \item{expected.len}{-} \item{expected.levs}{-} \item{fname}{-} \item{grid.col}{-} \item{info}{-} \item{inverse.func}{-} \item{jitter}{-} \item{labels.id}{-} \item{level}{-} \item{leverage.msg}{-} \item{naked}{-} \item{newdata}{-} \item{nfigs}{-} \item{nresponse}{-} \item{object.name}{-} \item{object}{-} \item{plotmo_fitted}{-} \item{residtype}{-} \item{resp.levs}{-} \item{rinfo}{-} \item{standardize}{-} \item{TRACE}{-} \item{trace}{-} \item{type}{-} \item{x}{-} \item{yfull}{-} \item{yhat}{-} \item{y}{-} } plotmo/man/plotres.Rd0000644000176200001440000003305613136204652014327 0ustar liggesusers\name{plotres} \alias{plotres} \concept{residual plot} \title{Plot the residuals of a regression model} \description{ Plot the residuals of a regression model. Please see the \href{../doc/plotres-notes.pdf}{plotres vignette} (also available \href{http://www.milbo.org/doc/plotres-notes.pdf}{here}). } \usage{ plotres(object = stop("no 'object' argument"), which = 1:4, info = FALSE, versus = 1, standardize = FALSE, delever = FALSE, level = 0, id.n = 3, labels.id = NULL, smooth.col = 2, grid.col = 0, jitter = 0, do.par = NULL, caption = NULL, trace = 0, npoints = 3000, center = TRUE, type = NULL, nresponse = NA, object.name = quote.deparse(substitute(object)), ...) } \arguments{ \item{object}{ The model object. } \item{which}{ Which plots do draw. Default is \code{1:4}. \code{1} Model plot. What gets plotted here depends on the model class. For example, for \code{earth} models this is a model selection plot. Nothing will be displayed for some models. For details, please see the \href{../doc/plotres-notes.pdf}{plotres vignette}. \code{2} Cumulative distribution of abs residuals \code{3} Residuals vs fitted \code{4} QQ plot \code{5} Abs residuals vs fitted \code{6} Sqrt abs residuals vs fitted \code{7} Abs residuals vs log fitted \code{8} Cube root of the squared residuals vs log fitted \code{9} Log abs residuals vs log fitted \cr \cr } \item{info}{ Default is \code{FALSE}. Use \code{TRUE} to print extra information as follows: % For more information, please % see the section \emph{\dQuote{The info argument of plot.earth}} % in the \code{earth} package vignette % \emph{\dQuote{Variance models in earth}}. i) Display the distribution of the residuals along the bottom of the plot. ii) Display the training R-Squared. iii) Display the Spearman Rank Correlation of the absolute residuals with the fitted values. Actually, correlation is measured against the absolute values of whatever is on the horizontal axis --- by default this is the fitted response, but may be something else if the \code{versus} argument is used. iv) In the Cumulative Distribution plot (\code{which=2}), display additional information on the quantiles. v) Only for \code{which=5} or \code{9}. Regress the absolute residuals against the fitted values and display the regression slope. Robust linear regression is used via \code{\link[MASS]{rlm}} in the MASS package. vi) Add various annotations to the other plots. \cr \cr } \item{versus}{ What do we plot the residuals against? One of: \code{1} Default. Plot the residuals versus the fitted values (or the log values when \code{which=7} to \code{9}). \code{2} Residuals versus observation number, after observations have been sorted on the fitted value. Same as \code{versus=1}, except that the residuals are spaced uniformly along the horizontal axis. \code{3} Residuals versus the response. \code{4} Residuals versus the hat leverages. \code{"b:"} Residuals versus the basis functions. Currently only supported for \code{earth}, \code{mda::mars}, and \code{gam::gam} models. A optional \code{\link{regex}} can follow the \code{"b:"} to specify a subset of the terms, e.g. \code{versus="b:wind"} will plot terms with \code{"wind"} in their name. Else a character vector specifying which predictors to plot against. \cr Example 1: \code{versus=""} plots against all predictors (since the regex \code{versus=""} matches anything). \cr Example 2: \code{versus=c("wind", "vis")} plots predictors with \code{wind} or \code{vis} in their name. \cr Example 3: \code{versus=c("wind|vis")} equivalent to the above. \cr Note: These are \code{\link{regex}}s. Thus \code{versus="wind"} will match all variables that have \code{"wind"} in their names. Use \code{"^wind$"} to match only the variable named \code{"wind"}. \cr \cr } \item{standardize}{ Default is \code{FALSE}. Use \code{TRUE} to standardize the residuals. Only supported for some models, an error message will be issued otherwise. \cr Each residual is divided by by \code{se_i * sqrt(1 - h_ii)}, where \code{se_i} is the standard error of prediction and \code{h_ii} is the leverage (the diagonal entry of the hat matrix). When the variance model holds, the standardized residuals are homoscedastic with unity variance. \cr The leverages are obtained using \code{\link{hatvalues}}. (For \code{earth} models the leverages are for the linear regression of the response on the basis matrix \code{bx}.) A standardized residual with a leverage of 1 is plotted as a star on the axis. \cr This argument applies to all plots where the residuals are used (including the cumulative distribution and QQ plots, and to annotations displayed by the \code{info} argument). } \item{delever}{ Default is \code{FALSE}. Use \code{TRUE} to \dQuote{de-lever} the residuals. Only supported for some models, an error message will be issued otherwise. \cr Each residual is divided by \code{sqrt(1 - h_ii)}. See the \code{standardize} argument for details. } \item{level}{ Draw estimated confidence or prediction interval bands at the given \code{level}, if the model supports them. \cr Default is \code{0}, bands not plotted. Else a fraction, for example \code{level=0.90}. Example:\preformatted{ mod <- lm(log(Volume)~log(Girth), data=trees) plotres(mod, level=.90)} You can modify the color of the bands with \code{level.shade} and \code{level.shade2}. \cr See also \dQuote{\emph{Prediction intervals}} in the \href{../doc/plotmo-notes.pdf}{plotmo vignette} (but note that \code{plotmo} needs prediction intervals on \emph{new} data, whereas \code{plotres} requires only that the model supports prediction intervals on the training data). } \item{id.n}{ The largest \code{id.n} residuals will be labeled in the plot. Default is \code{3}. Special values \code{TRUE} and \code{-1} or mean all.\cr If \code{id.n} is negative (but not \code{-1}) the \code{id.n} most positive and most negative residuals will be labeled in the plot.\cr A current implementation restriction is that \code{id.n} is ignored when there are more than ten thousand cases. } \item{labels.id}{ Residual labels. Only used if \code{id.n > 0}. Default is the case names, or the case numbers if the cases are unnamed. } \item{smooth.col}{ Color of the smooth line through the residual points. Default is \code{2}, red. Use \code{smooth.col=0} for no smooth line. \cr You can adjust the amount of smoothing with \code{smooth.f}. This gets passed as \code{f} to \code{\link[stats]{lowess}}. The default is \code{2/3}. Lower values make the line more wiggly. } \item{grid.col}{ Default is \code{0}, no grid. Else add a background \code{\link[graphics]{grid}} of the specified color to the degree1 plots. The special value \code{grid.col=TRUE} is treated as \code{"lightgray"}. } % \item{cum.grid}{ % Grid type in the Cumulative Distribution plot. One of: % % \code{"none"} No grid. % % \code{"grid"} Add grid showing the 25\%, 50\%, 90\%, and 95\% % quantiles. % % \code{"percentages"} (default) Add grid and percentage labels. % If \code{info=TRUE} also display quantiles on the right. % \cr % \cr % } \item{jitter}{ Default is \code{0}, no jitter. Passed as \code{factor} to \code{\link[base]{jitter}} to jitter the plotted points horizontally and vertically. Useful for discrete variables and responses, where the residual points tend to be overlaid. } \item{do.par}{One of \code{NULL}, \code{FALSE}, \code{TRUE}, or \code{2}, as follows: \code{do.par=NULL} (default). Same as \code{do.par=FALSE} if the number of plots is one; else the same as \code{TRUE}. \code{do.par=FALSE}. Use the current \code{\link[graphics]{par}} settings. You can pass additional graphics parameters in the ``\code{...}'' argument. \code{do.par=TRUE}. Start a new page and call \code{\link[graphics]{par}} as appropriate to display multiple plots on the same page. This automatically sets parameters like \code{mfrow} and \code{mar}. You can pass additional graphics parameters in the ``\code{...}'' argument. % This sets the \emph{overall} look of the display; modify % \emph{specific} plots by using prefixed arguments as described in the % documentation for the \dots argument below. \code{do.par=2}. Like \code{do.par=TRUE} but don't restore the \code{\link[graphics]{par}} settings to their original state when \code{plotres} exits, so you can add something to the plot. \cr \cr } \item{caption}{ Overall caption. By default create the caption automatically. Use \code{caption=""} for no caption. (Use \code{main} to set the title of an individual plot.) } \item{trace}{ Default is \code{0}. \cr \code{trace=1} (or \code{TRUE}) for a summary trace (shows how \code{\link[stats]{predict}} and friends are invoked for the model). \cr \code{trace=2} for detailed tracing. \cr } \item{npoints}{ Number of points to be plotted. A sample of \code{npoints} is taken; the sample includes the biggest twenty or so residuals. \cr The default is 3000 (not all, to avoid overplotting on large models). Use \code{npoints=TRUE} or \code{-1} for all points. } \item{center}{ Default is TRUE, meaning center the horizontal axis in the residuals plot, so asymmetry in the residual distribution is more obvious. } \item{type}{ Type parameter passed first to \code{\link{residuals}} and if that fails to \code{\link{predict}}. For allowed values see the \code{residuals} and \code{predict} methods for your \code{object} (such as \code{\link[rpart]{residuals.rpart}} or \code{\link[earth]{predict.earth}}). By default, \code{plotres} tries to automatically select a suitable value for the model in question (usually \code{"response"}), but this will not always be correct. Use \code{trace=1} to see the \code{type} argument passed to \code{residuals} and \code{predict}. } \item{nresponse}{ Which column to use when \code{residuals} or \code{predict} returns multiple columns. This can be a column index or column name (which may be abbreviated, partial matching is used). } \item{object.name}{ The name of the \code{object} for error and trace messages. Used internally by \code{plot.earth}. \cr \cr } \item{\dots}{ Dot arguments are passed to the plot functions. Dot argument names, whether prefixed or not, should be specified in full and not abbreviated. \dQuote{Prefixed} arguments are passed directly to the associated function. For example the prefixed argument \code{pt.col="pink"} passes \code{col="pink"} to \code{points()}, overriding the global \code{col} setting. The prefixes recognized by \code{plotres} are:\tabular{ll}{ \code{residuals.} \tab passed to \code{\link[stats]{residuals}} \cr \code{predict.} \tab passed to \code{\link[stats]{predict}} (\code{predict} is called if the call to \code{residuals} fails) \cr \code{w1.} \tab sent to the model-dependent plot for \code{which=1} e.g. \code{w1.col=2} \cr \code{pt.} \tab modify the displayed points e.g. \code{pt.col=as.numeric(survived)+2} or \code{pt.cex=.8}. \cr \code{smooth.} \tab modify the smooth line e.g. \code{smooth.col=0} or \code{smooth.f=.5}. \cr \code{level.} \tab modify the interval bands, e.g. \code{level.shade="gray"} or \code{level.shade2="lightblue"} \cr \code{legend.} \tab modify the displayed \code{\link[graphics]{legend}} e.g. \code{legend.cex=.9} \cr \code{cum.} \tab modify the Cumulative Distribution plot (arguments for \code{\link[stats]{plot.stepfun}}) \cr \code{qq.} \tab modify the QQ plot, e.g. \code{qq.pch=1} \cr \code{qqline} \tab modify the \code{\link{qqline}} in the QQ plot, e.g. \code{qqline.col=0} \cr \code{label.} \tab modify the point labels, e.g. \code{label.cex=.9} or \code{label.font=2} \cr \code{cook.} \tab modify the Cook's Distance annotations. This affects only the leverage plot (\code{versus=3}) for \code{lm} models with \code{standardize=TRUE}. e.g. \code{cook.levels=c(.5, .8, 1)} or \code{cook.col=2}. \cr \code{caption.} \tab modify the overall caption (see the \code{caption} argument) e.g. \code{caption.col=2}. \cr \code{par.} \tab arguments for \code{\link[graphics]{par}} (only necessary if a \code{par} argument name clashes with a \code{plotres} argument) } The \code{cex} argument is relative, so specifying \code{cex=1} is the same as not specifying \code{cex}. For backwards compatibility, some dot arguments are supported but not explicitly documented. } } \value{ If the \code{which=1} plot was plotted, the return value of that plot (model dependent). Else if the \code{which=3} plot was plotted, return \code{list(x,y)} where \code{x} and \code{y} are the coordinates of the points in that plot (but without jittering even if the \code{jitter} argument was used). Else return \code{NULL}. } \note{ This function is designed primarily for displaying standard \code{response - fitted} residuals for models with a single continuous response, although it will work for a few other models. In general this function won't work on models that don't save the call and data with the model in a standard way. It uses the same underlying mechanism to access the model data as \code{\link{plotmo}}. For further discussion please see \dQuote{\emph{Accessing the model data}} in the \href{../doc/plotmo-notes.pdf}{plotmo vignette} (also available \href{http://www.milbo.org/doc/plotmo-notes.pdf}{here}). Package authors may want to look at \href{../doc/modguide.pdf}{Guidelines for S3 Regression Models} (also available \href{http://www.milbo.org/doc/modguide.pdf}{here}). } \seealso{ Please see the \href{../doc/plotres-notes.pdf}{plotres vignette} (also available \href{http://www.milbo.org/doc/plotres-notes.pdf}{here}). \code{\link[stats]{plot.lm}} \code{\link[earth]{plot.earth}} } \examples{ # we use lm in this example, but plotres is more useful for models # that don't have a function like plot.lm for plotting residuals lm.model <- lm(Volume~., data=trees) plotres(lm.model) } \keyword{partial dependence} \keyword{regression} plotmo/man/plot_glmnet.Rd0000644000176200001440000000636314563612627015176 0ustar liggesusers\name{plot_glmnet} \alias{plot_glmnet} \title{Plot a glmnet model} \description{ Plot the coefficient paths of a \code{\link[glmnet]{glmnet}} model. An enhanced version of \code{\link[glmnet]{plot.glmnet}}. } \usage{ plot_glmnet(x = stop("no 'x' argument"), xvar = c("rlambda", "lambda", "norm", "dev"), label = 10, nresponse = NA, grid.col = NA, s = NA, ...) } \arguments{ \item{x}{ The \code{glmnet} model. } \item{xvar}{ What gets plotted along the x axis. One of:\cr \bold{\code{"rlambda"}} (default) decreasing log lambda (lambda is the glmnet penalty)\cr \bold{\code{"lambda"}} log lambda\cr \bold{\code{"norm"}} L1-norm of the coefficients\cr \bold{\code{"dev"}} percent deviance explained\cr\cr The default \code{xvar} differs from \code{plot.glmnet} to allow \code{s} to be plotted when this function is invoked by \code{\link{plotres}}. } \item{label}{ Default \code{10}. Number of variable names displayed on the right of the plot. One of:\cr \bold{\code{FALSE}} display no variables\cr \bold{\code{TRUE}} display all variables\cr \bold{\code{integer}} (default) number of variables to display (default is 10)\cr } \item{nresponse}{ Which response to plot for multiple response models. } \item{grid.col}{ Default \code{NA}. Color of the optional grid, for example \code{grid.col="lightgray"}. } \item{s}{ For use by \code{\link{plotres}}. The x position of the gray vertical line indicating the lambda \code{s} passed by \code{plotres} to \code{predict.glmnet} to calculate the residuals. Plotres defaults to \code{s=0}. } \item{\dots}{ Dot arguments are passed internally to \code{\link[graphics]{matplot}}. Use \code{col} to change the color of curves; for example \code{col=1:4}. The six default colors are intended to be distinguishable yet harmonious (to my eye at least), with adjacent colors as different as easily possible. } } \note{ \bold{Limitations} For multiple response models use the \code{nresponse} argument to specify which response should be plotted. (Currently each response must be plotted one by one.) The \code{type.coef} argument of \code{\link[glmnet]{plot.glmnet}} is currently not supported. Currently \code{xvar="norm"} is not supported for multiple response models (you will get an error message). \bold{Interaction with \code{plotres}} When invoking this function via \code{\link{plotres}}, prefix any argument of \code{plotres} with \code{w1.} to tell \code{plotres} to pass the argument to this function. For example give \code{w1.col=1:4} to \code{plotres} (plain \code{col=1:4} in this context gets passed to the residual plots). \bold{Acknowledgments} This function is based on \code{\link[glmnet]{plot.glmnet}} in the \code{\link[glmnet]{glmnet}} package authored by Jerome Friedman, Trevor Hastie, and Rob Tibshirani. This function incorporates the function \code{spread.labs} from the orphaned package \code{TeachingDemos} written by Greg Snow. } \seealso{ Chapter 6 in \href{../doc/plotres-notes.pdf}{plotres vignette} discusses this function. } \examples{ if (require(glmnet)) { x <- matrix(rnorm(100 * 10), 100, 10) # n=100 p=10 y <- x[,1] + x[,2] + 2 * rnorm(100) # y depends only on x[,1] and x[,2] mod <- glmnet(x, y) plot_glmnet(mod) # plotres(mod) # plot the residuals } } plotmo/man/plot_gbm.Rd0000644000176200001440000001075713011421421014430 0ustar liggesusers\name{plot_gbm} \alias{plot_gbm} \title{Plot a gbm model} \description{ Plot a \code{\link[gbm]{gbm}} model showing the training and other error curves. } \usage{ plot_gbm(object=stop("no 'object' argument"), smooth = c(0, 0, 0, 1), col = c(1, 2, 3, 4), ylim = "auto", legend.x = NULL, legend.y = NULL, legend.cex = .8, grid.col = NA, n.trees = NA, col.n.trees ="darkgray", ...) } \arguments{ \item{object}{ The \code{gbm} model. } \item{smooth}{ Four-element vector specifying if smoothing should be applied to the train, test, CV, and OOB curves respectively. When smoothing is specified, a smoothed curve is plotted and the minimum is calculated from the smoothed curve.\cr The default is c(0, 0, 0, 1) meaning apply smoothing only to the OOB curve (same as \code{\link[gbm]{gbm.perf}}).\cr Note that \code{smooth=1} (which gets recyled to \code{c(1,1,1,1)}) will smooth all the curves. } \item{col }{ Four-element vector specifying the colors for the train, test, CV, and OOB curves respectively.\cr The default is \code{c(1, 2, 3, 4)}.\cr Use a color of \code{0} to remove the corresponding curve, e.g. \code{col=c(1,2,3,0)} to not display the OOB curve.\cr If \code{col=0} (which gets recycled to \code{c(0,0,0,0)}) nothing will be plotted, but \code{plot_gbm} will return the number-of-trees at the minima as usual (as described in the Value section below). } \item{ylim }{ The default \code{ylim="auto"} shows more detail around the minima.\cr Use \code{ylim=NULL} for the full vertical range of the curves.\cr Else specify \code{ylim} as usual. } \item{legend.x }{ The x position of the legend. The default positions the legend automatically.\cr Use \code{legend.x=NA} for no legend.\cr See the \code{x} and \code{y} arguments of \code{\link[grDevices]{xy.coords}} for other options, for example \code{legend.x="topright"}. } \item{legend.y }{ The y position of the legend. } \item{legend.cex }{ The legend \code{cex} (the default is \code{0.8}). } \item{grid.col}{ Default \code{NA}. Color of the optional grid, for example \code{grid.col=1}. } \item{n.trees}{ For use by \code{\link{plotres}}.\cr The x position of the gray vertical line indicating the \code{n.trees} passed by \code{plotres} to \code{predict.gbm} to calculate the residuals. Plotres defaults to all trees. } \item{col.n.trees }{ For use by \code{\link{plotres}}.\cr Color of the vertical line showing the \code{n.trees} argument. Default is \code{"darkgray"}. } \item{\dots}{ Dot arguments are passed internally to \code{\link[graphics]{plot.default}}. } } \value{ This function returns a four-element vector specifying the number of trees at the train, test, CV, and OOB minima respectively. The minima are calculated after smoothing as specified by this function's \code{smooth} argument. By default, only the OOB curve is smoothed. The smoothing algorithm for the OOB curve differs slightly from \code{\link[gbm]{gbm.perf}}, so can give a slightly different number of trees. } \note{ \bold{The OOB curve} The OOB curve is artificially rescaled to force it into the plot. See Chapter 7 in the \href{../doc/plotres-notes.pdf}{plotres vignette}. % The OOB minimum is determined after smoothing the curve, % but the unsmoothed curve is displayed. % Whereas the minima for the test and cross-validation curves are % determined without smoothing. % This calculation of minima is compatible with \code{gbm.perf}. \bold{Interaction with \code{plotres}} When invoking this function via \code{\link{plotres}}, prefix any argument of \code{plotres} with \code{w1.} to tell \code{plotres} to pass the argument to this function. For example give \code{w1.ylim=c(0,10)} to \code{plotres} (plain \code{ylim=c(0,10)} in this context gets passed to the residual plots). \bold{Acknowledgments} This function is derived from code in the \code{\link[gbm]{gbm}} package authored by Greg Ridgeway and others. } \seealso{ Chapter 7 in \href{../doc/plotres-notes.pdf}{plotres vignette} discusses this function. } \examples{ if (require(gbm)) { n <- 100 # toy model for quick demo x1 <- 3 * runif(n) x2 <- 3 * runif(n) x3 <- sample(1:4, n, replace=TRUE) y <- x1 + x2 + x3 + rnorm(n, 0, .3) data <- data.frame(y=y, x1=x1, x2=x2, x3=x3) mod <- gbm(y~., data=data, distribution="gaussian", n.trees=300, shrinkage=.1, interaction.depth=3, train.fraction=.8, verbose=FALSE) plot_gbm(mod) # plotres(mod) # plot residuals # plotmo(mod) # plot regression surfaces } } plotmo/man/plotmo.Rd0000644000176200001440000004576113725545113014163 0ustar liggesusers\name{plotmo} \alias{plotmo} \concept{partial dependence plot} \title{Plot a model's response over a range of predictor values (the model surface)} \description{ Plot model surfaces for a wide variety of models. This function plots the model's response when varying one or two predictors while holding the other predictors constant (a poor man's partial-dependence plot). It can also generate partial-dependence plots (by specifying \code{pmethod="partdep"}). Please see the \href{../doc/plotmo-notes.pdf}{plotmo vignette} (also available \href{http://www.milbo.org/doc/plotmo-notes.pdf}{here}). } \usage{ plotmo(object=stop("no 'object' argument"), type=NULL, nresponse=NA, pmethod="plotmo", pt.col=0, jitter=.5, smooth.col=0, level=0, func=NULL, inverse.func=NULL, nrug=0, grid.col=0, type2="persp", degree1=TRUE, all1=FALSE, degree2=TRUE, all2=FALSE, do.par=TRUE, clip=TRUE, ylim=NULL, caption=NULL, trace=0, grid.func=NULL, grid.levels=NULL, extend=0, ngrid1=50, ngrid2=20, ndiscrete=5, npoints=3000, center=FALSE, xflip=FALSE, yflip=FALSE, swapxy=FALSE, int.only.ok=TRUE, ...) } \arguments{ \item{object}{ The model object. } \item{type}{ Type parameter passed to \code{\link{predict}}. For allowed values see the \code{predict} method for your \code{object} (such as \code{\link[earth]{predict.earth}}). By default, \code{plotmo} tries to automatically select a suitable value for the model in question (usually \code{"response"}) but this will not always be correct. Use \code{trace=1} to see the \code{type} argument passed to \code{predict}. } \item{nresponse}{ Which column to use when \code{predict} returns multiple columns. This can be a column index, or a column name if the \code{predict} method for the model returns column names. The column name may be abbreviated, partial matching is used. } \item{pmethod}{ Plotting method. One of: \code{"plotmo"} (default) Classic plotmo plots i.e. the background variables are fixed at their medians (or first level for factors). \code{"partdep"} Partial dependence plots, i.e. at each point the effect of the background variables is averaged. \code{"apartdep"} Approximate partial dependence plots. Faster than \code{"partdep"} especially for big datasets. Like \code{"partdep"} but the background variables are averaged over a subset of \code{ngrid1} cases (default 50), rather than all cases in the training data. The subset is created by selecting rows at equally spaced intervals from the training data after sorting the data on the response values (ties are randomly broken). % If \code{ngrid1} is greater then the number of cases than all cases % are used, and \code{"apartdep"} is identical to \code{"partdep"}. The same background subset of \code{ngrid1} cases is used for both degree1 and degree2 plots. } \item{pt.col}{ The color of response points (or response sites in degree2 plots). This refers to the response \code{y} in the data used to build the model. Note that the displayed points are jittered by default (see the \code{jitter} argument). \cr Default is \code{0}, display no response points. \cr This can be a vector, like all such arguments -- for example \code{pt.col = as.numeric(survived)+2} to color points by their survival class. \cr You can modify the plotted points with \code{pt.pch}, \code{pt.cex}, etc. (these get passed via \code{plotmo}'s ``\code{...}'' argument). For example, \code{pt.cex = weights} to size points by their weight. To label the points, set \code{pt.pch} to a character vector. } \item{jitter}{ Applies only if \code{pt.col} is specified.\cr The default is \code{jitter=.5}, automatically apply some jitter to the points. Points are jittered horizontally and vertically.\cr Use \code{jitter=0} to disable this automatic jittering. Otherwise something like \code{jitter=1}, but the optimum value is data dependent. } \item{smooth.col}{ Color of smooth line through the response points. (The points themselves will not be plotted unless \code{pt.col} is specified.) Default is \code{0}, no smooth line. \cr Example:\preformatted{ mod <- lm(Volume~Height, data=trees) plotmo(mod, pt.color=1, smooth.col=2)} You can adjust the amount of smoothing with \code{smooth.f}. This gets passed as \code{f} to \code{\link[stats]{lowess}}. The default is \code{.5}. Lower values make the line more wiggly. } \item{level}{ Draw estimated confidence or prediction interval bands at the given \code{level}, if the predict method for the model supports them.\cr Default is \code{0}, bands not plotted. Else a fraction, for example \code{level=.95}. See \dQuote{\emph{Prediction intervals}} in the \code{plotmo} vignette. Example:\preformatted{ mod <- lm(log(Volume)~log(Girth), data=trees) plotmo(mod, level=.95)} You can modify the color of the bands with \code{level.shade} and \code{level.shade2}. } \item{func}{ Superimpose \code{func(x)} on the plot. Example:\preformatted{ mod <- lm(Volume~Girth, data=trees) estimated.volume <- function(x) .17 * x$Girth^2 plotmo(mod, pt.col=2, func=estimated.volume)} The \code{func} is called for each plot with a single argument which is a dataframe with columns in the same order as the predictors in the \code{formula} or \code{x} used to build the model. Use \code{trace=2} to see the column names and first few rows of this dataframe. } \item{inverse.func}{ A function applied to the response before plotting. Useful to transform a transformed response back to the original scale. Example:\preformatted{ mod <- lm(log(Volume)~., data=trees) plotmo(mod, inverse.func=exp) # exp() is inverse of log() } } \item{nrug}{ Number of ticks in the \code{\link[graphics]{rug}} along the bottom of the plot \cr Default is \code{0}, no rug. \cr Use \code{nrug=TRUE} for all the points. \cr Else specify the number of quantiles e.g. use \code{nrug=10} for ticks at the 0, 10, 20, ..., 100 percentiles. \cr Modify the rug ticks with \code{rug.col}, \code{rug.lwd}, etc. \cr The special value \code{nrug="density"} means plot the density of the points along the bottom. Modify the \code{\link[stats]{density}} plot with \code{density.adjust} (default is \code{.5}), \code{density.col}, \code{density.lty}, etc. } \item{grid.col}{ Default is \code{0}, no grid. Else add a background \code{\link[graphics]{grid}} of the specified color to the degree1 plots. The special value \code{grid.col=TRUE} is treated as \code{"lightgray"}. } \item{type2}{ Degree2 plot type. One of \code{"\link[graphics]{persp}"} (default), \code{"\link[graphics]{image}"}, or \code{"\link[graphics]{contour}"}. You can pass arguments to these functions if necessary by using \code{persp.}, \code{image.}, or \code{contour.} as a prefix. Examples:\preformatted{ plotmo(mod, persp.ticktype="detailed", persp.nticks=3) plotmo(mod, type2="image") plotmo(mod, type2="image", image.col=heat.colors(12)) plotmo(mod, type2="contour", contour.col=2, contour.labcex=.4) } } \item{degree1}{ An index vector specifying which subset of degree1 (main effect) plots to include (after selecting the relevant predictors as described in \dQuote{\emph{Which variables are plotted?}} in the \code{plotmo} vignette). \cr Default is \code{TRUE}, meaning all (the \code{TRUE} gets recycled). To plot only the third plot use \code{degree1=3}. For no degree1 plots use \code{degree1=0}. \cr \cr Note that \code{degree1} indexes plots on the page, not columns of \code{x}. Probably the easiest way to use this argument (and \code{degree2}) is to first use the default (and possibly \code{all1=TRUE}) to plot all figures. This shows how the figures are numbered. Then replot using \code{degree1} to select the figures you want, for example \code{degree1=c(1,3,4)}. \cr \cr Can also be a character vector specifying which variables to plot. Examples:\cr \code{degree1="wind"}\cr \code{degree1=c("wind", "vis")}. \cr \cr Variables names are matched with \code{\link[base]{grep}}. Thus \code{"wind"} will match all variables with \code{"wind"} anywhere in their name. Use \code{"^wind$"} to match only the variable named \code{"wind"}. } \item{all1}{ Default is \code{FALSE}. Use \code{TRUE} to plot all predictors, not just those usually selected by \code{plotmo}. \cr The \code{all1} argument increases the number of plots; the \code{degree1} argument reduces the number of plots. } \item{degree2}{ An index vector specifying which subset of degree2 (interaction) plots to include. \cr Default is \code{TRUE} meaning all (after selecting the relevant interaction terms as described in \dQuote{\emph{Which variables are plotted?}} in the \code{plotmo} vignette). \cr \cr Can also be a character vector specifying which variables to plot (\code{\link[base]{grep}} is used for matching). Examples: \cr \code{degree2="wind"} plots all degree2 plots for the \code{wind} variable. \cr \code{degree2=c("wind", "vis")} plots just the \code{wind:vis} plot. } \item{all2}{ Default is \code{FALSE}. Use \code{TRUE} to plot all pairs of predictors, not just those usually selected by \code{plotmo}. } \item{do.par}{One of \code{NULL}, \code{FALSE}, \code{TRUE}, or \code{2}, as follows: \code{do.par=NULL}. Same as \code{do.par=FALSE} if the number of plots is one; else the same as \code{TRUE}. \code{do.par=FALSE}. Use the current \code{\link[graphics]{par}} settings. You can pass additional graphics parameters in the ``\code{...}'' argument. \code{do.par=TRUE} (default). Start a new page and call \code{\link[graphics]{par}} as appropriate to display multiple plots on the same page. This automatically sets parameters like \code{mfrow} and \code{mar}. You can pass additional graphics parameters in the ``\code{...}'' argument. % This sets the \emph{overall} look of the display; modify % \emph{specific} plots by using prefixed arguments as described in the % documentation for the \dots argument below. \code{do.par=2}. Like \code{do.par=TRUE} but don't restore the \code{\link[graphics]{par}} settings to their original state when \code{plotmo} exits, so you can add something to the plot. \cr } \item{clip}{ The default is \code{clip=TRUE}, meaning ignore very outlying predictions when determining the automatic \code{ylim}. This keeps \code{ylim} fairly compact while still covering all or nearly all the data, even if there are a few crazy predicted values. See \dQuote{\emph{The \code{ylim} and \code{clip} arguments}} in the \code{plotmo} vignette. \cr Use \code{clip=FALSE} for no clipping. } \item{ylim}{Three possibilities: \cr \code{ylim=NULL} (default). Automatically determine a \code{ylim} to use across all graphs. \cr \code{ylim=NA}. Each graph has its own \code{ylim}. \cr \code{ylim=c(ymin,ymax)}. Use the specified limits across all graphs. \cr } \item{caption}{ Overall caption. By default create the caption automatically. Use \code{caption=""} for no caption. (Use \code{main} to set the title of individual plots, can be a vector.) } \item{trace}{ Default is \code{0}. \cr \code{trace=1} (or \code{TRUE}) for a summary trace (shows how \code{\link[stats]{predict}} is invoked for the current object). \cr \code{trace=2} for detailed tracing. \cr \code{trace=-1} inhibits the messages usually issued by \code{plotmo}, like the \code{plotmo grid:}, \code{calculating partdep}, and \code{nothing to plot} messages. Error and warning messages will be printed as usual. \cr \cr } \item{grid.func}{ Function applied to columns of the \code{x} matrix to pin the values of variables not on the axis of the current plot (the ``background'' variables).\cr The default is a function which for numeric variables returns the median and for logical and factors variables returns the value occurring most often in the training data.\cr Examples:\preformatted{ plotmo(mod, grid.func=mean) grid.func <- function(x, ...) quantile(x)[2] # 25\% quantile plotmo(mod, grid.func=grid.func)} This argument is not related to the \code{grid.col} argument.\cr This argument can be overridden for specific variables---see \code{grid.levels} below. } \item{grid.levels}{ Default is \code{NULL}. Else a list of variables and their fixed value to be used when the variable is not on the axis. Supersedes \code{grid.func} for variables in the list. Names and values can be abbreviated, partial matching is used. Example:\preformatted{ plotmo(mod, grid.levels=list(sex="m", age=21)) } } \item{extend}{ Amount to extend the horizontal axis in each plot. The default is \code{0}, do not extend (i.e. use the range of the variable in the training data). Else something like \code{extend=.5}, which will extend both the lower and upper \code{xlim} of each plot by 50\%.\cr This argument is useful if you want to see how the model performs on data that is beyond the training data; for example, you want to see how a time-series model performs on future data.\cr This argument is currently implemented only for degree1 plots. Factors and discrete variables (see the \code{ndiscrete} argument) are not extended. } \item{ngrid1}{ Number of equally spaced x values in each degree1 plot. Default is \code{50}. Also used as the number of background cases for \code{pmethod="apartdep"}. } \item{ngrid2}{ Grid size for degree2 plots (\code{ngrid2 x ngrid2} points are plotted). Default is \code{20}. \cr The default will sometimes be too small for \code{contour} and \code{image} plots. \cr With large \code{ngrid2} values, \code{persp} plots look better with \code{persp.border=NA}. } \item{npoints}{ Number of response points to be plotted (a sample of \code{npoints} points is plotted). Applies only if \code{pt.col} is specified. \cr The default is 3000 (not all, to avoid overplotting on large models). Use \code{npoints=TRUE} or \code{-1} for all points. } \item{ndiscrete}{ Default \code{5} (a somewhat arbitrary value). Variables with no more than \code{ndiscrete} unique values are plotted as quantized in plots (a staircase rather than a curve).\cr Factors are always considered discrete. Variables with non-integer values are always considered non-discrete.\cr Use \code{ndiscrete=0} if you want to plot the response for a variable with just a few integer values as a line or a curve, rather than a staircase.\cr } \item{int.only.ok}{ Plot the model even if it is an intercept-only model (no predictors are used in the model). Do this by plotting a single degree1 plot for the first predictor. \cr The default is \code{TRUE}. Use \code{int.only.ok=FALSE} to instead issue an error message for intercept-only models. } \item{center}{ Center the plotted response. Default is \code{FALSE}. } \item{xflip}{ Default \code{FALSE}. Use \code{TRUE} to flip the direction of the \code{x} axis. This argument (and \code{yflip} and \code{swapxy}) is useful when comparing to a plot from another source and you want the axes to be the same. (Note that \code{xflip} and \code{yflip} cannot be used on the \code{persp} plots, a limitation of the \code{persp} function.) } \item{yflip}{ Default \code{FALSE}. Use \code{TRUE} to flip the direction of the y axis of the degree2 graphs. } \item{swapxy}{ Default \code{FALSE}. Use \code{TRUE} to swap the x and y axes on the degree2 graphs. \cr \cr } \item{\dots}{ Dot arguments are passed to the predict and plot functions. Dot argument names, whether prefixed or not, should be specified in full and not abbreviated. \cr \cr \dQuote{Prefixed} arguments are passed directly to the associated function. For example the prefixed argument \code{persp.col="pink"} passes \code{col="pink"} to \code{persp()}, overriding the global \code{col} setting. To send an argument to \code{predict} whose name may alias with \code{plotmo}'s arguments, use \code{predict.} as a prefix. Example:\preformatted{ plotmo(mod, s=1) # error: arg matches multiple formal args plotmo(mod, predict.s=1) # ok now: s=1 will be passed to predict() } The prefixes recognized by \code{plotmo} are:\tabular{ll}{ \cr \code{predict.} \tab passed to the \code{\link[stats]{predict}} method for the model \cr \code{degree1.} \tab modifies degree1 plots e.g. \code{degree1.col=3, degree1.lwd=2} \cr \code{persp.} \tab arguments passed to \code{\link[graphics]{persp}} \cr \code{contour.} \tab arguments passed to \code{\link[graphics]{contour}} \cr \code{image.} \tab arguments passed to \code{\link[graphics]{image}} \cr \code{pt.} \tab see the \code{pt.col} argument (arguments passed to \code{\link[graphics]{points}} and \code{\link[graphics]{text}}) \cr \code{smooth.} \tab see the \code{smooth.col} argument (arguments passed to \code{\link[graphics]{lines}} and \code{\link[stats]{lowess}}) \cr \code{level.} \tab see the \code{level} argument (\code{level.shade}, \code{level.shade2}, and arguments for \code{\link[graphics]{polygon}}) \cr \code{func.} \tab see the \code{func} argument (arguments passed to \code{\link[graphics]{lines}}) \cr \code{rug.} \tab see the \code{nrug} argument (\code{rug.jitter}, and arguments passed to \code{\link[graphics]{rug}}) \cr \code{density.} \tab see the \code{nrug} argument (\code{density.adjust}, and arguments passed to \code{\link[graphics]{lines}}) \cr \code{grid.} \tab see the \code{grid.col} argument (arguments passed to \code{\link[graphics]{grid}}) \cr \code{caption.} \tab see the \code{caption} argument (arguments passed to \code{\link[graphics]{mtext}}) \cr \code{par.} \tab arguments passed to \code{\link[graphics]{par}} (only necessary if a \code{par} argument name clashes with a \code{plotmo} argument) \cr \code{prednames.} \tab Use \code{prednames.abbreviate=FALSE} for full predictor names in graph axes. \cr } The \code{cex} argument is relative, so specifying \code{cex=1} is the same as not specifying \code{cex}. For backwards compatibility, some dot arguments are supported but not explicitly documented. For example, the old argument \code{col.response} is no longer in \code{plotmo}'s formal argument list, but is still accepted and treated like the new argument \code{pt.col}. } } \note{ In general this function won't work on models that don't save the call and data with the model in a standard way. For further discussion please see \dQuote{\emph{Accessing the model data}} in the \href{../doc/plotmo-notes.pdf}{plotmo vignette}. Package authors may want to look at \href{../doc/modguide.pdf}{Guidelines for S3 Regression Models} (also available \href{http://www.milbo.org/doc/modguide.pdf}{here}). By default, \code{plotmo} tries to use sensible model-dependent defaults when calling \code{predict}. Use \code{trace=1} to see the arguments passed to \code{predict}. You can change the defaults by using \code{plotmo}'s \code{type} argument, and by using dot arguments prefixed with \code{predict.} (see the description of ``\code{...}'' above). } \seealso{ Please see the \href{../doc/plotmo-notes.pdf}{plotmo vignette} (also available \href{http://www.milbo.org/doc/plotmo-notes.pdf}{here}). } \examples{ if (require(rpart)) { data(kyphosis) rpart.model <- rpart(Kyphosis~., data=kyphosis) # pass type="prob" to plotmo's internal calls to predict.rpart, and # select the column named "present" from the matrix returned by predict.rpart plotmo(rpart.model, type="prob", nresponse="present") } if (require(earth)) { data(ozone1) earth.model <- earth(O3 ~ ., data=ozone1, degree=2) plotmo(earth.model) # plotmo(earth.model, pmethod="partdep") # partial dependence plots } } \keyword{partial dependence} \keyword{regression} plotmo/DESCRIPTION0000644000176200001440000000153314567113416013304 0ustar liggesusersPackage: plotmo Version: 3.6.3 Title: Plot a Model's Residuals, Response, and Partial Dependence Plots Author: Stephen Milborrow Maintainer: Stephen Milborrow Depends: R (>= 3.4.0), Formula (>= 1.2-3), plotrix Description: Plot model surfaces for a wide variety of models using partial dependence plots and other techniques. Also plot model residuals and other information on the model. Suggests: C50 (>= 0.1.0-24), earth (>= 5.1.2), gbm (>= 2.1.1), glmnet (>= 2.0.5), glmnetUtils (>= 1.0.3), MASS (>= 7.3-51), mlr (>= 2.12.1), neuralnet (>= 1.33), partykit (>= 1.2-2), pre (>= 0.5.0), rpart (>= 4.1-15), rpart.plot (>= 3.0.8) License: GPL-3 URL: http://www.milbo.users.sonic.net NeedsCompilation: no Packaged: 2024-02-26 12:22:22 UTC; milbo Repository: CRAN Date/Publication: 2024-02-26 13:50:06 UTC plotmo/tests/0000755000176200001440000000000014563612461012736 5ustar liggesusersplotmo/tests/test.plotmo.Rout.save0000644000176200001440000000125214563612461017036 0ustar liggesusers > # test.plotmo.R > # This does a basic sanity test of plotmo. > # For more comprehensive tests, see plotmo/inst/slowtests. > library(plotmo) Loading required package: plotrix > library(rpart) > data(kyphosis) > rpart.model <- rpart(Kyphosis~., data=kyphosis) > plotmo(rpart.model, type="vec", trace=1) stats::predict(rpart.object, data.frame[3,3], type="vec") stats::fitted(object=rpart.object) fitted() was unsuccessful, will use predict() instead got model response from model.frame(Kyphosis~Age+Number+Start, data=call$data, na.action="na.pass") plotmo grid: Age Number Start 87 4 13 > plotmo/tests/test.plotmo.R0000644000176200001440000000037512764100512015344 0ustar liggesusers# test.plotmo.R # This does a basic sanity test of plotmo. # For more comprehensive tests, see plotmo/inst/slowtests. library(plotmo) library(rpart) data(kyphosis) rpart.model <- rpart(Kyphosis~., data=kyphosis) plotmo(rpart.model, type="vec", trace=1) plotmo/R/0000755000176200001440000000000014567065443012003 5ustar liggesusersplotmo/R/w1.R0000644000176200001440000002145514566065135012461 0ustar liggesusers# w1.R: plotres functions for the which=1 plot plot_w1 <- function(object, which, # currently used only to get the total nbr of plots (for xlim and ylim) # most of these args are merely for the recursive call to plotres for lm models info, standardize, delever, level, versus, id.n, labels.id, smooth.col, grid.col, do.par, caption, trace, npoints, center, type, nresponse, object.name, SHOWCALL=NA, # this is here to absorb SHOWCALL from dots ...) { if(inherits(object, "train")) { # caret check.is.caret.train.object(object) object <- object[["finalModel"]] # fall through to process the finalModel object } else if(inherits(object, "WrappedModel")) { # mlr package learner.field <- get.learner.field(object) object <- eval(parse(text=sprint("object%s", learner.field))) # fall through to process the learner.model object } if(inherits(object, "lm")) { # check that the model supports hatvalues(), needed for versus=V4LEVER. if(is.try.err(try(hatvalues(object), silent=TRUE))) retval <- list(plotted=FALSE, retval=NULL) else { # do a recursive call to plotres to plot the residuals versus leverage plot if(trace >= 1) printf( "plotres(object, which=3, versus=4, ...) (recursive call for leverage plot)\n") retval <- plotres(object=object, which=W3RESID, info=info, versus=V4LEVER, standardize=standardize, delever=delever, level=level, id.n=id.n, labels.id=labels.id, smooth.col=smooth.col, grid.col=grid.col, do.par=FALSE, caption=caption, trace=if(trace==1) 0 else trace, npoints=npoints, center=center, type=type, nresponse=nresponse, object.name=object.name, ...) } } else # call method function for object retval <- w1(object=object, trace=trace, type=type, nresponse=nresponse, which=which, grid.col=grid.col, ...) draw.caption(caption, ...) # necessary if w1 is only plot called by plotres retval } w1 <- function(object, trace, type, nresponse, which, grid.col, ...) { UseMethod("w1") } w1.default <- function(object, trace, type, nresponse, which, grid.col, ...) { list(plotted=FALSE, retval=NULL) } w1.earth <- function(object, trace, type, nresponse, which, grid.col, ...) { call.earth.modsel(object=object, trace=trace, grid.col=grid.col, ...) } w1.mars <- function(object, trace, type, nresponse, which, grid.col, ...) { # mda::mars, convert first to an earth model if(trace) printf("calling mars.to.earth (needed for the model selection plot)\n") earth.mod <- earth::mars.to.earth(object, trace=trace >= 2) earth.mod <- update(earth.mod, trace=trace >= 2) call.earth.modsel(object=earth.mod, trace=trace, grid.col=grid.col, ...) } # Note that by specifying col and lty in the arg list we drop # them from dots passed to earth_plotmodsel, else get # 'col' matches both the 'col.rsq' and 'col.grsq' arguments. # TODO call.dot should be able to do this dropping for us but currently can't call.earth.modsel <- function(object, trace, grid.col, col=NA, lty=NA, ...) { list(plotted = TRUE, retval = call.dots(earth::earth_plotmodsel, PREFIX="w1.", DROP="*", KEEP="PREFIX,PLOT.ARGS,PLOTMO.ARGS", trace=trace >= 1, force.x=object, grid.col=grid.col, ...)) } w1.rpart <- function(object, trace, type, nresponse, which, grid.col, ...) { if(requireNamespace("rpart.plot", quietly=TRUE)) # plotmo 3.1.5 (aug 2016): use prp not rpart.plot for a more # minimal plot because there isn't much space using (mfrow=c(2,2)) call.w1(rpart.plot::prp, def.box.palette="auto", ..., object=object, trace=trace) else { printf("Please install the \"rpart.plot\" package for better rpart plots.\n") plot(object, compress=TRUE, uniform=TRUE) list(plotted=TRUE, retval=text(object, xpd=NA)) } } w1.tree <- function(object, trace, type, nresponse, which, grid.col, ...) { call.w1(graphics::plot, def.type="uniform", ..., object=object, trace=trace) n <- nrow(object$frame) def.cex <- if(n < 8) 1 else if(n < 20) .9 else .8 call.w1(graphics::text, def.pretty=3, def.digits=3, def.cex=def.cex, ..., object=object, trace=trace) } w1.randomForest <- function(object, trace, type, nresponse, which, grid.col, ...) { call.w1(graphics::plot, ..., def.main=dota("main", DEF="Error vs Number of Trees", ...), object=object, trace=trace) } w1.gbm <- function(object, trace, type, nresponse, which, grid.col, ...) { # # don't allow n.trees argument to prevent a common mistake # if(!is.na(dota("n.trees", EX=0, ...))) # stop0("n.trees is not allowed (please use predict.n.trees)") # don't allow w1.n.trees argument, except w1.n.trees=NA predict.n.trees <- dota("predict.n.trees", DEF=gbm.n.trees(object), ...) w1.n.trees <- dota("w1.n.trees", DEF=predict.n.trees, ...) if(!is.na(w1.n.trees) && w1.n.trees != predict.n.trees) { if(is.na(dota("predict.n.trees", EX=0, ...))) stop0("w1.n.trees is not allowed (please use predict.n.trees)") else stop0("w1.n.trees is not allowed") } check.integer.scalar(w1.n.trees, min=1, max=gbm.n.trees(object), na.ok=TRUE, logical.ok=FALSE, object.name="n.trees") call.w1(plot_gbm, w1.n.trees=w1.n.trees, ..., object=object, trace=trace) } w1.GBMFit <- function(object, trace, type, nresponse, which, grid.col, ...) { w1.gbm(object, trace, type, nresponse, which, grid.col, ...) } w1.cosso <- function(object, trace, type, nresponse, which, grid.col, ...) { call.w1(graphics::plot, def.M=2, ..., object=object, trace=trace) } w1.glmnet <- function(object, trace, type, nresponse, which, grid.col, ...) { call.w1(plot_glmnet, def.xvar="rlambda", def.grid.col=grid.col, force.s=attr(object, "plotmo.s"), force.nresponse=nresponse, ..., object=object, trace=trace) } plot_with_axis_par <- function(object, which, trace, type, ...) { if(length(which) > 1) { # slightly smaller axis annotations to fit all top labels old.cex.axis <- par("cex.axis") on.exit(par(cex.axis=old.cex.axis)) par(cex.axis=min(old.cex.axis, .9)) } call.w1(graphics::plot, ..., object=object, trace=trace) } w1.lars <- function(object, trace, type, nresponse, which, grid.col, ...) { plot_with_axis_par(object, which, trace, type, ...) } w1.sparsenet <- function(object, trace, type, nresponse, which, grid.col, ...) { plot_with_axis_par(object, which, trace, type, ...) } w1.cv.glmnet <- function(object, trace, type, nresponse, which, grid.col, ...) { plot_with_axis_par(object, which, trace, type, ...) } w1.pre <- function(object, trace, type, nresponse, which, grid.col, ...) # pre package { importance <- try(pre::importance(object, plot=FALSE), silent=TRUE) if(is.try.err(importance)) { warning0("pre::importance(pre.object) failed") list(plotted=FALSE, retval=NULL) } else if(NROW(importance$varimps) == 0) # based on code in importance function in pre.R list(plotted=FALSE, retval=NULL) else call.w1(pre::importance, force.plot=TRUE, ..., object=object, trace=trace) } call.w1 <- function(FUNC, ..., object, trace) { keep <- "PREFIX" # drop everything except args matching PREFIX fname <- trunc.deparse(substitute(FUNC)) list(plotted = TRUE, retval = call.dots(FUNC=FUNC, PREFIX="w1.", DROP="*", # drop everything KEEP=keep, # except args matching keep TRACE=trace >= 1, FNAME=fname, force.anon=object, ...)) } # # TODO commented out because plot.C5.0 ignores par settings # w1.C5.0 <- function(object, trace, type, nresponse, which, grid.col, ...) # { # call.w1(graphics::plot, ...) # } # TODO commented out because plot.nn uses grid graphics # which doesn't coexist with base graphics # w1.nn <- function(object, trace, type, nresponse, which, grid.col, ...) # { # rep <- dota("w1.rep", DEF="best", ...) # if(is.null(rep)) # stop0("rep=NULL is not allowed here for plot.nn ", # "(because it invokes dev.new)") # call.w1(plot.nn, def.rep=rep, ..., object=object, trace=trace) # } plotmo/R/residuals.R0000644000176200001440000002017413712116411014104 0ustar liggesusers# residuals.R: plotmo functions for residuals (the residuals, their scale, and name) # "rinfo" is "residual info" plotmo_rinfo <- function(object, type=NULL, residtype=type, nresponse=1, standardize=FALSE, delever=FALSE, trace=0, leverage.msg="returned as NA", expected.levs=NULL, labels.id=NULL, ...) { trace2(trace, "----plotmo_rinfo: plotmo_resids(object, type=\"%s\", nresponse=%s)\n", type, if(is.na(nresponse)) "NA" else if(is.null(nresponse)) "NULL" else paste(nresponse)) # TODO e.g. earth pclass nresp=1, plotmo_y returns pclass1st 0 or 1 but predict is 1, 2, 3 if(!is.na(pmatch(type, "class"))) { # if(inherits(object, "lda") || inherits(object, "qda")) # stopf( # "plotres does not support type=\"class\" for %s objects\n Note: plotmo extends predict.%s internally:\n%s%s\n", # class.as.char(object, TRUE), # class.as.char(object), # " 'type' can be one of c(\"class\", \"posterior\", \"response\")\n", # " This is discussed in the plotmo vignette.") # else stopf( "plotres does not (yet) support type=\"class\" for %s objects\n Try type=\"response\" ?", class.as.char(object, quotify=TRUE)) } # try calling residuals() directly tracex <- if(trace == 1) 0 else trace # already printed call to residuals in plotmo_meta plotmo_resids <- plotmo_resids(object, type, residtype, nresponse=nresponse, trace=tracex, ...) if(!is.null(plotmo_resids)) { resids <- plotmo_resids$resids labs <- plotmo_resids$labs fitted <- plotmo_fitted(object, trace, nresponse, type, ...)$fitted } else { # trace=2 not 1 because we have already printed this message info in plotmo_meta if(trace >= 2) printf("calling predict() because residuals() was unsuccessful\n") fitted <- plotmo_predict(object, newdata=NULL, nresponse, type, expected.levs, trace, inverse.func=NULL, ...)$yhat labs <- rownames(fitted) check.numeric.scalar(nresponse) # nresponse should be specified by now if(nresponse == 1) plotmo_y <- plotmo_y(object, nresponse, trace, nrow(fitted), object$levels) else { # TODO needed for e.g. rpart and lars where y has one col but predict has multiple cols tracex <- if(trace <= 0) -1 else trace # prevent msg in plotmo_nresponse, see note there plotmo_y <- try(plotmo_y(object, nresponse, tracex, nrow(fitted), object$levels), silent=trace == 0) if(is.try.err(plotmo_y)) { trace1(trace, "the call to plotmo_y was unsuccessful with nresponse=%g, trying again with nresponse=1\n", nresponse) nresponse <- 1 plotmo_y <- plotmo_y(object, nresponse, trace, nrow(fitted), object$levels) trace1(trace, "plotmo_y is ok with nresponse forced to 1\n") } } y <- plotmo_y$y resids <- y - fitted colnames(resids) <- "resids" # TODO following will sometimes give the wrong results? if(!is.null(nresponse) && nresponse > NCOL(resids)) { if(trace >= 1) printf( "forcing nresponse %g to 1 because response - fitted has one column\n", nresponse) nresponse <- 1 } resids <- process.y(resids, object, type, nresponse, expected.len=nrow(fitted), expected.levs=expected.levs, trace, "residuals")$y trace2(trace, "generated the residuals using plotmo_predict() and plotmo_y()\n") } scale <- get.resid.scale(object, resids, standardize, delever, trace, leverage.msg) trace2(trace, "----plotmo_rinfo: done\n") if(!is.null(labels.id)) # user specified labels.id? labs <- repl(paste(labels.id), length(resids)) # recycle if necessary list(resids = resids, # numeric vector, standardize and delever not applied labs = labs, # resids names, may be NULL fitted = fitted, # predicted values for newdata=NULL and given type scale = scale$scale, # vector of 1s unless standardize or delever set name = scale$name) # "Residual" or "Delevered Residual" etc. } # return NULL if call to residuals failed plotmo_resids <- function(object, type, residtype, nresponse, trace, ...) { stopifnot.string(type) stopifnot.string(residtype) if(inherits(object, "train")) { # Caret train model. Force use of predict to calculate residuals # instead of residuals(), for consistency with plotmo. if(trace >= 2) printf("inherits(object, \"train\"): plotmo_resids returns NULL\n") return(NULL) } resids <- try(call.dots(stats::residuals, DROP="*", KEEP="PREFIX", # following prevents reprint of residuals msg if fail TRACE=if(trace == 0) -1 else trace, force.object=object, force.type=residtype, ...), silent=trace <= 1) # is.null check is for residuals(glmnet) which silently returns NULL if(is.try.err(resids) || is.null(resids)) return(NULL) if(trace >= 2) print_summary(resids, "residuals is ", details=if(trace>=2) 2 else -1) list(resids = process.y(resids, object, type, nresponse, expected.len=NULL, expected.levs=NULL, trace, "residuals")$y, labs=if(!is.null(names(resids))) names(resids) else rownames(resids)) } get.resid.scale <- function(object, resids, standardize, delever, trace, leverage.msg) { scale <- repl(1, length(resids)) name <- "Residual" standardize <- check.boolean(standardize) if(standardize) { scale <- plotmo_standardizescale(object) name <- "Standardized Residual" } delever <- check.boolean(delever) if(delever) { if(standardize) # don't allow double denormalization stop0("the standardize and delever arguments cannot both be set") hatvalues <- hatvalues1(object, "'delever'") hat1 <- which(hatvalues == 1) if(trace >= 0 && length(hat1) > 0) warnf("response[%s] has a leverage of one and will be %s", paste.c(hat1), leverage.msg) scale <- 1 / sqrt(1 - hatvalues) name <- "Delevered Residual" } # leverages of 1 cause an inf scale, change to NA for easier handling later scale[is.infinite(scale)] <- NA check.vec(scale, "scale", length(resids), na.ok=TRUE) check(scale, "scale", "non-positive value", function(x) { x <= 0 }, na.ok=TRUE) list(scale = scale, name = name) } # scale for standardization, inf if leverage is 1 plotmo_standardizescale <- function(object) { if(inherits(object, "earth")) { if(is.null(object$varmod)) stop0("\"standardize\" is not allowed because\n", "the model was not built with varmod.method") se <- predict(object, type="earth", interval="se") } else if(inherits(object, "rlm")) se <- object$s else if(inherits(object, "glm")) se <- sqrt(summary(object)$dispersion) else if(inherits(object, "lm")) se <- sqrt(deviance(object) / df.residual(object)) else stop0("'standardize' is not yet supported for this object") stopifnot(is.numeric(se)) stopifnot(all(!is.na(se)), all(se > 0)) 1 / (se * sqrt(1 - hatvalues1(object, "'standardize'"))) } hatvalues1 <- function(object, argname) # try hatvalues, specific err msg if fails { hatvalues <- try(hatvalues(object)) if(is.try.err(hatvalues)) stop0(argname, " is not supported for this object ", "(the call to hatvalues failed)") hatvalues } plotmo/R/predict.nn.R0000644000176200001440000000725213304041703014155 0ustar liggesusers# predict.nn.R: plotmo support for the neuralnet package # Note that the neuralnet package is not the V&R nnet package. # # The neuralnet function doesn't save the standard terms etc., so we # have to do things in a slightly non-standard way below. # # The rep argument must be "mean" (return mean of predicted value over all # reps) or "best" (return predicted value on best rep) or a column index # (return predicted value from the given rep), or an integer vector # (return mean of predicted value over the given reps) # # Some of the error tests below may be duplicated in neuralnet::compute, # but we do them here just to be sure and to avoid obscure failures later, # and also to detect if internal implementation of nn objects changes. # # TODO error handling in this function hasn't been completely tested predict.nn <- function(object, newdata=NULL, rep="mean", trace=FALSE, ...) { stop.if.dots(...) # "..." is required for compat with the # generic predict, although we don't use it stopifnot(is.numeric(trace) || is.logical(trace), length(trace) == 1) if(is.null(newdata)) newdata <- object$covariate stopifnot(length(dim(newdata)) == 2) if(NCOL(newdata) != NCOL(object$covariate)) stop0("newdata has ", NCOL(newdata), " columns but original data had ", NCOL(object$covariate), " columns") varnames <- object$model.list$variables if(!is.null(colnames(newdata)) && !is.null(varnames)) { stopifnot(length(colnames(newdata)) == length(varnames)) if(any(colnames(newdata) != varnames)) warning0("colnames(newdata) do not match the ", "colnames of the original data\n", " colnames(newdata): ", paste.trunc(colnames(newdata)), "\n", " colnames(orginal): ", paste.trunc(varnames)) } check.df.numeric.or.logical(newdata) result.matrix <- object$result.matrix if(is.null(result.matrix)) { # following happens if neuralnet() gave warning "algorithm did not converge" stop0("predict.nn: object does not have a result.matrix (did neuralnet converge?)") } stopifnot(length(dim(result.matrix)) == 2) stopifnot(is.character(rep) || is.numeric(rep)) reps <- rep if(is.character(rep)) switch(match.choices(rep[1], c("best", "mean"), "rep"), best = { reps <- which.min(result.matrix["error",]) if(trace) cat("predict.nn: rep = \"best\" is rep =", reps, "\n") }, mean = { reps <- seq_len(NCOL(result.matrix)) if(trace) cat("predict.nn: rep = \"mean\" will take the mean of", length(reps), "reps\n") }) stopifnot(!is.null(reps)) mean.yhat <- rep_len(0, NROW(newdata)) for(rep in reps) { stopifnot(length(rep) == 1, floor(rep) == rep, rep >= 1, rep <= NCOL(result.matrix)) yhat <- neuralnet::compute(x=object, covariate=newdata, rep=rep)$net.result stopifnot(NROW(yhat) == NROW(newdata)) mean.yhat <- mean.yhat + yhat } mean.yhat / length(reps) } # plotmo method for predict.nn # this wrapper is used merely to pass trace.call.global to predict.nn plotmo.predict.nn <- function(object, newdata, type, ..., TRACE, FUNC=NULL) { # the following invokes predict.nn plotmo.predict.default(object, newdata, # type arg is unused trace=trace.call.global >= 1, ..., TRACE=TRACE) } plotmo/R/gbm.backcompat.R0000644000176200001440000001151514566064465015003 0ustar liggesusers# gbm.backcompat.R: # # TODO change name of this module? this is actually for new functions (not back compat funcs) # # The following functions were added in Oct 2016 for # Paul Metcalfe's changes to gbm (version 2.2 and higher). # # The idea is that we work with both the old and the new gbm models, and # give error messages appropriate to the object (not to an object # converted by to_old_gbm). plotmo.prolog.GBMFit <- function(object, ...) { if(is.null(object$gbm_data_obj)) stop0("use keep_gbm_data=TRUE in the call to gbmt ", "(object$gbm_data_obj is NULL)") # "importance" is a vector of variable indices (column numbers in x), most # important vars first, no variables with relative.influence < 1%. We attach # it to the object to avoid calling summary.gbm twice (it's expensive). attr(object, "plotmo.importance") <- order.GBMFit.vars.on.importance(object) object } order.GBMFit.vars.on.importance <- function(object) { # order=FALSE so importances correspond to orig variable indices importance <- summary(object, plot_it=FALSE, # calls summary.GBMFit order=FALSE, normalize=TRUE)$rel_inf stopifnot(!is.null(importance)) # NA assignment below so order() drops vars with importance < .01 importance[importance < .01] <- NA importance <- order(importance, decreasing=TRUE, na.last=NA) # return a vector of variable indices, most important vars first importance[!is.na(importance)] } plotmo.singles.GBMFit <- function(object, x, nresponse, trace, all1, ...) { plotmo.singles.gbm(object, x, nresponse, trace, all1, ...) } plotmo.pairs.GBMFit <- function(object, ...) { plotmo.pairs.gbm(object, ...) } plotmo.x.GBMFit <- function(object, ...) { plotmo_x_gbm_aux(object$gbm_data_obj$x, object$gbm_data_obj$x_order, object$variables$var_levels) } plotmo.y.GBMFit <- function(object, ...) { plotmo_y_gbm_aux(object$gbm_data_obj$y, object$gbm_data_obj$x_order) } plotmo.predict.GBMFit <- function(object, newdata, type, ..., TRACE) { plotmo.predict.gbm(object, newdata, type, ..., TRACE=TRACE) } gbm.short.distribution.name <- function(obj) { substr(tolower(obj$distribution$name), 1, 2) } gbm.n.trees <- function(obj) { ncol.fit <- NCOL(obj[["fit"]]) stopifnot(ncol.fit >= 1) # paranoia n.trees <- length(obj$trees) / ncol.fit if(!is.null(obj$n.trees)) stopifnot(obj$n.trees == n.trees) # paranoia n.trees } gbm.train.fraction <- function(obj) { train.fraction <- if(is.null(obj$train.fraction)) { # TODO following returns the wrong results # obj$params$train_fraction # TODO work around if(is.null(obj$gbm_data_obj)) stop0("use keep_gbm_data=TRUE in the call to gbmt ", "(obj$gbm_data_obj is NULL)") stopifnot(!is.null(obj$gbm_data_obj$original_data)) train.fraction <- obj$params$num_train / NROW(obj$gbm_data_obj$original_data) # check.numeric.scalar(train.fraction, min=0, max=1) # stopifnot(train.fraction > 0) train.fraction } else obj$train.fraction check.numeric.scalar(train.fraction, min=0, max=1) train.fraction } gbm.bag.fraction <- function(obj) { bag.fraction <- if(is.null(obj$bag.fraction)) obj$params$bag_fraction else obj$bag.fraction check.numeric.scalar(bag.fraction, min=0, max=1) bag.fraction } gbm.cv.folds <- function(obj) { cv.folds <- if(is.null(obj$cv.folds)) obj$cv_folds else obj$cv.folds check.numeric.scalar(cv.folds, min=1, null.ok=TRUE) cv.folds } gbm.train.error <- function(obj) { train.error <- obj$train.error stopifnot(!is.null(train.error)) stopifnot(is.numeric(train.error)) stopifnot(length(train.error) == gbm.n.trees(obj)) train.error } gbm.valid.error <- function(obj) { valid.error <- obj$valid.error if(!is.null(valid.error)) { stopifnot(is.numeric(valid.error)) stopifnot(length(valid.error) == gbm.n.trees(obj)) } valid.error } gbm.oobag.improve <- function(obj) { oobag.improve <- obj$oobag.improve if(!is.null(oobag.improve)) { stopifnot(is.numeric(oobag.improve)) stopifnot(length(oobag.improve) == gbm.n.trees(obj)) } oobag.improve } gbm.cv.error <- function(obj) { cv.error <- if(is.null(obj$cv.error)) obj$cv_error else obj$cv.error if(!is.null(cv.error)) { stopifnot(is.numeric(cv.error)) stopifnot(length(cv.error) == gbm.n.trees(obj)) } cv.error } plotmo/R/methods.R0000644000176200001440000002773213722436165013577 0ustar liggesusers# methods.R: plotmo method functions for miscellaneous objects plotmo.x.mars <- function(object, trace, ...) # mda package { # like plotmo.x.default but ignore object$x get.x.or.y(object, "x", trace, try.object.x.or.y=FALSE) } plotmo.type.bruto <- function(object, ..., TRACE) "fitted" plotmo.predict.bruto <- function(object, newdata, type, ..., TRACE) # mda package { # TODO fails: predict.bruto returned a response of the wrong length plotmo.predict.defaultm(object, newdata, type=type, ..., TRACE=TRACE) } plotmo.type.clm <- function(object, ..., TRACE) "prob" # ordinal package plotmo.predict.clm <- function(object, newdata, type, ..., TRACE) # ordinal package { as.data.frame(plotmo.predict.default(object, newdata, type=type, ..., TRACE=TRACE)) } plotmo.type.lars <- function(object, ..., TRACE) "fit" plotmo.predict.lars <- function(object, newdata, type, ..., TRACE) # lars package { # newx for predict.lars must be a matrix not a dataframe, # so here we use plotmo.predict.defaultm (not plotmo.predict.default) plotmo.predict.defaultm(object, newdata, type=type, ..., TRACE=TRACE)$fit } plotmo.predict.mvr <- function(object, newdata, type, ..., TRACE) # pls package { # the following calls predict.mvr y <- plotmo.predict.default(object, newdata, type=type, ..., TRACE=TRACE) dim <- dim(y) if(length(dim) == 3) { # type="response" returns a 3 dimensional array if(dim[2] != 1) stop0("multiple response models are not supported") y <- y[,1,] } y } plotmo.predict.quantregForest <- function(object, newdata, ..., TRACE) { # the following calls predict.quantregForest plotmo.predict.default(object, newdata, def.quantiles=.5, ..., TRACE=TRACE) } # plotmo.type.cosso works only if before calling plotmo # you manually do class(cosso.object) <- "cosso" plotmo.type.cosso <- function(object, ..., TRACE) "fit" # cosso package plotmo.predict.cosso <- function(object, newdata, type, ..., TRACE) { # xnew for predict.cosso must be a matrix not a dataframe, # so here we use plotmo.predict.defaultm (not plotmo.predict.default). # We default M so first time users can call plotmo easily. yhat <- plotmo.predict.defaultm(object, newdata, type=type, def.M=min(ncol(newdata), 2), ..., TRACE=TRACE) stopifnot(NCOL(yhat) == 1) # class(yhat) is "predict.cosso" but that chokes as.data.frame later class(yhat) <- "vector" yhat } plotmo.type.lda <- function(object, ..., TRACE) "class" plotmo.type.qda <- function(object, ..., TRACE) "class" plotmo.predict.lda <- function(object, newdata, type, ..., TRACE) # MASS package { # the following calls predict.lda yhat <- plotmo.predict.default(object, newdata, ..., TRACE=TRACE) get.lda.yhat(object, yhat, type, trace=0) } plotmo.predict.qda <- function(object, newdata, type, ..., TRACE) # MASS package { # the following calls predict.qda yhat <- plotmo.predict.default(object, newdata, ..., TRACE=TRACE) get.lda.yhat(object, yhat, type, trace=0) } # Special handling for MASS lda and qda predicted response, which # is a data.frame with fields "class", "posterior", and "x". # Here we use plotmo's type argument to choose a field. get.lda.yhat <- function(object, yhat, type, trace) { yhat1 <- switch(match.choices(type, c("class", "posterior", "response", "ld"), "type"), class = yhat$class, # default posterior = yhat$posterior, response = yhat$x, ld = { warning0("type=\"ld\" is deprecated for lda and qda models"); yhat$x }) if(is.null(yhat1)) { msg <- paste0( if(!is.null(yhat$x)) "type=\"response\" " else "", if(!is.null(yhat$class)) "type=\"class\" " else "", if(!is.null(yhat$posterior)) "type=\"posterior\" " else "") stop0("type=\"", type, "\" is not allowed for predict.", class(object)[1], ". ", if(nzchar(msg)) paste("Use one of:", msg) else "", "\n") } yhat1 } plotmo.type.varmod <- function(object, ..., TRACE) "se" plotmo.x.varmod <- function(object, trace, ...) { attr(object$parent, ".Environment") <- get.model.env(object$parent, "object$parent", trace) plotmo.x(object$parent, trace) } plotmo.y.varmod <- function(object, trace, naked, expected.len, nresponse, ...) { attr(object$residmod, ".Environment") <- get.model.env(object$residmod, "object$residmod", trace) plotmo.y(object$residmod, trace, naked, expected.len, nresponse) } order.randomForest.vars.on.importance <- function(object, x, trace) { importance <- object$importance colnames <- colnames(importance) if(!is.matrix(importance) || # sanity checks nrow(importance) == 0 || !identical(row.names(importance), colnames(x)) || is.null(colnames)) { warning0("object$importance is invalid") return(NULL) } colname <- if("%IncMSE" %in% colnames) # regression model: "%IncMSE" # importance=TRUE else if("IncNodePurity" %in% colnames) "IncNodePurity" # importance=FALSE else if("MeanDecreaseAccuracy" %in% colnames) # classification model: "MeanDecreaseAccuracy" # importance=TRUE else if("MeanDecreaseGini" %in% colnames) "MeanDecreaseGini" # importance=FALSE else { warning0("column names of object$importance are unrecognized") return(NULL) } if(trace > 0) printf("randomForest built with importance=%s, ranking variables on %s\n", if(colname == "%IncMSE" || colname == "MeanDecreaseAccuracy") "TRUE" else "FALSE", colname) # vector of var indices, most important vars first order(importance[,colname], decreasing=TRUE) } plotmo.singles.randomForest <- function(object, x, nresponse, trace, all1, ...) { importance <- order.randomForest.vars.on.importance(object, x, trace) if(all1) return(importance) if(is.null(importance)) seq_len(NCOL(x)) # all variables # 10 most important variables # (10 becauses plotmo.pairs returns 6, total is 16, therefore 4x4 grid) importance[seq_len(min(10, length(importance)))] } plotmo.pairs.randomForest <- function(object, x, ...) { if(is.null(object$forest)) stop0("object has no 'forest' component ", "(use keep.forest=TRUE in the call to randomForest)") importance <- order.randomForest.vars.on.importance(object, x, trace=FALSE) if(is.null(importance)) return(NULL) # choose npairs so a total of no more than 16 plots # npairs=5 gives 10 pairplots, npairs=4 gives 6 pairplots npairs <- if(length(importance) <= 6) 5 else 4 form.pairs(importance[1: min(npairs, length(importance))]) } possible.biglm.warning <- function(object, trace) { if(inherits(object, "biglm")) { n <- check.integer.scalar(object$n, min=1) y <- plotmo.y.default(object, trace, naked=TRUE, expected.len=NULL)$field if(NROW(y) != n) warnf("plotting %g cases but the model was built with %g cases\n", NROW(y), n) } } plotmo.predict.biglm <- function(object, newdata, type, ..., TRACE) # biglm package { # predict.biglm: newdata must include the response even though it isn't needed # The following extracts the response from the formula, converts it to a # string, then "nakens" it (converts e.g. "log(Volume)" to plain "Volume"). resp.name <- naken.collapse(format(formula(object)[[2]])) if(TRACE >= 1) printf("plotmo.predict.biglm: adding dummy response \"%s\" to newdata\n", resp.name) data <- data.frame(NONESUCH.RESPONSE=1, newdata) colnames(data) <- c(resp.name, colnames(newdata)) plotmo.predict.default(object, data, type=type, ..., TRACE=TRACE) } plotmo.predict.boosting <- function(object, newdata, # adabag package type="prob", newmfinal=length(object$trees), ...) { stopifnot(inherits(object, "boosting") || inherits(object, "bagging")) predict <- predict(object, newdata=newdata, newmfinal=newmfinal, ...) # adabag (version 4.0) returns a list, so use the type arg to select what we want # note that data.frames are lists, hence must check both below if(is.list(predict) && !is.data.frame(predict)) predict <- switch(match.arg(type, c("response", "votes", "prob", "class")), response = predict$prob, # plotmo default, same as prob votes = predict$votes, prob = predict$prob, class = predict$class) stopifnot(!is.null(predict), NROW(predict) == NROW(newdata)) predict } plotmo.predict.bagging <- function(object, newdata, # adabag package type="prob", newmfinal=length(object$trees), ...) { plotmo.predict.boosting(object, newdata=newdata, type=type, newmfinal=newmfinal, ...) } plotmo.predict.svm <- function(object, newdata, type, ..., TRACE) # package e1071 { # treat warnings as errors (to catch if user didn't specify # probability when building the model) old.warn <- getOption("warn") on.exit(options(warn=old.warn)) options(warn=2) predict <- plotmo.predict.default(object, newdata=newdata, ..., TRACE=TRACE) # no type arg probabilities <- attr(predict, "probabilities") decision.values <- attr(predict, "decision.values") if(!is.null(decision.values) && !is.null(probabilities)) stop0("predict.svm: specify either 'decision.values' or 'probability' (not both)") if(!is.null(decision.values)) # user specified decision.values decision.values else if(!is.null(probabilities)) # user specified probability probabilities else predict } plotmo.prolog.model_fit <- function(object, object.name, trace, ...) # parsnip package { # sanity check: that it is indeed a parnsip model if(!is.list(object[["spec"]]) || !is.list(object[["fit"]])) stop0("unrecognized \"model_fit\" object (was expecting a parsnip model)") # USE.SUBMODEL is an undocumented plotmo dots argument, default is TRUE # TODO this is supposed to be temporary solution use.submodel <- dota("USE.SUBMODEL", DEF=TRUE, ...) if(is.specified(use.submodel)) object$fit else object } # TODO Following commented out because polyreg is not supported by plotmo # So with this commented out we support plotmo(fda.object) # but not plotmo(fda.object$fit). # If it were not commented out, we would support neither. # # plotmo.singles.fda <- function(object, x, nresponse, trace, all1, ...) # { # trace2(trace, "Invoking plotmo_x for embedded fda object\n") # x <- plotmo_x(object$fit, trace) # plotmo.singles(object$fit, x, nresponse, trace, all1) # } # plotmo.pairs.fda <- function(object, x, nresponse, trace, all2, ...) # { # trace2(trace, "Invoking plotmo_x for embedded fda object\n") # x <- plotmo_x(object$fit, trace) # plotmo.pairs(object$fit, x, nresponse, trace, all2) # } # # Simple interface for the AMORE package. # # Thanks to Bernard Nolan and David Lorenz for these. # # Commented out so we don't have to include AMORE in plotmo's DESCRIPTION file. # # plotmo.x.MLPnet <- function(object, ...) # { # get("P", pos=1) # } # plotmo.y.MLPnet <- function(object, ...) # { # get("T", pos=1) # } # plotmo.predict.MLPnet <- function(object, newdata, type, ..., TRACE) # { # # the following calls AMORE::sim.MLPnet # plotmo.predict.default(object, newdata, func=AMORE::sim.MLPnet, ..., TRACE=TRACE) # } plotmo/R/plotres.R0000644000176200001440000002506213727275351013621 0ustar liggesusers# plotres.R: plot model residuals # values for which W1 <- 1 # model selection W2CUM <- 2 # cumulative distribution W3RESID <- 3 # residuals vs fitted W4QQ <- 4 # qq plot W5ABS <- 5 # abs residuals vs fitted W6SQRT <- 6 # sqrt abs residuals vs fitted W7VLOG <- 7 # abs residuals vs log fitted W8CUBE <- 8 # cube root of the squared residuals vs log fitted W9LOGLOG <- 9 # log abs residuals vs log fitted # values for vs V1FITTED <- 1 # fitted V2INDEX <- 2 # obs number V3RESPONSE <- 3 # response V4LEVER <- 4 # leverages plotres <- function(object = stop("no 'object' argument"), which = 1:4, info = FALSE, versus = 1, standardize = FALSE, delever = FALSE, level = 0, id.n = 3, labels.id = NULL, smooth.col = 2, grid.col = 0, jitter = 0, do.par = NULL, caption = NULL, trace = 0, npoints = 3000, center = TRUE, type = NULL, # passed to predict nresponse = NA, object.name = quote.deparse(substitute(object)), ...) # passed to predict { init.global.data() on.exit({init.global.data(); gc()}) # release memory on exit object # make sure object exists trace <- as.numeric(check.integer.scalar(trace, logical.ok=TRUE)) use.submodel <- dota("USE.SUBMODEL", DEF=TRUE, ...) # undoc arg (for parsnip models) use.submodel <- is.specified(use.submodel) # Associate the model environment with the object. # (This is instead of passing it as an argument to plotmo's data access # functions. It saves a few hundred references to model.env in the code.) object.env <- get.model.env(object, object.name, trace, use.submodel) ret <- plotmo_prolog(object, object.name, trace, ...) object <- ret$object # the original object or a submodel (parsnip) my.call <- ret$my.call attr(object, ".Environment") <- object.env if(!is.numeric(which) || !is.vector(which) || anyNA(which) || any(which != floor(which)) || any(which < 1) || any(which > W9LOGLOG)) { which.err() } info <- check.boolean(info) standardize <- check.boolean(standardize) delever <- check.boolean(delever) level <- check.level.arg(level, zero.ok=TRUE) smooth.col <- get.smooth.col(smooth.col, ...) grid.col <- dota("col.grid", DEF=grid.col, ...) if(is.specified(grid.col) && is.logical(grid.col) && grid.col) # grid.col=TRUE grid.col <- "lightgray" check.integer.scalar(nresponse, min=1, na.ok=TRUE, logical.ok=FALSE, char.ok=TRUE) temp <- get.plotres.data(object, object.name, which, standardize, delever, level, versus, id.n, labels.id, trace, npoints, type, nresponse, ..., must.get.rsq=info || trace >= 1) # get rsq only if necessary nresponse <- temp$nresponse # col index in the response (converted from NA if necessary) resp.name <- temp$resp.name # used only in automatic caption, may be NULL type <- temp$type # always a string (converted from NULL if necessary) rinfo <- temp$rinfo # resids, scale, name, etc. vinfo <- temp$vinfo # versus.mat, icolumns, nversus, etc. fitted <- temp$fitted # n x 1 numeric matrix, colname is "Fitted" which <- temp$vinfo$which # plots we don't want will have been removed id.n <- temp$id.n # forced to zero if row indexing changed npoints <- temp$npoints # special values have been converted rsq <- temp$rsq # r-squared on the training data possible.biglm.warning(object, trace) nfigs <- length(which) * length(vinfo$icolumns) if(nfigs == 0) { if(trace >= 0) warning0("plotres: nothing to plot") return(invisible(NULL)) } do.par <- check.do.par(do.par, nfigs) # do.par is 0, 1, or 2 # Prepare caption --- we need it now for do.par() but # can only display it later after at least one plot. caption <- get.caption(nfigs, do.par, caption, resp.name, type, getCall(object), object.name, my.call) if(do.par) { oldpar <- par(no.readonly=TRUE) do.par(nfigs = nfigs, caption=caption, main1=NA, # nlines.in.main below explicitly specified below xlab1 = dota("xlab", DEF=NULL, ...), # used only for margin spacing ylab1 = dota("ylab", DEF=NULL, ...), # ditto trace = trace, nlines.in.main = # nbr of lines in main is needed for margins nlines.in.plotres.main(object=object, which=which, versus=versus, standardize=standardize, delever=delever, level=level, ...), def.font.main = 1, # for compat with lm.plot ...) if(do.par == 1) on.exit(par(oldpar), add=TRUE) } else { # do.par=FALSE oldpar <- do.par.dots(..., trace=trace) if(length(oldpar)) on.exit(do.call(par, oldpar), add=TRUE) } # force.auto.resids.xlim is for back compat with old versions of earth. # To pass ylim to the w1 plot, use a w1. prefix, just like any other arg. # So plain ylim gets passed to the residuals plot not the w1 plot. # But for backwards compatibility when the w1 plot is # an earth model pass plain ylim to the w1 plot unless w1.ylim is set force.auto.resids.xlim <- length(which) > 1 && (W1 %in% which) && inherits(object, "earth") && !is.dot("w1.xlim", ...) force.auto.resids.ylim <- length(which) > 1 && (W1 %in% which) && inherits(object, "earth") && !is.dot("w1.ylim", ...) w1.retval <- list(plotted=FALSE, retval=NULL) w3.retval <- NULL attempted.w1.plot <- FALSE if(any(which == W1)) { w1.retval <- plot_w1(object=object, which=which, info=info, standardize=standardize, delever=delever, level=level, versus=versus, id.n=id.n, labels.id=rinfo$labs, smooth.col=smooth.col, grid.col=grid.col, do.par=do.par, # must do caption here if will not call plot1 later caption=if(all(which == W1)) caption else "", trace=trace, npoints=npoints, center=center, type=type, nresponse=nresponse, object.name=object.name, ...) attempted.w1.plot <- TRUE which <- which[which != W1] if(length(which) == 0 && !w1.retval$plotted && trace >= 0) warning0("plotres: nothing to plot") } if(length(which) == 0) # nothing more to plot? return(invisible(if(attempted.w1.plot) w1.retval$retval else w3.retval)) # we do this after the w1 call so we pass NULL to w1 if labels.id were NULL if(is.null(rinfo$labs)) rinfo$labs <- paste(1:length(rinfo$resids)) # We plot only the residuals in iresids, but use all the # residuals for calculating densities (where "all" actually means # a maximum of NMAX cases, see the previous call to get.isubset). # # The "use.all=(nversus == V4LEVER)" keeps things easier later # for leverage plots, but it would be nice to not have to use it. iresids <- get.isubset(rinfo$resids, npoints, id.n, use.all=(vinfo$nversus == V4LEVER), rinfo$scale) xlim <- dota("xlim", DEF=NULL, ...) # TODO what is this? for(icolumn in vinfo$icolumns) { for(iwhich in seq_along(which)) { if(which[iwhich] == W2CUM) plotmo_cum(rinfo=rinfo, info=info, nfigs=nfigs, add=FALSE, cum.col1=NA, grid.col=grid.col, jitter=0, ...) else if(which[iwhich] == W4QQ) plotmo_qq(rinfo=rinfo, info=info, nfigs=nfigs, grid.col=grid.col, smooth.col=smooth.col, id.n=id.n, iresids=iresids, npoints=npoints, force.auto.resids.ylim=force.auto.resids.ylim, ...) else w3.retval <- plotresids(object=object, which=which[iwhich], info=info, standardize=standardize, level=level, # versus1 is what we plot along the x axis, a vector versus1=vinfo$versus.mat[, icolumn], id.n=id.n, smooth.col=smooth.col, grid.col=grid.col, jitter=jitter, npoints=npoints, center=center, type=type, fitted=fitted, rinfo=rinfo, rsq=rsq, iresids=iresids, nversus=vinfo$nversus, colname.versus1=colnames(vinfo$versus.mat)[icolumn], force.auto.resids.xlim=force.auto.resids.xlim, force.auto.resids.ylim=force.auto.resids.ylim, ...) } } draw.caption(caption, ...) if(trace >= 1) printf("\ntraining rsq %.2f\n", rsq) invisible(if(attempted.w1.plot) w1.retval$retval else w3.retval) } which.err <- function() { stop0("Bad value for which\n", "Allowed values for which:\n", " 1 Model\n", " 2 Cumulative distribution\n", " 3 Residuals vs fitted\n", " 4 QQ plot\n", " 5 Abs residuals vs fitted\n", " 6 Sqrt abs residuals vs fitted\n", " 7 Abs residuals vs log fitted\n", " 8 Cube root of the squared residuals vs log fitted\n", " 9 Log abs residuals vs log fitted") } versus.err <- function() { stop0("versus must be an integer or a string:\n", " 1 fitted (default)\n", " 2 observation numbers\n", " 3 response\n", " 4 leverages\n", " \"\" predictors\n", " \"b:\" basis functions") } nlines.in.plotres.main <- function(object, which, versus, standardize, delever, level, ...) { w1.does.own.mar4 <- # these models do their own top margin spacing in w1 plot inherits(object, c("gbm", "GBMFit", "glmnet", "multnet")) auto.main.has.extra.line <- # conservative guess if main will have two lines standardize || delever || level || any(which %in% W6SQRT:W9LOGLOG) || (versus %in% V4LEVER) || is.character(versus) max(1 + auto.main.has.extra.line, nlines(dota("main", ...)), 1 + if(w1.does.own.mar4) 0 else nlines(dota("w1.main", ...))) } plotmo/R/stop.if.dots.R0000644000176200001440000000306514055553444014457 0ustar liggesusers# stop.if.dots.R: # stop.if.dots issues an an error message if any args in dots. # We use it to test if any dots arg of the calling function was used, for # functions that must have a dots arg (to match the generic method) but don't # actually use the dots. This helps the user catch mistyped or illegal args. stop.if.dots <- function(...) { dots <- match.call(expand.dots=FALSE)$... if(length(dots)) dots.used.err(STOPFUNC=base::stop, MSG=": unrecognized", ...) } warn.if.dots <- function(...) { dots <- match.call(expand.dots=FALSE)$... if(length(dots)) dots.used.err(STOPFUNC=base::warning, MSG=" ignored", ...) } dots.used.err <- function(..., STOPFUNC, MSG) # utility for stop.if.dots and friends { callers.name <- callers.name(n=2) dots <- match.call(expand.dots=FALSE)$... for(idot in seq_along(dots)) # STOPFUNC is either stop() or warning() { desc <- describe.dot(dots, idot) STOPFUNC(callers.name, MSG, desc, call.=FALSE) } } describe.dot <- function(dots, idot, n=4) # utility for dots.used.err { nchar <- nchar(names(dots)[idot]) if(length(nchar) && nchar > 0) return(sprint(" argument '%s'", names(dots[idot]))) # the argument that was passed in dots is unnamed call <- call.as.char(n=4) # n=4 to describe call to caller of stop.if.dots sprint(" unnamed argument\n The call was %s", paste0(strwrap(call, width=max(40, max(25, getOption("width")-20)), exdent=25), collapse="\n")) } plotmo/R/quantreg.R0000644000176200001440000000572613304041703013743 0ustar liggesusers# quantreg.R: plotmo method functions for the quantreg package # # Currently we support only rq (which for some reason returns objects of # class "rqs", so we need to support both "rq" and"rqs") plotmo.predict.rq <- function(object, newdata, type, ..., TRACE) { if(type != "response") warning0("plotmo.predict.rq: ignored type=\"", type, "\"") if(is.null(object$tau)) stop0("rq object has no 'tau' field") # The following invokes predict.rq or predict.rqs. It may return multiple # responses, which are handled later in plotmo.convert.na.nresponse.rq. yhat <- plotmo.predict.default(object, newdata, type="none", ..., TRACE=TRACE) } plotmo.predict.rqs <- function(object, newdata, type, ..., TRACE) { plotmo.predict.rq(object, newdata, type, ..., TRACE=TRACE) } # quantreg::predict.rq returns a column for each value in the tau arg # in the call to rq. Select the column corresponding to tau=.5 plotmo.convert.na.nresponse.rq <- function(object, nresponse, yhat, type, ...) { if(NCOL(yhat) == 1) nresponse <- 1 else { nresponse <- which(abs(object$tau - .5) < 1e-8) if(length(nresponse) == 0) { # no tau=.5? nresponse <- length(object$tau) %/% 2 warning0( "rq object has multiple taus, none are tau=.5, so plotting tau=", object$tau[nresponse]) } nresponse <- nresponse[1] # needed if tau=.5 specified twice in call to rq } nresponse } plotmo.convert.na.nresponse.rqs <- function(object, nresponse, yhat, type, ...) { plotmo.convert.na.nresponse.rq(object, nresponse, yhat, type) } plotmo.pint.rq <- function(object, newdata, type, level, ...) # quantreg package { if(length(object$tau) == 1) stop0("object was built with single tau (tau=", object$tau, ")\n", "Plotmo needs multiple taus to plot confidence bands, ", "something like tau=c(.05,.5,.95)") q0 <- (1 - level) / 2 # .95 becomes .025 q1 <- 1 - q0 # .975 tau <- object$tau i0 <- which(abs(tau - q0) < 1e-8) # 1e-8 allows limited precision i1 <- which(abs(tau - q1) < 1e-8) if(length(i0) == 0 || length(i1) == 0) { i0 <- 1 i1 <- length(tau) warning0( "You specified level=", level, " but rq was called with tau=", if(length(tau) == 1) tau else sprint("c(%s)", paste(tau, collapse=", ")), "\n Try plotmo level=", 1 - 2 * tau[1], " to make this warning go away", "\n Continuing anyway, with confidence bands for tau=", tau[i0], " and ", tau[i1]) } predict <- predict(object, newdata=newdata, type="none") data.frame(lwr = predict[,i0], upr = predict[,i1]) } plotmo.pint.rqs <- function(object, newdata, type, level, ...) # quantreg package { plotmo.pint.rq(object, newdata, type, level) } plotmo/R/plot_gbm.R0000644000176200001440000003404514563612461013731 0ustar liggesusers# plot_gbm.R: plot gbm models # # This code is derived from code in gbm 2.1.1 (Aug 2016). # # TODO when selecting best n.trees, why is OOB smoothed but not test or CV? # TODO maybe add arg to rescale errs e.g. RSquared rather than Squared Error # TODO add right hand axis for OOB, or scale OOB to same units when possible? # TODO if gbm calculated CV stddev across folds then we could plot CV conf bands plot_gbm <- function(object=stop("no 'object' argument"), smooth = c(0, 0, 0, 1), col = c(1, 2, 3, 4), ylim = "auto", legend.x = NULL, legend.y = NULL, legend.cex = .8, grid.col = NA, n.trees = NA, col.n.trees ="darkgray", ...) { # GBMFit was added in Oct 2016 for Paul Metcalfe's changes to gbm (version 2.2) check.classname(object, "object", c("gbm", "GBMFit")) obj <- object if((!is.numeric(smooth) && !is.logical(smooth)) || any(smooth != 0 & smooth != 1)) stop0("smooth should be a four-element vector specifying if train, ", "test, CV, and OOB curves are smoothed, e.g. smooth=c(0,0,0,1)") smooth <- rep_len(smooth, 4) # recycle smooth if necessary col <- rep_len(col, 4) # recycle col if necessary col[is.na(col)] <- 0 # make using col below a bit easier check.integer.scalar(n.trees, min=1, max=n.trees, na.ok=TRUE, logical.ok=FALSE) n.alltrees = gbm.n.trees(obj) # final.max is max of values on the right of the curves (excluding OOB) train.error <- gbm.train.error(obj) valid.error <- gbm.valid.error(obj) cv.error <- gbm.cv.error(obj) final.max <- max(train.error[length(train.error)], valid.error[length(valid.error)], cv.error [length(cv.error)], na.rm=TRUE) if(any1(col)) { # must anything be plotted? par <- par("mar", "mgp") # will be modified in init.gbm.plot on.exit(par(mar=par$mar, mgp=par$mgp)) init.gbm.plot(obj, ylim, final.max, par$mar, ...) if(is.specified(grid.col[1])) grid(col=grid.col[1], lty=3) # draw n.trees vertical gray line first, so other plots go on top of it if(is.specified(n.trees)) vertical.line(n.trees, col.n.trees, 1, 0) } leg.text <- leg.col <- leg.lty <- leg.vert <- leg.imin <- NULL # for legend voffset <- 0 # slight offset to prevent overplotting of dotted vertical lines # train curve y <- maybe.smooth(train.error, "train", smooth[1], n.alltrees) imin <- which.min1(y) # index of minimum train error imins <- c(imin, 0, 0, 0) # index of train, test, CV, OOB minima names(imins) <- c("train", "test", "CV", "OOB") train.fraction <- gbm.train.fraction(obj) if(is.specified(col[1])) { lines(y, col=col[1]) leg.text <- c(leg.text, if(train.fraction == 1) "train" else sprint("train (frac %g)", train.fraction)) leg.col <- c(leg.col, col[1]) leg.lty <- c(leg.lty, 1) leg.vert <- c(leg.vert, FALSE) leg.imin <- imin } # test curve (aka valid.error curve) if(train.fraction != 1) { y <- maybe.smooth(valid.error, "test", smooth[2], n.alltrees) imin <- imins[2] <- which.min1(y) if(is.specified(col[2])) { if(imin) vertical.line(imin, col[2], 3, voffset) voffset <- voffset + 1 lines(y, col=col[2]) leg.text <- c(leg.text, if(!imin) "test not plotted" else sprint("test (frac %g)", 1-train.fraction)) leg.col <- c(leg.col, col[2]) leg.lty <- c(leg.lty, 1) leg.vert <- c(leg.vert, FALSE) leg.imin <- c(leg.imin, imin) } } # CV curve if(!is.null(cv.error)) { y <- maybe.smooth(cv.error, "CV", smooth[3], n.alltrees) imin <- imins[3] <- which.min1(y) if(is.specified(col[3])) { if(imin) vertical.line(imin, col[3], 3, voffset) voffset <- voffset + 1 lines(y, col=col[3]) leg.text <- c(leg.text, if(!imin) "CV not plotted" else sprint("CV (%g fold)", gbm.cv.folds(obj))) leg.col <- c(leg.col, col[3]) leg.lty <- c(leg.lty, 1) leg.vert <- c(leg.vert, FALSE) leg.imin <- c(leg.imin, imin) } } # OOB curve bag.fraction <- gbm.bag.fraction(obj) if(bag.fraction != 1) { oobag.improve <- gbm.oobag.improve(obj) y <- maybe.smooth(-cumsum(oobag.improve), "OOB", smooth[4], n.alltrees) imin <- imins[4] <- which.min1(y) if(is.specified(col[4])) { if(imin) draw.oob.curve(y, imin, voffset, col[4], smooth, train.error) voffset <- voffset + 1 leg.text <- c(leg.text, if(!imin) "OOB not plotted" else "OOB (rescaled)") leg.col <- c(leg.col, col[4]) leg.lty <- c(leg.lty, 2) leg.vert <- c(leg.vert, FALSE) leg.imin <- c(leg.imin, imin) } } # legend entry for vertical line at n.trees if(is.specified(n.trees)) { leg.text <- c(leg.text, "predict n.trees") leg.col <- c(leg.col, col.n.trees) leg.lty <- c(leg.lty, 1) leg.vert <- c(leg.vert, TRUE) leg.imin <- c(leg.imin, n.trees) } if(any1(col)) { # was anything plotted? box() # replot box because vertical.line overplots it slightly gbm.legend(legend.x, legend.y, legend.cex, leg.text, leg.col, leg.lty, leg.vert, leg.imin) gbm.top.labels(leg.imin, leg.text, leg.col) } invisible(imins) } init.gbm.plot <- function(obj, ylim, final.max, mar, ...) { xlim <- dota("xlim", ...) # get xlim from dots, NA if not in dots n.alltrees <- gbm.n.trees(obj) if(!is.specified(xlim)) xlim <- c(0, n.alltrees) xlim <- fix.lim(xlim) ylim <- get.gbm.ylim(obj, xlim, ylim, final.max) ylab <- get.gbm.ylab(obj) # set mar[3] space for top labels and possibly (user-specified) main main <- dota("main", ...) # get main from dots, NA if not in dots nlines.needed.for.main <- if(is.specified(main)) nlines(main) + .5 else 0 par(mar=c(mar[1], mar[2], max(mar[3], nlines.needed.for.main + 1), mar[4])) par(mgp=c(1.5, .4, 0)) # squash axis annotations # Call graphics::plot but drop args in dots that aren't graphics args # or formal args of graphics::plot. # If argname below is prefixed with force. then ignore any such arg in dots. # Any argname below prefixed with def. can be overridden by a user arg in dots. # force.main="" because we add (user-specified) main manually because top labels. train.error <- gbm.train.error(obj) call.plot(graphics::plot, force.x=1:n.alltrees, force.y=train.error, force.type="n", force.main="", force.xlim=xlim, def.ylim=ylim, def.xlab="Number of Trees", def.ylab=ylab, ...) if(is.specified(main)) mtext(main, side=3, line=1.3, cex=par("cex")) # above top labels } get.gbm.ylim <- function(obj, xlim, ylim, final.max) { train.error <- gbm.train.error(obj) valid.error <- gbm.valid.error(obj) cv.error <- gbm.cv.error(obj) if(is.character(ylim) && substr(ylim[1], 1, 1) == "a") { # auto ylim? imin <- max(1, min(1, xlim[1])) imax <- min(length(train.error), max(length(train.error), xlim[2])) cv.error <- gbm.cv.error(obj) ylim <- range(train.error[imin:imax], valid.error[imin:imax], cv.error [imin:imax], na.rm=TRUE) # decrease ylim[2] to put more resolution in the "interesting" # part of the curve by putting final.max half way up plot ylim[2] <- ylim[1] + 2 * (final.max - ylim[1]) # ensure 75% of training curve is visible # (typically needed when no test or CV curve) i <- floor(xlim[1] + .25 * (xlim[2] - xlim[1])) if(i >= 1 && i <= length(train.error[imin:imax])) ylim[2] <- max(ylim[2], train.error[i]) } else if(!is.specified(ylim)) # ylim=NULL or ylim=NA ylim <- range(train.error, valid.error, cv.error, na.rm=TRUE) fix.lim(ylim) } get.gbm.ylab <- function(obj) { dist <- gbm.short.distribution.name(obj) if(dist =="pa") # pairwise switch(obj$distribution$metric, conc="Fraction of Concordant Pairs", ndcg="Normalized Discounted Cumulative Gain", map ="Mean Average Precision", mrr ="Mean Reciprocal Rank", stop0("unrecognized pairwise metric: ", obj$distribution$metric)) else # not pairwise switch(dist, ga="Squared Error Loss", # gaussian la="Absolute Loss", # laplace td="t-distribution deviance", be="Bernoulli Deviance", # logistic hu="Huberized Hinge Loss", mu="Multinomial Deviance", ad="Adaboost Exponential Bound", ex="Exponential Loss", po="Poisson Deviance", co="Cox Partial Deviance", qu="Quantile Loss", stop0("unrecognized distribution name: ", obj$distribution.name)) } vertical.line <- function(x, col=1, lty=1, voffset=0) # draw a vertical line at x { if(is.specified(col)) { usr <- par("usr") # xmin, xmax, ymin, ymax range <- usr[4] - usr[3] lwd <- 1 if(lty == 3) { # dotted line? # increase lwd to make dotted lines more visible lwd <- min(1.5, 2 * par("cex")) # small vertical offset so multiple dotted lines at same xpos visible voffset <- 0.008 * voffset * range } else voffset <- 0 lines(x=c(x, x), y=c(usr[3], usr[4]) - voffset, col=col, lty=lty, lwd=lwd) lines(x=c(x, x), y=c(usr[3], usr[3] + .02 * range), col=col, lty=1) # tick } } # this returns a single NA if y has non finite values maybe.smooth <- function(y, yname, must.smooth, n.alltrees) { if(any(!is.finite(y))) { # infinities in OOB curve occur with distribution="huberized" warning0("plot_gbm: cannot plot ", yname, " curve (it has some non-finite values)") return(NA) } if(must.smooth) { x <- 1:n.alltrees if(n.alltrees < 10) # loess tends to fail for small n.alltrees, use lowess instead y <- lowess(x, y)$y else # use loess for compatibility with gbm y <- loess(y~x, na.action=na.omit, # paranoia, prevent warnings from loess # enp.target is the same as gbm.perf for compatibility # (this does only minimal smoothing) enp.target=min(max(4, n.alltrees/10), 50))$fitted } y } which.min1 <- function(x) # like which.min but return 0 if x is all NA { if(all(is.na(x))) return(0) which.min(x) } draw.oob.curve <- function(y, imin, voffset, col, smooth, train.error) { stopifnot(!is.na(imin)) vertical.line(imin, col, 3, voffset) # rescale y to fit into plot usr <- par("usr") # xmin, xmax, ymin, ymax y <- y - min(y) y <- y / max(y) # y is now 0..1 e <- train.error n <- length(e) # start and end of OOB curve same as 10% into train curve and end train curve y <- e[n] + (e[max(1, 0.1 * n)] - e[n]) * y lines(1:n, y, col=col, lty=2) } gbm.legend <- function(legend.x, legend.y, legend.cex, leg.text, leg.col, leg.lty, leg.vert, leg.imin) { xjust <- 0 usr <- par("usr") # xmin, xmax, ymin, ymax if(is.null(legend.y)) legend.y <- usr[3] + .65 * (usr[4] - usr[3]) if(is.null(legend.x)) { # Automatically position the legend just to the left of the # leftmost vertical line that is to the right of .7 * usr[2]. # Hopefully that puts it not on top of anything interesting. xjust <- 1 imin <- c(usr[2], leg.imin[which(leg.imin > usr[1] + .7 * (usr[2]-usr[1]))]) legend.x <- min(imin) - .05 * (usr[2] - usr[1]) legend.y <- usr[4] - .05 * (usr[4] - usr[3]) } if(is.specified(legend.x)) elegend(x=legend.x, y=legend.y, legend=leg.text, col=leg.col, lty=leg.lty, vert=leg.vert, # vert is supported by elegend but not by legend bg="white", cex=legend.cex, xjust=xjust, yjust=xjust) } # print the best number-of-trees for each curve along the top of the plot gbm.top.labels <- function(leg.imin, leg.text, leg.col) { # don't print number-of-trees for the training curve stopifnot(substring(leg.text[1], 1, 5) == "train") leg.col[1] <- 0 # darker than darkgray seems needed for top text # to be perceived as darkgray, not sure why leg.col[leg.col == "darkgray"] <- lighten("darkgray", -0.1) usr <- par("usr") # xmin, xmax, ymin, ymax # TODO spread.labs is buggy for horizontal labels (too much space sometimes)? x <- spread.labs(leg.imin,mindiff=par("cex") * max(strwidth(paste0(leg.imin, " "))), min=usr[1], max=usr[2]) # use of "ok" prevents display off the right or left of the plot # (necessary if user specifies xlim) # check against leg.imin is for when which.lim1(NA) returns 0 margin <- .05 * (usr[2] - usr[1]) ok <- (x > usr[1] - margin) & (x < usr[2] + margin) & (leg.imin != 0) if(any(ok)) text(x=x[ok], # this call to text works with call to text in init.gbm.plot y=usr[4] + .4 * strheight("X"), # just above plot labels=leg.imin[ok], col=leg.col[ok], adj=c(.5, 0), # x is middle of text, y is bottom of text xpd=NA) # allow plotting out the plot area } plotmo/R/partykit.R0000644000176200001440000002075213720064757014000 0ustar liggesusers# partykit.R: hackery for plotmo to support the partykit package plotmo.prolog.party <- function(object, object.name, trace, ...) # called when plotmo starts { check.mob.object(object) # Attach plotmo.importance (a character vector) to the model. object <- attach.party.plotmo.importance(object, trace) # Following is necessary because we will shortly change the class of the object # (and therefore getCall.party won't work, we must rely on getCall.default). # We need the call to get the data used to build the model. (We can't use # object$data because that may contain "variable names" like "log(lstat)".) object$call <- getCall(object) # The meaning of "[[" is redefined for party objects i.e. the partykit # package defines "[[.party". Since in the plotmo code we need [[ to do # things like object[["x"]], we change the class of the object here, so # [[ has its standard meaning for the object while we are in plotmo. trace2(trace, "changing class of %s from %s to \"party_plotmo\" for standard \"[[\"\n", object.name, quote.with.c(class(object))) original.class <- class(object) # save for plotmo.predict.party_plotmo class(object) <- "party_plotmo" object$original.class <- original.class object } plotmo.predict.party_plotmo <- function(object, newdata, type, ..., TRACE) { stopifnot(is.character(object$original.class)) class(object) <- object$original.class # suppress warnings: # Warning: 'newdata' had 2 rows but variables found have 297 rows # Warning in rval[ix[[i]]] <- preds[[i]] : number of items to replace is not a multiple of replacement length on.exit(options(warn=old.warn)) options(warn=-1) old.warn <- getOption("warn") predict <- plotmo.predict(object, newdata, type=type, ..., TRACE=TRACE) predict } # attach plotmo.importance (a character vector) to the model attach.party.plotmo.importance <- function(object, trace) { varimp <- try(varimp(object), silent=TRUE) if(is.try.err(varimp)) { # only some party objects support varimp # the variable(s) before the | in the formula varnames <- colnames(attr(object$info$terms$response, "factors")) # append variables actually used in the tree, in order of importance varnames <- c(varnames, names(varimp_party(object))) } else varnames <- names(sort(varimp, decreasing=TRUE)) varnames.original <- varnames for(i in seq_along(varnames)) varnames[i] <- naken.collapse(varnames[i]) # e.g. log(lstat) becomes lstat if(trace >= 1) cat("variable importance:", varnames, "\n") attr(object, "plotmo.importance") <- varnames object } # Like varimp.constparty but works for all party trees, including mob trees. # Splits that affect more observations get more weight. # Splits near the root get slightly more weight (lower depth). # (This is to disambiguate vars that have equal importance otherwise.) varimp_party <- function(object) { init.varimp <- function(node, varimp, depth) { # update varimp for tree starting at node by walking the tree varid <- node$split$varid if(!is.null(varid)) { check.index(varid, "varid", varimp) # paranoia nobs <- if(!is.null(node$info$nobs)) node$info$nobs else 1 varimp[varid] <- varimp[varid] + nobs - .0001 * depth } knodes <- partykit::kids_node(node) for(node in knodes) if(!is.null(node)) varimp <- init.varimp(node, varimp, depth+1) # recurse varimp } #--- varimp_party starts here varnames <- colnames(object$data) varimp <- repl(0, length(varnames)) names(varimp) <- varnames varimp <- init.varimp(object$node, varimp, depth=0) sort(varimp[varimp != 0], decreasing=TRUE) # discard vars not in tree, sort } plotmo.singles.party_plotmo <- function(object, x, nresponse, trace, all1, ...) { all <- seq_along(colnames(x)) if(all1) return(all) varnames <- attr(object, "plotmo.importance") stopifnot(!is.null(varnames)) i <- match(varnames, colnames(x)) ina <- which(is.na(i)) # sanity check if(length(ina)) { warnf( "could not find \"%s\" in %s\nWorkaround: use all1=TRUE to plot all variables", varnames[ina[1]], quote.with.c(colnames(x))) i <- i[!is.na(i)] } if(length(i) == 0) { warnf("could not estimate variable importance") i <- seq_along(length(colnames(x))) # something went wrong, use all vars } # indices of important variables, max of 10 variables # (10 becauses plotmo.pairs returns 6, total is 16, therefore 4x4 grid) i[1: min(10, length(i))] } plotmo.pairs.party_plotmo <- function(object, x, nresponse, trace, all2, ...) { singles <- plotmo.singles(object, x, nresponse, trace, all1=FALSE, ...) # choose npairs so a total of no more than 16 plots # npairs=5 gives 10 pairplots, npairs=4 gives 6 pairplots npairs <- if(length(singles) <= 6) 5 else 4 form.pairs(singles[1: min(npairs, length(singles))]) } # Check the mob object formula and issue a work-around message when # the formula won't work for predictions with new data. # This prevents err msg: 'newdata' had 1 row but variables found have 167 rows check.mob.object <- function(object) { call.fit <- getCall(object)$fit # was a fit func passed to the model building func? if(is.null(call.fit)) return() # it's a mob object func <- eval(call.fit) stopifnot(inherits(func, "function")) func <- deparse(func, width.cutoff=500) # Is there a "(" followed by "~" followed by a lone "x," in the function body? # Or a "(" followed by "~" followed by "x - 1,". regex1 <- "\\(.*\\~.*[^a-zA-Z0-9_\\.]x," regex2 <- "\\(.*\\~.*x \\- 1," regex <- paste0(regex1, "|", regex2) grepl <- grepl(regex, func) if(any(grepl)) { # Issue the following message (details will vary depending on the fit func): # # The following formula in the mob fit function is not supported by plotmo: # # glm(y ~ 0 + x, family = binomial, start = start, ...) # # Possible workaround: Replace the fit function with: # # function (y, x, start = NULL, weights = NULL, offset = NULL, ...) # { # glm(as.formula(paste("y ~ ", paste(colnames(x)[-1], collapse="+"))), # family = binomial, start = start, ...) # } # # Error: The formula in the mob fit function is not supported by plotmo (see above) printf("\nThe following formula in the mob fit function is not supported by plotmo:\n\n") ifunc <- which(grepl)[1] cat(func[ifunc]) regex <- "\\([^,]+," func[ifunc] <- sub(regex, "(as.formula(paste(\"y ~ \", paste(colnames(x)[-1], collapse=\"+\"))),\n data=x,", func[ifunc]) printf("\n\nPossible workaround: Replace the fit function with:\n\n") printf(" %s <- ", as.character(call.fit)) for(i in 1:length(func)) printf("%s\n ", func[i]) printf("\n") stop0("The formula in the mob fit function is not supported by plotmo (see above)\n", " This is because predict.mob often fails with newdata and type=\"response\"\n", " e.g. example(mob); predict(pid_tree, newdata=PimaIndiansDiabetes[1:3,], type=\"response\")") } } # cforest objects plotmo.prolog.parties <- function(object, object.name, trace, ...) # called when plotmo starts { attr(object, "plotmo.importance") <- order.parties.vars.on.importance(object, trace) # a char vector object } order.parties.vars.on.importance <- function(object, trace) # a char vector { varimp <- try(varimp(object), silent=TRUE) varnames <- if(is.try.err(varimp)) colnames(object$data)[-1] # -1 to drop response TODO is this reliable? else names(sort(varimp, decreasing=TRUE)) if(trace >= 1) cat("variable importance:", varnames, "\n") varnames } plotmo.singles.parties <- function(object, x, nresponse, trace, all1, ...) { plotmo.singles.party_plotmo(object, x, nresponse, trace, all1, ...) } plotmo.pairs.parties <- function(object, x, nresponse, trace, all2, ...) { plotmo.pairs.party_plotmo(object, x, nresponse, trace, all2, ...) } plotmo/R/pre.R0000644000176200001440000000576613710707163012721 0ustar liggesusers# pre.R: plotmo functions for "pre" package plotmo.prolog.pre <- function(object, object.name, trace, ...) # invoked when plotmo starts { # importance is a vector of variable indices, most important vars first importance <- order.pre.vars.on.importance(object, trace) attr(object, "plotmo.importance") <- importance object } order.pre.vars.on.importance <- function(object, trace) { varimps <- try(pre::importance(object, plot=FALSE)$varimps, silent=TRUE) if(is.try.err(varimps)) { cat("\n") warning0("pre::importance(pre.object) failed\n", "(Will plot all variables regardless of importance. Use all2=TRUE to get degree2 plots.)\n") # NULL be will be treated as all vars by plotmo.single.pre, # and as no vars by plotmo.pairs.pre. return(NULL) } stopifnot(is.data.frame(varimps)) if(NROW(varimps) == 0) { # based on code in importance function in pre.R warning0("importance(pre.object)$varimps is empty") return(NULL) } stopifnot(!is.null(varimps$varname)) # following is needed for multiple response models # we get the combined importance across all responses if(is.null(varimps$imp)) varimps$imp <- rowSums(varimps[,-1]) stopifnot(!is.null(varimps$imp)) # discard variables whose importance is less than 1% of max importance varname <- varimps[varimps$imp > .01 * varimps$imp[1], ]$varname # convert variable names to column indices allvarnames <- object$x_names stopifnot(!is.null(allvarnames) && length(allvarnames) > 0) # paranoia importance <- match(varname, allvarnames) if(any(is.na(importance) | (importance == 0))) { # sanity check warning0("could not get variable importances\n varname=", paste.c(varname, maxlen=30)) return(NULL) } if(trace > 0) cat0("importance: ", paste.trunc(allvarnames[importance], maxlen=120), "\n") importance # return a vector of var indices, most important vars first } plotmo.singles.pre <- function(object, x, nresponse, trace, all1, ...) { importance <- attr(object, "plotmo.importance") if(all1 || is.null(importance)) return(seq_len(NCOL(x))) # all variables # 10 most important variables # (10 becauses plotmo.pairs returns 6, total is 16, therefore 4x4 grid) importance[seq_len(min(10, length(importance)))] } plotmo.pairs.pre <- function(object, x, ...) { importance <- attr(object, "plotmo.importance") if(is.null(importance)) return(NULL) # importances not available so don't plot any pairs # choose npairs so a total of no more than 16 plots # npairs=5 gives 10 pairplots, npairs=4 gives 6 pairplots npairs <- if(length(importance) <= 6) 5 else 4 form.pairs(importance[1: min(npairs, length(importance))]) } plotmo.pairs.gpe <- function(object, x, nresponse=1, trace=0, all2=FALSE, ...) { return(NULL) # not yet supported because importance(gpe) not supported } plotmo/R/prolog.R0000644000176200001440000000136313722322770013422 0ustar liggesusers# prolog.R: plotmo.prolog functions, called at the start of plotmo and plotres # gets called at the start of plotmo and plotres plotmo.prolog <- function(object, object.name, trace, ...) { trace2(trace, "--plotmo_prolog for %s object %s\n", class.as.char(object), object.name) UseMethod("plotmo.prolog") } plotmo.prolog.default <- function(object, object.name, ...) { # prevent confusing downstream errors by doing an initial check here if(is.null(getCall(object)) && is.null(object[["x"]])) stopf("%s does not have a 'call' field or %s", object.name, if(is.null(object[["y"]])) "'x' and 'y' fields" else "an 'x' field") object } plotmo/R/do.par.R0000644000176200001440000002104714242000736013275 0ustar liggesusers# do.par.R: functions setting par() and for setting the overall caption # main1 is not called main else would clash with main passed in dots (which # we ignore but cause an error message). Likewise for xlab1 and ylab1. do.par <- function(..., nfigs, caption, main1, xlab1, ylab1, trace, nlines.in.main=if(is.specified(main1)) nlines(main1) else 1, def.cex.main=1, def.font.main=2, # use 1 for compat with plot.lm def.right.mar=.8) { nrows <- ceiling(sqrt(nfigs)) # Note that the plain old cex argument is used in plotmo only in par() # (but we also query it later using par("cex")). # We use plain old cex relative to the cex calculated by nrows (so passing # cex=1 to plotmo causes no changes, and cex=.8 always makes things smaller). # TODO cex.axis etc. should be treated in the same way # TODO consider moving this into the dotargs functions, also extend for cex.axis, cex.main plain.old.cex <- dota("cex", DEF=1, ...) check.numeric.scalar(plain.old.cex) cex <- if(nrows == 1) 1 else if(nrows == 2) .83 else if(nrows >= 3) .66 cex <- plain.old.cex * cex # set oma to make space for caption if necessary stopifnot.string(caption, allow.empty=TRUE, null.ok=TRUE) def.oma <- dota("oma", ...) if(!is.specified(def.oma)) { def.oma <- par("oma") def.oma[3] <- max(def.oma[3], # .333 to limit cex adjustmment 2 + (plain.old.cex^.333 * nlines(caption))) } cex.lab <- dota("cex.lab", # make the labels small if multiple figures DEF=if(def.cex.main < 1) .8 * def.cex.main else 1, ...) mgp <- # compact title and axis annotations if(cex.lab < .6) c(1, 0.2, 0) else if(cex.lab < .8) c(1, 0.25, 0) else c(1.5, 0.4, 0) # margins are small to pack plots in, but make bigger if xlab # or ylab specified (note that xlab or ylab equal to NULL means # that we will later auto generate them) mar <- c( if(is.null(xlab1) || (is.specified(xlab1) && any(nzchar(xlab1)))) 4 else 3, # bottom if(is.null(ylab1) || (is.specified(ylab1) && any(nzchar(ylab1)))) 3 else 2, # left 1.2 * nlines.in.main, # top def.right.mar) # right if(nrows >= 5) # small margins if lots of figures mar <- cex * mar trace2(trace, "\n") call.dots(graphics::par, DROP="*", # drop everything KEEP="PREFIX,PAR.ARGS", # except args matching PREFIX and PAR.ARGS TRACE=if(trace >= 2) trace-1 else 0, SCALAR=TRUE, def.mfrow = c(nrows, nrows), def.mgp = mgp, # compact title and axis annotations def.tcl = -.3, # shorten tick length def.font.main = def.font.main, def.mar = mar, def.oma = def.oma, def.cex.main = def.cex.main, # ignored by most plot funcs so do it here def.cex.lab = cex.lab, def.cex.axis = cex.lab, force.cex = cex, # last, overrides any cex set by any arg above ...) # any remaining graphic dot args are also processed } # call do.par on any graphics args in dots, and return a list of their # old values so the caller can use on.exit to restore them do.par.dots <- function(..., trace=0) { dots <- match.call(expand.dots=FALSE)$... if(length(dots) == 0) return(NULL) oldpar <- args <- list() env <- parent.frame() for(dotname in PAR.ARGS) if(is.dot(dotname, ...)) { arg <- list(par(dotname)) names(arg) <- dotname oldpar <- append(oldpar, arg) dot.org <- dota(dotname, ...) dot <- try(eval(dot.org, envir=env, enclos=env), silent=TRUE) if(is.try.err(dot)) dot <- dot.org # TODO consider moving this into the dotargs functions, also extend for cex.axis, cex.main # special handling for cex args: we want cex to be relative # to the current setting, so e.g cex=1 causes no change if(substr(dotname, 1, 3) == "cex") { olddot <- par(dotname) dot <- dot[[1]] * olddot } else if(!(dotname %in% PAR.VEC) && length(dot) != 1) dot <- dot[[1]] # similar to handling of argument "scalar" in eval.dotlist arg <- list(dot) names(arg) <- dotname args <- append(args, arg) } if(length(args)) { if(trace >= 2) printf.wrap("\npar(%s)\n", list.as.char(args)) do.call(par, args) } oldpar # a list of old values of args that were changed, empty if none } check.do.par <- function(do.par, nfigs) # auto do.par if null, check is 0,1, or 2 { if(is.null(do.par)) do.par <- nfigs > 1 if(is.logical(do.par)) do.par <- as.numeric(do.par) stopifnot(length(do.par) == 1) if(!is.numeric(do.par) || (do.par != 0 && do.par != 1 &&do.par != 2)) stop0("do.par must be 0, 1, or 2") do.par } auto.caption <- function(caption, resp.name, type, model.call, object.name, my.call) { sresponse <- stype <- smodel <- scaption <- smy.call <- "" if(!is.null(caption)) scaption <- sprint("%s ", caption) # the test against "y" is because "y" may just be a fabricated # name created because the actual name was not available if(!is.null(resp.name) && resp.name != "y") sresponse <- paste0(resp.name, " ") if(type != "response") stype <- paste0("type=", type, " ") if(!is.null(model.call)) { smodel <- strip.deparse(model.call) smodel <- sub("\\(formula=", "(", smodel) # delete formula= } else smodel <- paste0("model: ", object.name) s <- paste0(scaption, sresponse, stype, smodel) smy.call <- process.my.call.for.caption(my.call) if(nzchar(smy.call)) s <- paste0(s, if(nzchar(s)) "\n" else "", smy.call) s } # Call this only after a plot is on the screen to avoid # an error message "plot.new has not been called yet" draw.caption <- function(caption, ...) { if(!is.null(caption) && any(nzchar(caption))) { # allow use of dot args for caption specs cex <- dota("caption.cex cex.caption", DEF=1, NEW=1, ...) font <- dota("caption.font font.caption", DEF=1, NEW=1, ...) col <- dota("caption.col col.caption", DEF=1, NEW=1, ...) line <- dota("caption.line", DEF=1, ...) # trim so caption fits # strwidth doesn't have units of device coords so work with usr coords # TODO the algorithm below is not quite correct caption <- strsplit(caption, "\n")[[1]] usr <- par("usr") # xmin, xmax, ymin, ymax n <- par("mfrow")[2] # number of figures horizontally across page avail <- .7 * n * (usr[2] - usr[1]) strwidth <- max(strwidth(caption)) if(strwidth > avail) { which <- strwidth(caption) > avail max <- max(nchar(caption)) max.nchar <- max * avail / strwidth if(max.nchar < max) { # TODO should always be FALSE but actually isn't caption <- substr(caption, 1, max.nchar) caption[which] <- paste0(caption[which], "...") } } caption <- paste(caption, collapse="\n") mtext(text=caption, line=line, outer=TRUE, cex=cex * par("cex")^.333, col=col, font=font) } caption } get.caption <- function(nfigs, do.par, caption, resp.name, type, model.call, object.name, my.call) { stopifnot.string(caption, null.ok=TRUE, allow.empty=TRUE) if(nfigs > 1 && do.par && (is.null(caption) || !is.null(my.call))) auto.caption(caption, resp.name, type, model.call, object.name, my.call) else paste0(if(is.null(caption)) "" else caption, if(!is.null(caption) && !is.null(my.call)) "\n" else "", if(!is.null(my.call)) "" else process.my.call.for.caption(my.call)) } process.my.call.for.caption <- function(my.call) { s <- "" if(!is.null(my.call)) { s <- sub("\\(object=", "(", my.call) # delete object= s <- sub(", trace=[-._$[:alnum:]]+", "", s) # delete trace=xxx s <- sub(", SHOWCALL=[-._$[:alnum:]]+", "", s) # delete SHOWCALL=xxx } s # a string, may be "" } plotmo/R/as.char.R0000644000176200001440000002257014566605576013461 0ustar liggesusers# as.char.R: brief description of an object as a string e.g. "c(1,2)" # this file also includes print_summary for matrices and data.frames as.char <- function(object, maxlen=20) { check.integer.scalar(maxlen, min=1) if(is.null(object)) "NULL" else if(is.name(object)) paste.trunc(object, maxlen=maxlen) # e.g. "..3" for unforced dot args else if(is.environment(object)) environment.as.char(object) else if(is.call(object)) { # e.g. x is a call object in foo(x=1:3) s <- strip.space.collapse(format(object)) if(nchar(s) > maxlen) s <- paste0(substr(s, 1, maxlen), "...)") s } else if(NCOL(object) == 1 && is.character(object)) paste.c(paste0("\"", object, "\"")) else if(NCOL(object) == 1 && is.logical(object)) paste.c(object) else if(NCOL(object) == 1 && is.numeric(object)) { # digits=4 is arb but seems about right, and zapsmall means more can # be displayed in limited space if just one val is say 3.553e-15 paste.c(signif(zapsmall(object, digits=4), digits=4)) } else if(length(dim(object)) == 2) sprint("%s[%g,%g]", class(object)[1], NROW(object), NCOL(object)) else if(class(object)[1] == "list") # not is.list() because e.g. lm objects are lists paste0("list(", paste.trunc(list.as.char(object), maxlen=maxlen+12), ")") else if(inherits(object, "Date")) paste0("Date:", paste.trunc(object, maxlen=maxlen+12)) else paste0(class.as.char(object), ".object") } # compact description of an object's class # typically quotify=TRUE for error messages (full class name with quotes), # and quotify=FALSE for trace messages (just first field of class name, no quotes) class.as.char <- function(object, quotify=FALSE) { if(quotify) quotify(paste.trunc(class(object), collapse=",", maxlen=60)) else class(object)[1] } # compact description of a list # maxlen is max length of each list element (not of the entire list) list.as.char <- function(object, maxlen=20) { stopifnot(is.list(object) || is.pairlist(object)) s <- "" names <- names(object) for(i in seq_along(object)) { if(i != 1) s <- sprint("%s, ", s) name.ok <- length(names) >= i && !is.na(names[i]) && nzchar(names[i]) if(name.ok && names[i] == "...") s <- sprint("%s...", s) # print dots as ... not as ...=pairlist.object else { if(name.ok) s <- sprint("%s%s=", s, names(object)[i]) s <- sprint("%s%s", s, as.char(object[[i]], maxlen=maxlen)) } } s # one element character vector e.g "x=1, 2" } environment.as.char <- function(env, maxlen=60) # compact description { if(is.null(env)) # illegal, but we still want to format it return("env(NULL)") stopifnot(is.environment(env)) # format(env) returns "" stripped.env <- gsub("", "", format(env)[1]) # if it's a standard environment return the environment's name if(grepl("^namespace:|^R_[[:alnum:]]+Env", stripped.env)) stripped.env # something like "namespace:stats" or "R_GlobalEnv" else # return the names of the objects in the environment sprint("env(%s)", paste.trunc(paste0(ls(env, all.names=TRUE), collapse=", "), maxlen=maxlen)) } # The main purpose of this routine is to summarize matrices and data.frames, # but it will also (semi)gracefully handle any object that is passed to it. # # Note that this only does anything if trace >= 2. # # If x is a matrix or dataframe or similar, print first few rows and last row. # If trace >= 4, then print all rows and cols, up to 1000 rows and 100 cols. # # the details argument: # 0=don't print data, print the colnames truncated to one line of output # 1=don't print data, print all colnames # -1=like print data but don't prefix the output with spaces # 2=print the data print_summary <- function(x, xname=trunc.deparse(substitute(x)), trace=2, msg="", prefix="", details=2) { check.numeric.scalar(trace) if(trace < 2) return() if(is.null(x)) { printf("%s: NULL\n", xname) return() } if(length(x) == 0) { printf("%s: length zero\n", xname) return() } # try(data.frame(), silent=TRUE) is not actually silent # for language objects, so handle them specially if(is.language(x)) { x$na.action <- NULL # don't want to print the na.action if there is one s <- try(format(x)) max <- if(trace <= 2) 8 else 1000 if(length(s) > max) { s <- s[1:max] s[max] <- paste(s[max], "\n...") } s <- gsub("[ \t\n]", "", s) # remove white space s <- gsub(",", ", ", s) # replace comma with comma space s <- paste(s, collapse="\n ", sep="") printf("%s%s%s:\n%s\n", prefix, xname, msg, s) return() } if(is.list(x) && !is.data.frame(x)) { # data.frames are lists, hence must check both if(details < 2 && trace < 4) { printf("%s: list with elements %s\n", xname, quotify.trunc(paste(names(x)))) return() } printf("%s ", xname) str(x) return() } df <- try(my.data.frame(x, trace, stringsAsFactors=FALSE), silent=TRUE) if(is.try.err(df)) { # be robust for whatever gets passed to this function printf("print_summary: cannot convert class \"%s\" to a data.frame (%s)\n", class(x)[1], cleantry(df)) printf("%s%s%s:\n", prefix, xname, msg) if(length(dim(x)) == 2) { # it's a matrix or other 2D object? if(trace >= 4) { try(print_with_strings_quoted(x)) try(print(summary(x))) } else { try(print_with_strings_quoted(head(x))) printf("...\n") } } else try(print_with_strings_quoted(x)) return() } if(details < 2 && trace < 4) { # don't print the data, just the dimensions and colnames if(details != -1) printf(" ") printf("%s%s[%d,%d]%s ", prefix, xname, nrow(df), ncol(df), msg) print_colnames(x, full=details == 2, newline="") if(NCOL(x) == 1 || NROW(x) == 1) # if a vector, print first few values cat0(", and values ", # if double, print 4 significant digits paste.trunc(if(is.double(x)) sprint("%.4g", x) else x, collapse=", ", maxlen=32)) cat0("\n") return() } colnames <- safe.colnames(x) printf("%s%s[%d,%d]%s%s:\n", prefix, xname, nrow(df), ncol(df), msg, if(is.null(colnames)) " with no column names" else "") df.short <- df maxrows <- if(trace >= 4) 1000 else 5 if(maxrows < nrow(df)) { df.short <- df[c(1:(maxrows-1), nrow(df)), , drop=FALSE] if(is.null(rownames(df.short))) rownames(df.short) <- c(1:(maxrows-1), nrow(df)) rownames(df.short)[maxrows-2+1] <- "..." } maxcols <- if(trace >= 4) 100 else 10 if(maxcols < ncol(df)) { df.short[,maxcols] <- "..." df.short <- df.short[, 1:maxcols, drop=FALSE] if(!is.null(colnames)) colnames(df.short)[maxcols] <- "..." } try(print_with_strings_quoted(df.short)) is.fac <- sapply(df, is.factor) if(is.null(colnames)) colnames(df) <- sprint("[,%d]", seq_len(NCOL(x))) if(any(is.fac)) { names <- paste0(colnames(df), ifelse(sapply(df, is.ordered), "(ordered)", "")) if(sum(is.fac) == 1) # only one fac, so enough space to print levels too printf(" %s is a factor with levels: %s\n", paste.trunc(names[is.fac]), paste.trunc(levels(df[,is.fac]))) else printf(" factors: %s\n", paste.trunc(names[is.fac])) } if(trace >= 4) try(print(summary(df))) } print_colnames <- function(x, full=FALSE, newline="\n") { colnames <- safe.colnames(x) if(is.null(colnames)) printf("with no column names%s", newline) else { colnames[which(colnames == "")] <- "\"\"" if(full) # full colnames (up to 1000 characters) printf("with colname%s %s%s", if(length(colnames(x)) > 1) "s" else "", paste.trunc(colnames, maxlen=max(25, getOption("width")-20)), newline) else # short version of colnames printf.wrap("with colname%s %s%s", if(length(colnames(x)) > 1) "s" else "", paste.trunc(colnames), newline) } } # Like print but puts quotes around strings. # Useful for disambiguating strings from factors. # # "..." is not quoted because it is used as a # "something was deleted" indicator in print_summary print_with_strings_quoted <- function(x) { if(length(dim(x)) == 2) for(j in seq_len(NCOL(x))) if(is.character(x[,j])) for(i in seq_along(x[,j])) if(x[i,j] != "...") x[i,j] <- paste0("\"", x[i,j], "\"") print(x) } plotmo/R/plotmo.R0000644000176200001440000023111214567065443013440 0ustar liggesusers# plotmo.R: plot the model response when varying one or two predictors # # Stephen Milborrow Sep 2006 Cape Town plotmo <- function(object = stop("no 'object' argument"), type = NULL, nresponse = NA, pmethod = "plotmo", pt.col = 0, jitter = .5, smooth.col = 0, level = 0, func = NULL, inverse.func = NULL, nrug = 0, grid.col = 0, type2 = "persp", degree1 = TRUE, all1 = FALSE, degree2 = TRUE, all2 = FALSE, do.par = TRUE, clip = TRUE, ylim = NULL, caption = NULL, trace = 0, grid.func = NULL, grid.levels = NULL, extend = 0, ngrid1 = 50, ngrid2 = 20, ndiscrete = 5, npoints = 3000, center = FALSE, xflip = FALSE, yflip = FALSE, swapxy = FALSE, int.only.ok = TRUE, ...) { init.global.data() on.exit({init.global.data(); gc()}) # release memory on exit object.name <- quote.deparse(substitute(object)) object # make sure object exists trace <- as.numeric(check.integer.scalar(trace, logical.ok=TRUE)) use.submodel <- dota("USE.SUBMODEL", DEF=TRUE, ...) # undoc arg (for parsnip models) use.submodel <- is.specified(use.submodel) # Associate the model environment with the object. # (This is instead of passing it as an argument to plotmo's data access # functions. It saves a few hundred references to model.env in the code.) object.env <- get.model.env(object, object.name, trace, use.submodel) ret <- plotmo_prolog(object, object.name, trace, ...) object <- ret$object # the original object or a submodel (parsnip) my.call <- ret$my.call attr(object, ".Environment") <- object.env # We will later make two passes through the plots if we need to # automatically determine ylim (see get.ylim.by.dummy.plots). # The trace2 variable is used for disabling tracing on the second pass. trace2 <- trace # trace=100 to 103 are special values used for development # (they are for tracing just plotmo_x with no plotting) special.trace <- FALSE if(trace >= 100 && trace <= 103) { special.trace <- TRUE trace <- trace - 100 } pmethod <- match.choices(pmethod, c("plotmo", "partdep", "apartdep"), "pmethod") clip <- check.boolean(clip) all1 <- check.boolean(all1) all2 <- check.integer.scalar(all2, min=0, max=2) center <- check.boolean(center) swapxy <- check.boolean(swapxy) xflip <- check.boolean(xflip) yflip <- check.boolean(yflip) type2 <- match.choices(type2, c("persp", "contour", "image"), "type2") level <- get.level(level, ...) pt.col <- get.pt.col(pt.col, ...) jitter <- get.jitter(jitter, ...) smooth.col <- get.smooth.col(smooth.col, ...) check.integer.scalar(ndiscrete, min=0) extend <- check.numeric.scalar(extend) stopifnot(extend > -.3, extend <= 10) # .3 prevents shrinking to nothing, 10 is arb if(!is.specified(degree1)) degree1 <- 0 if(!is.specified(degree2)) degree2 <- 0 if(!is.specified(nresponse)) nresponse <- NA if(!is.specified(clip)) clip <- FALSE if(center && clip) { clip <- FALSE # otherwise incorrect clipping (TODO revisit) warning0("forcing clip=FALSE because center=TRUE ", "(a limitation of the current implementation)") } # get x so we can get the predictor names and ux.list x <- plotmo_x(object, trace) if(NCOL(x) == 0 || NROW(x) == 0) stop("x is empty") # seen with an intercept only model for some model classes (not earth) if(special.trace) # special value of trace was used? return(invisible(x)) meta <- plotmo_meta(object, type, nresponse, trace, msg.if.predictions.not.numeric= if(level > 0) "the level argument is not allowed" else NULL, ...) y <- meta$y.as.numeric.mat # y as a numeric mat, only the nresponse column nresponse <- meta$nresponse # column index resp.name <- meta$resp.name # used only in automatic caption, may be NULL resp.levs <- meta$resp.levs # to convert predicted strings to factors, may be NULL type <- meta$type # always a string (converted from NULL if necessary) ngrid1 <- get.ngrid1(ngrid1, y, ...) ngrid2 <- get.ngrid2(ngrid2, y, ...) n.apartdep <- ngrid1 # following prevents aliasing on nrow(data) to ensure we catch the following: # "warning: predict(): newdata' had 31 rows but variable(s) found have 30 rows" if(ngrid1 == length(y)) { trace2(trace, "changed ngrid1 from %g to %g\n", ngrid1, ngrid1+1) ngrid1 <- ngrid1 + 1 } temp <- get.unique.xyvals(x, y, npoints, trace) ux.list <- temp$ux.list # list, each elem is unique vals in a column of x uy <- temp$uy # unique y vals npoints <- temp$npoints y <- apply.inverse.func(inverse.func, y, object, trace) if(center) y <- my.center(y, trace) # get iresponse ncases <- nrow(x) iresponse <- NULL if(is.specified(pt.col)) { iresponse <- get.iresponse(npoints, ncases) if(is.null(iresponse)) pt.col <- 0 } # singles is a vector of indices of predictors for degree1 plots singles <- plotmo_singles(object, x, nresponse, trace, degree1, all1) nsingles <- length(singles) # each row of pairs is the indices of two predictors for a degree2 plot pairs <- plotmo_pairs(object, x, nresponse, trace, all2, degree2) npairs <- NROW(pairs) temp <- get.pred.names(colnames.x=colnames(x), nfigs=nsingles + npairs, ...) pred.names <- temp$pred.names abbr.pred.names <- temp$abbr.pred.names def.cex.main <- temp$def.cex.main is.int.only <- FALSE # is intercept only model? if(nsingles == 0 && npairs == 0) { # is this an intercept only model? (which causes nsingles == 0 && npairs == 0) # if so, we plot it anyway (unless degree1=0) trace2(trace, "\n----plotmo_singles for %s object, all1=FALSE %s \n", class.as.char(object), "(determine if is.int.only)") sing <- plotmo.singles(object=object, x=x, nresponse=nresponse, trace=trace, all1=FALSE) # note that all1=FALSE is.int.only <- length(sing) == 0 trace2(trace, if(is.int.only) "intercept-only model\n\n" else "model has an intercept\n\n") } if(is.int.only && int.only.ok && !all(degree1 == 0)) { singles <- 1 # plot the first predictor nsingles <- 1 } if(nsingles > 64 && trace >= 0) { cat0("More than 64 degree1 plots.\n", "Consider using plotmo's degree1 argument to limit the number of plots.\n", "For example, degree1=1:10 or degree1=c(\"", pred.names[singles[1]], "\", \"", pred.names[singles[2]], "\")\n", "Call plotmo with trace=-1 to make this message go away.\n\n") } else if(nsingles > 200) { # 220 is arb, 15 * 15 warning0("Will plot only the first 200 degree1 plots (of ", nsingles, " degree1 plots)") singles <- singles[1:200] nsingles <- length(singles) } if(npairs > 64 && trace >= 0) { cat0("More than 64 degree2 plots.\n", "Consider using plotmo's degree2 argument to limit the number of plots.\n", "For example, degree2=1:10 or degree2=\"", pred.names[singles[1]], "\"\n", "Call plotmo with trace=-1 to make this message go away.\n\n") } else if(npairs > 200) { warning0("Will plot only the first 200 degree2 plots (of ", npairs, " degree2 plots)") pairs <- pairs[1:200,] npairs <- NROW(pairs) } if(extend != 0 && npairs) { warning0("extend=", extend, ": will not plot degree2 plots ", "(extend is not yet implemented for degree2 plots)") pairs <- NULL npairs <- 0 } nfigs <- nsingles + npairs if(nfigs == 0) { if(trace >= 0) warning0("plotmo: nothing to plot") return(invisible()) } do.par <- check.do.par(do.par, nfigs) # do.par is 0, 1, or 2 # Prepare caption --- we need it now for do.par() but # can only display it later after at least one plot. # nfigs=2 (any number greater than 1) because by default we do.par in plotmo. caption <- get.caption(nfigs=2, do.par, caption, resp.name, type, getCall(object), object.name, my.call) if(do.par) { # TODO document what happens here and in plotres if only one plot oldpar <- par(no.readonly=TRUE) # need xlab etc. so so we can figure out margin sizes in do.par xlab <- dota("xlab", DEF="", ...) ylab <- dota("ylab", DEF="", ...) main <- dota("main", ...) do.par(nfigs=nfigs, caption=caption, main1=main, xlab1=xlab, ylab1=ylab, trace=trace, def.cex.main=def.cex.main, ...) if(do.par == 1) on.exit(par(oldpar), add=TRUE) } else { # do.par=FALSE oldpar <- do.par.dots(..., trace=trace) if(length(oldpar)) on.exit(do.call(par, oldpar), add=TRUE) } trace2(trace, "\n----Figuring out ylim\n") is.na.ylim <- !is.null(ylim) && anyNA(ylim) jittered.y <- apply.jitter(as.numeric(y), jitter) # get.ylim will do dummy plots if necessary temp <- get.ylim(object=object, type=type, nresponse=nresponse, pmethod=pmethod, pt.col=pt.col, jitter=jitter, smooth.col=smooth.col, level=level, func=func, inverse.func=inverse.func, nrug=nrug, grid.col=grid.col, type2=type2, degree1=degree1, all1=all1, degree2=degree2, all2=all2, do.par=do.par, clip=clip, ylim=ylim, caption=caption, trace=trace, grid.func=grid.func, grid.levels=grid.levels, extend=extend, ngrid1=ngrid1, ngrid2=ngrid2, npoints=npoints, ndiscrete=ndiscrete, int.only.ok=int.only.ok, center=center, xflip=xflip, yflip=yflip, swapxy=swapxy, def.cex.main=def.cex.main, x=x, y=y, singles=singles, resp.levs=resp.levs, ux.list=ux.list, pred.names=pred.names, abbr.pred.names=abbr.pred.names, nsingles=nsingles, npairs=npairs, nfigs=nfigs, uy=uy, is.na.ylim=is.na.ylim, is.int.only=is.int.only, trace2=trace2, pairs=pairs, iresponse=iresponse, jittered.y=jittered.y, n.apartdep=n.apartdep, ...) ylim <- temp$ylim trace2 <- temp$trace2 if(nsingles) plot_degree1(object=object, degree1=degree1, all1=all1, center=center, ylim=if(is.na.ylim) NULL else ylim, # each graph has its own ylim? type=type, nresponse=nresponse, pmethod=pmethod, trace=trace, trace2=trace2, pt.col=pt.col, jitter=jitter, iresponse=iresponse, smooth.col=smooth.col, grid.col=grid.col, inverse.func=inverse.func, grid.func=grid.func, grid.levels=grid.levels, extend=extend, ngrid1=ngrid1, is.int.only=is.int.only, level=level, func=func, nrug=nrug, draw.plot=TRUE, x=x, y=y, singles=singles, resp.levs=resp.levs, ux.list=ux.list, ndiscrete=ndiscrete, pred.names=pred.names, abbr.pred.names=abbr.pred.names, nfigs=nfigs, uy=uy, xflip=xflip, jittered.y=jittered.y, n.apartdep=n.apartdep, ...) if(npairs) plot_degree2(object=object, degree2=degree2, all2=all2, center, ylim=if(is.na.ylim) NULL else ylim, # each graph has its own ylim? type=type, nresponse=nresponse, pmethod=pmethod, clip=clip, trace=trace, trace2=trace2, pt.col=pt.col, jitter=jitter, iresponse=iresponse, inverse.func=inverse.func, grid.func=grid.func, grid.levels=grid.levels, extend=extend, type2=type2, ngrid2=ngrid2, draw.plot=TRUE, do.par=do.par, x=x, y=y, pairs=pairs, resp.levs=resp.levs, ux.list=ux.list, ndiscrete=ndiscrete, pred.names=pred.names, abbr.pred.names=abbr.pred.names, nfigs=nfigs, nsingles=nsingles, npairs=npairs, xflip=xflip, yflip=yflip, swapxy=swapxy, def.cex.main=def.cex.main, n.apartdep=n.apartdep, ...) draw.caption(caption, ...) invisible(x) } # plotmo.retval <- function(x, singles, pairs, pred.names) # plotmo's return value # { # degree1 <- vector("list", length(singles)) # names <- vector("character", length(singles)) # for(isingle in seq_along(singles)) { # ipred <- singles[isingle] # ipred is the predictor index i.e. col in model mat # temp <- degree1.data(isingle) # stopifnot(!is.null(temp)) # stopifnot(nrow(temp$xframe) == length(temp$yhat)) # data <- data.frame(temp$xframe[[ipred]], temp$yhat) # names[isingle] <- pred.names[ipred] # colnames(data) <- c(pred.names[ipred], "PLOTMO") # degree1[[isingle]] <- data # } # names(degree1) <- names # # npairs <- NROW(pairs) # degree2 <- vector("list", npairs) # names <- vector("character", npairs) # for(ipair in seq_len(npairs)) { # ipred1 <- pairs[ipair,1] # index of first predictor # ipred2 <- pairs[ipair,2] # index of second predictor # temp <- degree2.data(ipair) # stopifnot(!is.null(temp)) # # TODO this fails if blockify.degree2.frame kicks in # stopifnot(nrow(temp$xframe) == length(temp$yhat)) # data <- data.frame(temp$xframe[ipred1], temp$xframe[ipred2], as.vector(temp$yhat)) # names[ipair] <- paste0(pred.names[ipred1], ":", pred.names[ipred1]) # colnames(data) <- c(pred.names[ipred1], pred.names[ipred2], "PLOTMO") # degree2[[ipair]] <- data # } # names(degree2) <- names # # list(x=x, degree1=degree1, degree2=degree2) # } plotmo_prolog <- function(object, object.name, trace, ...) { object <- plotmo.prolog(object, object.name, trace, ...) my.call <- call.as.char(n=2) SHOWCALL <- dota("SHOWCALL", ...) if(!is.specified(SHOWCALL)) my.call <- NULL list(object=object, my.call=my.call) } get.pred.names <- function(colnames.x, nfigs, ...) { # numbers below are somewhat arb nrows <- ceiling(sqrt(nfigs)) # nrows in plot grid minlength <- 20; def.cex.main <- 1.2 if (nrows >= 9) { minlength <- 6; def.cex.main <- .7 } else if(nrows >= 8) { minlength <- 7; def.cex.main <- .8 } else if(nrows >= 7) { minlength <- 7; def.cex.main <- .8 } else if(nrows >= 6) { minlength <- 7; def.cex.main <- .8 } else if(nrows >= 5) { minlength <- 8; def.cex.main <- 1 } else if(nrows >= 4) { minlength <- 9; def.cex.main <- 1.1 } stopifnot(!is.null(colnames.x)) # plotmo_x always returns colnames (unless no columns) minlength <- dota("prednames.minlength", DEF=minlength, ...) prednames.abbreviate <- dota("prednames.abbreviate", DEF=TRUE, ...) prednames.abbreviate <- check.boolean(prednames.abbreviate) abbr.pred.names <- if((prednames.abbreviate)) abbreviate(strip.space(colnames.x), minlength=minlength, method="both.sides") else colnames.x list(pred.names = colnames.x, abbr.pred.names = abbr.pred.names, def.cex.main = def.cex.main) } # always returns a vector of 2 elems, could be c(-Inf, Inf) get.ylim <- function(object, type, nresponse, pmethod, pt.col, jitter, smooth.col, level, func, inverse.func, nrug, grid.col, type2, degree1, all1, degree2, all2, do.par, clip, ylim, caption, trace, grid.func, grid.levels, extend=extend, ngrid1, ngrid2, npoints, ndiscrete, int.only.ok, center, xflip, yflip, swapxy, def.cex.main, x, y, singles, resp.levs, ux.list, pred.names, abbr.pred.names, nsingles, npairs, nfigs, uy, is.na.ylim, is.int.only, trace2, pairs, iresponse, jittered.y, n.apartdep, ...) { get.ylim.by.dummy.plots <- function(..., trace) { # call the plotting functions with draw.plot=FALSE to get the ylim trace2(trace, "--get.ylim.by.dummy.plots\n") all.yhat <- NULL if(nsingles) { # get all.yhat by calling with draw.plot=FALSE # have to use explicit arg names to prevent alias probs # with dots, because the user can pass in any name with dots all.yhat <- c(all.yhat, plot_degree1(object=object, degree1=degree1, all1=all1, center=center, ylim=ylim, type=type, nresponse=nresponse, pmethod=pmethod, trace=trace, trace2=trace2, pt.col=pt.col, jitter=jitter, iresponse=iresponse, smooth.col=smooth.col, grid.col=grid.col, inverse.func=inverse.func, grid.func=grid.func, grid.levels=grid.levels, extend=extend, ngrid1=ngrid1, is.int.only=is.int.only, level=level, func=func, nrug=nrug, draw.plot=FALSE, x=x, y=y, singles=singles, resp.levs=resp.levs, ux.list=ux.list, ndiscrete=ndiscrete, pred.names=pred.names, abbr.pred.names=abbr.pred.names, nfigs=nfigs, uy=uy, xflip=xflip, jittered.y=jittered.y, n.apartdep=n.apartdep, ...)) } if(npairs) { all.yhat <- c(all.yhat, plot_degree2(object=object, degree2=degree2, all2=all2, center=center, ylim=ylim, type=type, nresponse=nresponse, pmethod=pmethod, clip=clip, trace=trace, trace2=trace2, pt.col=pt.col, jitter=jitter, iresponse=iresponse, inverse.func=inverse.func, grid.func=grid.func, grid.levels=grid.levels, extend=extend, type2=type2, ngrid2=ngrid2, draw.plot=FALSE, do.par=do.par, x=x, y=y, pairs=pairs, resp.levs=resp.levs, ux.list=ux.list, ndiscrete=ndiscrete, pred.names=pred.names, abbr.pred.names=abbr.pred.names, nfigs=nfigs, nsingles=nsingles, npairs=npairs, xflip=xflip, yflip=yflip, swapxy=swapxy, def.cex.main=def.cex.main, n.apartdep=n.apartdep, ...)) } # 1 2 3 4 5 q <- quantile(all.yhat, probs=c(0, .25, .5, .75, 1), names=FALSE) ylim <- c(q[1], q[5]) # all the data check.vec(ylim, "automatic ylim", expected.len=2) # iqr test to prevent clipping in some pathological cases iqr <- q[4] - q[2] # middle 50% of the data (inter-quartile range) if(clip && !is.na(iqr) && iqr > .05 * (max(y) - min(y))) { median <- q[3] ylim[1] <- max(ylim[1], median - 10 * iqr) ylim[2] <- min(ylim[2], median + 10 * iqr) } if(is.specified(pt.col) || is.specified(smooth.col) || is.specified(level)) ylim <- range1(ylim, jittered.y) # ensure ylim big enough for resp points else if(is.specified(smooth.col)) ylim <- range1(ylim, y) # binary or ternary reponse? # the range(uy) test is needed for binomial models specified using counts else if(length(uy) <= 3 || all(range(y) == c(0,1))) ylim <- range1(ylim, y) if(is.specified(nrug)) # space for rug ylim[1] <- ylim[1] - .1 * (ylim[2] - ylim[1]) trace2(trace, "--done get.ylim.by.dummy.plots\n\n") # have called the plot functions, minimize tracing in further calls to them trace2 <<- 0 # note <<- not <- ylim } #--- get.ylim starts here if(!(is.null(ylim) || is.na(ylim[1]) || length(ylim) == 2)) stop0("ylim must be one of:\n", " NULL all graphs have same vertical axes\n", " NA each graph has its own vertical axis\n", " c(min,max) ylim for all graphs") if(length(ylim) == 2 && ylim[2] <= ylim[1]) stop0("ylim[2] ", ylim[2], " is not greater than ylim[1] ", ylim[1]) if(is.na.ylim) ylim <- c(NA, NA) # won't be used else if(is.null(ylim)) # auto ylim ylim <- if(is.yaxis.a.probability(object, type, trace)) { if(is.specified(pt.col)) c(-0.1, 1.1) # leave space for possibly jittered points else c(0, 1) } else if(is.int.only) range(y, na.rm=TRUE) else get.ylim.by.dummy.plots(trace=trace, ...) if(!anyNA(ylim)) ylim <- fix.lim(ylim) if(trace >= 2) printf("ylim c(%.4g, %.4g) clip %s\n\n", ylim[1], ylim[2], if(clip) "TRUE" else "FALSE") list(ylim=ylim, trace2=trace2) } do.persp.auto.par <- function(simple.ticktype) # want small margins for bigger persp plots { # persp ignores both the global mgp and any mgp passed as arguments # directly to persp so we must adjust margins using par() old.mar <- par("mar") axis.space <- max(par("mgp")) mar <- old.mar if(simple.ticktype) { # Reduce bottom and left margins so we get a bigger persp plot. # This puts the bottom corner of the perp plot at same height at the # bottom of the axis labels on the degree1 plots. mar[1] <- max(mar[1] - axis.space - .5, .5) # bottom margin mar[2] <- max(mar[2] - axis.space - .5, .5) # left margin } else { # detailed mar[1] <- min(mar[1], 1) # enough space for axes mar[2] <- min(mar[2], 1) } par(mar=mar) } do.degree2.auto.par <- function(type2, nfigs, simple.ticktype) { if(type2 == "persp") # perspective plot do.persp.auto.par(simple.ticktype) else { # contour or image plot nrows <- ceiling(sqrt(nfigs)) if(nrows >= 5) mar <- c(2, 2, 1.2, .5) # space for bottom and left axis labels else mar <- c(3, 3, 2, .5) par(mar=mar) cex <- par("cex") # TODO would be better to use nfigs here? mgp <- # compact title and axis annotations if (cex < .7) c(1.2, 0.2, 0) else if(cex < .8) c(1.3, 0.3, 0) else c(1.5, 0.4, 0) par(mgp=mgp) } } plotmo_singles <- function(object, x, nresponse, trace, degree1, all1) { trace2(trace, "\n----plotmo_singles for %s object\n", class.as.char(object)) singles <- plotmo.singles(object=object, x=x, nresponse=nresponse, trace=trace, all1=all1) if(is.character(degree1)) # get all singles, not just those used in the model? singles <- seq_len(NCOL(x)) if(!is.null(singles) && any(is.na(singles))) { # !is.null required only for old R # Following occurs when plotting # train(Petal.Length ~ ., data=iris, method="rpart", tuneLength=4) # because caret converts factor predictors to indicator columns and # thus creates new variable names e.g. Speciesversicolor warning0("NA in singles, will plot all variables (as if all1=TRUE)") singles <- seq_len(NCOL(x)) } if(length(singles)) singles <- sort_unique(singles) # this will drop NAs if any nsingles <- length(singles) if(length(singles)) { degree1 <- check.index(degree1, "degree1", singles, colnames=colnames(x), allow.empty=TRUE, is.degree.spec=TRUE) singles <- singles[degree1] } else if(is.degree.specified(degree1) && degree1[1] != 0 && trace >= 0) warning0("'degree1' specified but no degree1 plots (maybe use all1=TRUE?)") if(trace >= 2) { if(length(singles)) cat("singles:", paste0(singles, " ", colnames(x)[singles], collapse=", "), "\n") else cat("no singles\n") } singles # a vector of indices of predictors for degree1 plots } plotmo_pairs <- function(object, x, nresponse, trace, all2, degree2) { trace2(trace, "\n----plotmo_pairs for %s object\n", class.as.char(object)) pairs <- NULL if(is.character(degree2) && length(degree2) == 2) { # degree2 is a two element character vector # treat as a special case (intentional inconsistency) singles <- seq_len(NCOL(x)) # get all singles, not just those used in the model i1 <- check.index(degree2[1], "degree2", singles, colnames=colnames(x)) if(length(i1) > 0) { i2 <- check.index(degree2[2], "degree2", singles, colnames=colnames(x)) if(length(i2) > 0) { if(i1[1] == i2[1]) warning0("both elements of degree2 are the same") pairs <- matrix(c(i1[1], i2[1]), nrow=1, ncol=2) } } } else { pairs <- if(all2) get.all.pairs.from.singles(object, x, trace, all2) else plotmo.pairs(object, x, nresponse, trace, all2) if(NROW(pairs)) { # put lowest numbered predictor first and remove duplicate pairs pairs <- unique(t(apply(pairs, 1, sort))) # order the pairs on the predictor order order <- order(pairs[,1], pairs[,2]) pairs <- pairs[order, , drop=FALSE] i <- check.index(degree2, "degree2", pairs, colnames=colnames(x), allow.empty=TRUE, is.degree.spec=TRUE) pairs <- pairs[i, , drop=FALSE] # length(i) will be 0 if check.index not ok } else if(is.degree.specified(degree2) && degree2[1] != 0 && trace >= 0) warning0("'degree2' specified but no degree2 plots (maybe use all2=TRUE?)") } if(trace >= 2) { if(NROW(pairs)) { cat("pairs:\n") print(matrix(paste(pairs, colnames(x)[pairs]), ncol=2)) } else cat("no pairs\n") } pairs } # pt.col is a formal arg, but for back compat we also support col.response get.pt.col <- function(pt.col, ...) { pt.col <- pt.col if(!is.specified(pt.col) && !is.dot("col", ...)) pt.col <- dota("col.response", EX=0, ...) # partial match, "col" excluded above # if any other response argument is specified, set the response color if(!is.specified(pt.col) && is.dot("pch cex.response pch.response pt.cex pt.pch", EX=c(1,1,1,0,0), ...)) pt.col <- "slategray4" if(!is.specified(pt.col)) pt.col <- 0 pt.col } get.jitter <- function(jitter, ...) { if(anyNA(jitter)) # allow jitter=NA jitter <- 0 check.numeric.scalar(jitter, logical.ok=TRUE) jitter <- as.numeric(jitter) if(jitter < 0 || jitter > 100) stop0("jitter=", jitter, " is illegal") jitter } get.smooth.col <- function(smooth.col, ...) { smooth.col <- dota("col.smooth", DEF=smooth.col, ...) # back compat # if any other smooth argument is specified, set the smooth color if(!is.specified(smooth.col) && is.dot("lty.smooth lwd.smooth lwd.loess smooth.lty smooth.lwd", EX=c(1,1,1,0,0), ...)) smooth.col <- 2 if(!is.specified(smooth.col)) smooth.col <- 0 smooth.col } get.ngrid1 <- function(ngrid1, y, ...) { check.integer.scalar(ngrid1) if(ngrid1 < 2) stop0("illegal ngrid1 ", ngrid1) if(ngrid1 > 1000) { warning0("clipped ngrid1=", ngrid1, " to 1000") ngrid1 <- 1000 } ngrid1 } get.ngrid2 <- function(ngrid2, y, ...) { check.integer.scalar(ngrid2) if(ngrid2 < 2) stop0("illegal ngrid2 ", ngrid2) if(ngrid2 > 500) { warning0("clipped ngrid2=", ngrid2, " to 500") ngrid2 <- 500 } ngrid2 } get.level <- function(level, ...) { if(anyNA(level) || is.null(level)) # treat NA and NULL as 0 level <- 0 check.numeric.scalar(level) # some code for backward compatibility (se is now deprecated) se <- 0 if(is.dot("se", ...)) se <- dota("se", ...) check.numeric.scalar(se, logical.ok=TRUE) if(se && level) # both specified? stop0("plotmo's 'se' argument is deprecated, please use 'level' instead") if(identical(se, TRUE)) { level <- .95 warning0( "plotmo's 'se' argument is deprecated, please use 'level=.95' instead") } else if(se < 0 || se > 5) # 5 is arb stop0("plotmo's 'se' argument is deprecated, please use 'level=.95' instead") else if(se > 0 && se < 1) # e.g. se=.95 stop0("plotmo's 'se' argument is deprecated, please use 'level=.95' instead") else if(se > 0) { level <- 1 - 2 * (1 - pnorm(se)) # se=2 becomes level=.954 warning0(sprint( "plotmo's 'se' argument is deprecated, please use 'level=%.2f' instead", level)) } else if(level != 0 && (level < .5 || level >= 1)) stop0("level=", level, " is out of range, try level=.95") level } get.unique.xyvals <- function(x, y, npoints, trace) { # convert special values of npoints ncases <- nrow(x) check.integer.scalar(npoints, min=-1, null.ok=TRUE, logical.ok=TRUE) npoints.was.neg <- FALSE if(is.null(npoints)) npoints <- 0 else if(is.logical(npoints)) npoints <- if(npoints) ncases else 0 else if(npoints == -1) { npoints.was.neg <- TRUE npoints <- ncases } else if(npoints > ncases) npoints <- ncases # Use a maximum of NMAX cases for calculating ux.list and uy # (unless npoints is bigger or TRUE or negative). # Allows plotmo to be fast even on models with millions of cases. NMAX <- 1e4 nmax <- max(NMAX, npoints) if(!npoints.was.neg && ncases > nmax) { trace2(trace, "using %g of %g cases to calculate unique x and y values\n", npoints, ncases) isubset <- get.isubset(y, npoints) y <- y[isubset] x <- x[isubset, , drop=FALSE] } list(ux.list = get.ux.list(x, trace), uy = unique(y), npoints = npoints) } # return a list, each element is the unique levels for corresponding column of x # TODO this is where we spend a lot of time in plotmo for big data get.ux.list <- function(x, trace) { ux.list <- list(colnames(x)) for(i in seq_len(ncol(x))) ux.list[[i]] <- if(is.factor(x[,i])) levels(x[,i]) else sort_unique(x[,i]) trace2(trace, "number of x values: %s\n", paste.trunc(colnames(x), sapply(ux.list, length))) ux.list } points.or.text <- function(..., x, y, pt.col, iresponse) { stopifnot(!is.na(pt.col)) cex <- dota("pt.cex cex.response", DEF=1, EX=c(0,1), NEW=1, ...) cex <- cex * pt.cex(NROW(x)) pch <- dota("pt.pch pch.response pch", DEF=20, EX=c(0,1,1), NEW=1, ...) # recycle then select only iresponse points n <- length(y) col <- repl(pt.col, n)[iresponse] pch <- repl(pch, n)[iresponse] cex <- repl(cex, n)[iresponse] x <- x[iresponse] y <- y[iresponse] if(is.character(pch) && pch[1] != ".") call.plot(graphics::text.default, PREFIX="pt.", force.x = x, force.y = y, force.labels = pch, force.col = col, force.cex = pmax(.1, .9 * cex), def.xpd = NA, # allow writing beyond plot area ...) else call.plot(graphics::points.default, PREFIX="pt.", force.x = x, force.y = y, force.pch = pch, force.col = col, force.cex = cex, # commented out because looks messy in image plots # def.xpd = NA, # allow writing beyond plot area ...) } # TODO Following handling of global variables is unpleasant. # I would prefer to have two namespace level variables, # degree1.data.global and degree2.data.global (similar to # degree1.xgrid.global etc.) # But CRAN check won't allow # unlockBinding(degree1.data.global, asNamespace("plotmo")) # so we can update those variables. # Also, we can't directly use assignInMyNamespace for these # variables because we need to update individual list elements. make.static.list <- function() { data <- list() func <- function(i, newdata=NULL) { if(is.null(i)) # init the data? data <<- list() else if(!missing(newdata)) # assign to the data? data[[i]] <<- newdata else if(i <= length(data)) # return the data element data[[i]] else # return the element, but it's NULL NULL } func } # The following global variables are for efficiency when we make two # passes through the plot. We store the data from the first pass so we # don't have to regenerate it. (We make two passes if we need to # precalculate ylim before doing the actual plotting.) # NULL is used here to indicate uninitialized. degree1.xgrid.global <- NULL degree2.xgrid.global <- NULL partdep.x.global <- NULL # dataframe of background vars we integrate over degree1.data <- make.static.list() degree2.data <- make.static.list() # the following global variables are for communicating across functions trace.call.global <- 0 # nonzero to trace call to predict, residuals, etc init.global.data <- function() { assignInMyNamespace("trace.call.global", 0) assignInMyNamespace("degree1.xgrid.global", NULL) assignInMyNamespace("degree2.xgrid.global", NULL) assignInMyNamespace("partdep.x.global", NULL) degree1.data(NULL) # clear the degree1 data by passing NULL degree2.data(NULL) } plot_degree1 <- function( # plot all degree1 graphs # copy of args from plotmo, some have been tweaked slightly object, degree1, all1, center, ylim, type, nresponse, pmethod, trace, trace2, pt.col, jitter, iresponse, smooth.col, grid.col, inverse.func, grid.func, grid.levels, extend, ngrid1, is.int.only, level, func, nrug, # the following args are generated in plotmo draw.plot, # draw.plot=FALSE means get predictions but don't actually plot x, y, singles, resp.levs, ux.list, ndiscrete, pred.names, abbr.pred.names, nfigs, uy, xflip, jittered.y, n.apartdep, ...) { get.degree1.data <- function(isingle) { # check if plot_degree1 was already called by get.ylim.by.dummy.plots data <- degree1.data(isingle) if(!is.null(data)) # data is already initialized? return(data) # yes, use it intervals <- NULL # prediction intervals, NULL if level argument not used # create data.frame of predictor values to be plotted, # by updating xgrid for this predictor (one column gets updated) xframe <- get.degree1.xframe(xgrid, x, ipred, ngrid1, ndiscrete, ux.list, extend) trace2(trace, "degree1 plot%d (pmethod \"%s\") variable %s\n", isingle, pmethod, pred.names[ipred]) if(pmethod == "partdep" || pmethod == "apartdep") { # following commented out because causes warning in R 4.2.0: length(x) = 64 > 1' in coercion to 'logical(1)' # stopifnot(!is.na(partdep.x) && !is.null(partdep.x)) yhat <- degree1.partdep.yhat(object, type, nresponse, pmethod, inverse.func, trace2, partdep.x, xframe, ipred, pred.names, resp.levs, ...) if(level > 0) { # get prediction intervals? warning0( "ignoring the 'level' argument because plotmo pmethod=\"", pmethod, "\"") level <- 0 } } else { # classic plotmo plot yhat <- plotmo_predict(object, xframe, nresponse, type, resp.levs, trace2, inverse.func, ...)$yhat if(level > 0) # get prediction intervals? intervals <- plotmo_pint(object, xframe, type, level, trace2, ipred, inverse.func) } temp <- blockify.degree1.frame(xframe, yhat, intervals, ipred, ux.list, ndiscrete) xframe <- temp$xframe yhat <- temp$yhat intervals <- temp$intervals if(center) { yhat <- my.center(yhat, trace2) intervals$fit <- my.center(intervals$fit, trace2) intervals$lwr <- my.center(intervals$lwr, trace2) intervals$upr <- my.center(intervals$upr, trace2) intervals$cint.lwr <- my.center(intervals$cint.lwr, trace2) intervals$cint.upr <- my.center(intervals$cint.upr, trace2) } all.yhat <- c(all.yhat, yhat, intervals$lwr, intervals$upr, intervals$cint.lwr, intervals$cint.upr) data <- list(xframe=xframe, yhat=yhat, intervals=intervals, all.yhat=all.yhat) if(!draw.plot) # save the data, if there is going to be a next time degree1.data(isingle, data) data } draw.degree1 <- function(...) { draw.degree1.fac <- function(...) { draw.grid(grid.col, nx=NA, ...) # nx=NA for horiz-only grid draw.fac.intervals(xframe[,ipred], intervals, ...) if(is.specified(pt.col)) points.or.text(x=jittered.x, y=yscale * (yshift + jittered.y), pt.col=pt.col, iresponse=iresponse, ...) draw.smooth1(smooth.col, x, ipred, yscale * (yshift + y), ux.list, ndiscrete, center, ...) # formal args for plot.factor, needed because "CRAN check" # doesn't allow ":::" and plot.factor isn't public plot.factor.formals <- c("x", "y", "legend.text") call.plot(graphics::plot, # calls plot.factor PREFIX = "degree1.", FORMALS = plot.factor.formals, TRACE = if(isingle == 1 && trace >= 2) trace-1 else 0, force.x = xframe[,ipred], force.y=yhat, force.add = TRUE, def.xaxt = if(xaxis.is.levs) "n" else "s", def.yaxt = if(yaxis.is.levs) "n" else "s", force.lty = 1, # else lty=2 say is printed weirdly force.lwd = 1, ...) if(xaxis.is.levs) # plot x level names along the x axis mtext(xlevnames, side=1, at=1:length(xlevnames), cex=par("cex") * cex.lab, line=.5, las=get.las(xlevnames)) if(yaxis.is.levs) # plot y level names along the y axis mtext(ylevnames, side=2, at=1:length(ylevnames), cex=par("cex") * cex.lab, line=.5, las=get.las(ylevnames)) } draw.degree1.numeric <- function(...) { draw.grid(grid.col, ...) draw.numeric.intervals(xframe[,ipred], intervals, ...) draw.func(func, object, xframe, ipred, center, trace, ...) if(is.specified(pt.col)) points.or.text(x=jittered.x, y=yscale * (yshift + jittered.y), pt.col=pt.col, iresponse=iresponse, ...) draw.smooth1(smooth.col, x, ipred, yscale * (yshift + y), ux.list, ndiscrete, center, ...) call.plot(graphics::lines.default, PREFIX="degree1.", force.x = xframe[,ipred], force.y = yhat, force.col = dota("degree1.col col.degree1 col", EX=c(0,1,1), DEF=1, NEW=1, ...), force.lty = dota("degree1.lty lty.degree1 lty", EX=c(0,1,1), DEF=1, NEW=1, ...), force.lwd = dota("degree1.lwd lwd.degree1 lwd", EX=c(0,1,1), DEF=1, NEW=1, ...), ...) draw.degree1.numeric.rug(nrug, numeric.x, jittered.x, ...) } #--- draw.degree1 starts here x1 <- x[,ipred] numeric.x <- jittered.x <- as.numeric(x1) jittered.x <- apply.jitter(numeric.x, jitter) xlim <- get.degree1.xlim(ipred, xframe, ux.list, ndiscrete, pt.col, jittered.x, xflip, ...) # title of the current plot main <- dota("main", ...) main <- if(is.specified(main)) repl(main, isingle)[isingle] else { main <- "" if(nfigs > 1 && !is.degree.specified(degree1)) main <- paste0(isingle, " ") # show plot number in headers paste(main, abbr.pred.names[ipred]) } xlevnames <- abbreviate(levels(xframe[,ipred]), minlength=6, strict=TRUE) xaxis.is.levs <- is.factor(x1) && length(xlevnames) <= 12 yaxis.is.levs <- length(resp.levs) >= 1 && length(resp.levs) <= 12 if(yaxis.is.levs) ylevnames <- abbreviate(resp.levs, minlength=6, strict=TRUE) yaxis.is.levs <- FALSE # TODO should only do this if response is a string or a factor xlab <- dota("xlab", ...) xlab <- if(is.null(xlab)) abbr.pred.names[ipred] else if(is.specified(xlab)) repl(xlab, isingle)[isingle] else "" ylab <- dota("ylab", DEF=NULL, ...) ylab <- if(is.specified(ylab)) repl(ylab, isingle)[isingle] else "" call.plot(graphics::plot.default, PREFIX="degree1.", TRACE = if(isingle == 1 && trace >= 2) trace-1 else 0, force.x = xframe[,ipred], force.y = yhat, force.type = "n", # nothing in interior of plot yet force.main = main, force.xlab = xlab, force.ylab = ylab, force.xlim = xlim, force.ylim = ylim, def.xaxt = if(xaxis.is.levs) "n" else "s", def.yaxt = if(yaxis.is.levs) "n" else "s", ...) if(yaxis.is.levs) # plot y level names along the y axis mtext(ylevnames, side=2, at=1:length(ylevnames), cex=par("cex") * cex.lab, line=.5, las=get.las(ylevnames)) if(center && !is.specified(grid.col) && !is.specified(dota("col.grid", ...))) abline(h=0, col="gray", lwd=.6) # gray line at y=0 temp <- get.y.shift.scale(pt.col, ylim, uy, ndiscrete, trace) yshift <- temp$yshift yscale <- temp$yscale if(is.factor(x1)) draw.degree1.fac(...) else draw.degree1.numeric(...) if(is.int.only) # make it obvious that this is an intercept-only model legend("topleft", "intercept-only model", bg="white") } #--- plot_degree1 starts here trace2(trace, "--plot.degree1(draw.plot=%s)\n", if(draw.plot) "TRUE" else "FALSE") # get the x matrix we will plot, will be updated later for each predictor one by one if(!is.null(degree1.xgrid.global)) # already have the data? xgrid <- degree1.xgrid.global # yes, use it else { xgrid <- get.degree1.xgrid(x, grid.func, grid.levels, pred.names, ngrid1) if(!draw.plot) # save the data, if there is going to be a next time assignInMyNamespace("degree1.xgrid.global", xgrid) } if(!is.null(partdep.x.global)) # already have partdep.x? partdep.x <- partdep.x.global # yes use it else { partdep.x <- get.partdep.x(pmethod, x, y, n.apartdep, grid.levels, pred.names) if(!draw.plot) # save the data, if there is going to be a next time assignInMyNamespace("partdep.x.global", partdep.x) } if(pmethod == "plotmo" && draw.plot && trace >= 0 && ncol(xgrid) > 1) print_grid_values(xgrid, trace) cex.lab <- dota("cex.lab", DEF=.8 * par("cex.main"), ...) all.yhat <- NULL for(isingle in seq_along(singles)) { if(isingle == 2 && trace2 == 2) { trace2 <- 1 printf("Reducing trace level for subsequent degree1 plots\n") } ipred <- singles[isingle] # ipred is the predictor index i.e. col in model mat # following happens with lm if you do e.g. ozone1$doy <- NULL after using ozone1 # this won't catch all such errors if(ipred > NCOL(x)) stop0("illegal index=", ipred, " (missing column in x?) NCOL(x)=", NCOL(x)) temp <- get.degree1.data(isingle) xframe <- temp$xframe yhat <- temp$yhat intervals <- temp$intervals all.yhat <- temp$all.yhat if(draw.plot) draw.degree1(...) } all.yhat # numeric vector of all predicted values } # When we are predicting a probability (0 to 1), we want the displayed # points to be on the plot, even if factor levels are say 1 and 2. # In that situation, we scale the displayed points into range 0...1. get.y.shift.scale <- function(pt.col, ylim, uy, ndiscrete, trace) { yshift <- 0 yscale <- 1 if(is.specified(pt.col)) { # for efficiency, only calculate if necessary ymin <- min(uy) ymax <- max(uy) if(is.specified(ylim[1]) && round(ylim[1]) >= 0 && is.specified(ylim[2]) && round(ylim[2]) <= 1 && # check that y is a factor (or factor-like) round(ymax) == ymax && length(uy) <= ndiscrete && min(uy) >= 0) { yshift <- -ymin yscale <- 1 / (yshift + ymax) trace2(trace, "Will shift and scale displayed points specified by pt.col: yshift %g yscale %g\n", yshift, yscale) } } list(yshift=yshift, yscale=yscale) } get.degree1.xlim <- function(ipred, xframe, ux.list, ndiscrete, pt.col, jittered.x, xflip, ...) { xlim <- dota("xlim", ...) if(is.specified(xlim)) stopifnot(is.numeric(xlim), length(xlim) == 2) else { x1 <- xframe[,ipred] xlim <- range1(x1) if(is.factor(x1)) { xlim[1] <- xlim[1] - .4 xlim[2] <- xlim[2] + .4 } else if(length(ux.list[[ipred]]) <= ndiscrete) xlim <- c(xlim[1] - .1, xlim[2] + .1) if(is.specified(pt.col)) xlim <- range1(xlim, jittered.x) } xlim <- fix.lim(xlim) if(xflip) { temp <- xlim[1] xlim[1] <- xlim[2] xlim[2] <- temp } xlim } apply.jitter <- function(x, jitter, adjust=1) { if(jitter == 0) return(x) jitter(x, factor=adjust * jitter) } get.iresponse <- function(npoints, ncases) # get indices of xrows { check.integer.scalar(npoints) if(npoints == 0) return(NULL) if(npoints == 1) npoints <- -1 if(npoints <= 1 || npoints > ncases) # -1 or TRUE means all cases npoints <- ncases if(npoints == ncases) seq_len(ncases) else sample(seq_len(ncases), size=npoints, replace=FALSE) } draw.smooth1 <- function(smooth.col, x, ipred, y, ux.list, ndiscrete, center, ...) { if(!is.specified(smooth.col)) return(NULL) x1 <- x[,ipred] is.discrete.x <- FALSE if(is.factor(x1)) { is.discrete.x <- TRUE levels <- sort_unique(as.numeric(x1)) } else if(length(ux.list[[ipred]]) <= ndiscrete) { is.discrete.x <- TRUE levels <- ux.list[[ipred]] } if(is.discrete.x) { # x1 has discrete levels, display the mean y at each value of x1 smooth <- sapply(split(y, x1), mean) if(center) smooth <- my.center(smooth) else smooth call.plot(graphics::lines.default, PREFIX="smooth.", drop.f=1, force.x = levels, force.y = smooth, force.col = smooth.col, force.lty = dota("smooth.lty lty.smooth", EX=c(0,1), DEF=1, NEW=1, ...), force.lwd = dota("smooth.lwd lwd.smooth lwd.loess", EX=c(0,1,1), DEF=1, NEW=1, ...), force.pch = dota("smooth.pch", DEF=20, EX=0, ...), def.type = "b", ...) } else { # For less smoothing (so we can better judge earth inflection points), # we use a default value for f lower than the default 2/3. smooth.f <- dota("smooth.f loess.f", DEF=.5, NEW=1, ...) check.numeric.scalar(smooth.f) stopifnot(smooth.f > .01, smooth.f < 1) smooth <- lowess(x1, y, f=smooth.f) y <- if(center) my.center(smooth$y) else smooth$y call.plot(graphics::lines.default, PREFIX="smooth.", drop.f=1, force.x = smooth$x, force.y = y, force.col = smooth.col, force.lty = dota("smooth.lty lty.smooth", EX=c(0,1), DEF=1, NEW=1, ...), force.lwd = dota("smooth.lwd lwd.smooth lwd.loess", EX=c(0,1,1), DEF=1, NEW=1, ...), force.pch = dota("smooth.pch", DEF=20, EX=0, ...), ...) } } draw.degree1.numeric.rug <- function(nrug, numeric.x, jittered.x, ...) { if(is.character(nrug)) draw.density.along.the.bottom(numeric.x, ...) else { # must be numeric nrug check.integer.scalar(nrug, logical.ok=TRUE) rug.x <- # nrug < 0 is for backwards compat if(nrug == 1 || nrug < 0 || nrug > length(numeric.x)) jittered.x else if(nrug > 0) quantile(numeric.x, probs=seq(from=0, to=1, length.out=nrug+1), na.rm=TRUE, names=FALSE) else NA if(length(rug.x) > 1) { stopifnot(length(jittered.x) == length(numeric.x)) call.plot(graphics::rug, force.x=rug.x, def.quiet=TRUE, ...) } } } draw.grid <- function(grid.col, nx=NULL, ...) { if(is.specified(grid.col) || is.specified(dota("col.grid", ...))) { if(is.specified(grid.col) && is.logical(grid.col) && grid.col) grid.col <- "lightgray" grid.col <- if(is.specified(grid.col)) grid.col else dota("col.grid", DEF="lightgray", ...) # grid() doesn't have a dots arg so we invoke call.plot without dots call.plot(graphics::grid, force.nx = dota("grid.nx", DEF=nx, ...), force.ny = dota("grid.ny", DEF=NULL, ...), force.col = grid.col, force.lty = dota("grid.lty", DEF=1, ...), force.lwd = dota("grid.lwd", DEF=1, ...)) } } get.level.shades <- function(intervals, ...) { level.shade <- dota("level.shade shade.pints", DEF="mistyrose2", ...) if(is.null(intervals$lwr) || is.null(intervals$cint.lwr)) c(level.shade, level.shade) else { # use level.shade2 only if two kinds of intervals # use exact match here because level.shade2 is also matched by level.shade level.shade2 <- dota("level.shade2 shade2.pints", DEF="mistyrose4", ...) c(level.shade, level.shade2) } } # draw std err bars for a numeric predictor draw.numeric.intervals <- function(x, intervals, ...) { if(!is.null(intervals)) { level.shades <- get.level.shades(intervals, ...) if(!is.null(intervals$lwr)) polygon1(x=x, lwr=intervals$lwr, upr=intervals$upr, shade=level.shades[1], ...) if(!is.null(intervals$cint.lwr)) polygon1(x=x, lwr=intervals$cint.lwr, upr=intervals$cint.upr, shade=level.shades[2]) if(!is.null(intervals$lwr) || !is.null(intervals$cint.lwr)) box() # replot the box because intervals sometimes drawn over it } } # TODO you can't get just the confidence lines with no shading, following looks not ok: # plotmo(a, level=.8, level.lty=1, level.border=1, level.shade=2, level.density=0) polygon1 <- function(x, lwr, upr, shade, ...) { call.plot(graphics::polygon, PREFIX="level.", drop.shade=1, drop.shade2=1, force.x = c(x[1], x, rev(x)), force.y = c(lwr[1], lwr, rev(upr)), force.col = shade, def.border = shade, def.lty = 0, ...) } # draw std err bands for a factor predictor draw.fac.intervals <- function(x, intervals, ...) { draw.intervals <- function(lwr, upr, shade) { for(ilev in seq_along(levels(x))) { min <- min(lwr[[ilev]]) max <- max(upr[[ilev]]) polygon(c(ilev - .4, ilev - .4, ilev + .4, ilev + .4), c(min, max, max, min), col=shade, border=shade, lty=0) } } if(!is.null(intervals)) { level.shades <- get.level.shades(intervals, ...) if(!is.null(intervals$lwr)) draw.intervals(split(intervals$lwr, x), split(intervals$upr, x), level.shades[1]) if(!is.null(intervals$cint.lwr)) draw.intervals(split(intervals$cint.lwr, x), split(intervals$cint.upr, x), level.shades[2]) if(!is.null(intervals$lwr) || !is.null(intervals$cint.lwr)) box() # replot the box because intervals sometimes drawn over it } } # draw the func arg, if specified draw.func <- function(func, object, xframe, ipred, center, trace, ...) { if(!is.null(func)) { print_summary(xframe, "Data for func", trace) if(!is.function(func)) stop0("'func' is not a function"); y <- process.y(func(xframe), object, type="response", nresponse=1, nrow(xframe), expected.levs=NULL, trace, "func returned")$y if(center) y <- my.center(y, trace) call.plot(graphics::lines.default, PREFIX="func.", force.x = xframe[,ipred], force.y = y, def.type = "l", force.col = dota("func.col col.func", EX=c(0,1), DEF="lightblue3", NEW=1, ...), force.lty = dota("func.lty lty.func", EX=c(0,1), DEF=1, NEW=1, ...), force.lwd = dota("func.lwd lwd.func", EX=c(0,1), DEF=2, NEW=1, ...), ...) } } get.def.nticks <- function(x, ipred1, ipred2) # for persp plot { # nticks is just a suggestion for persp, so we don't fret over it too much nticks <- 5 # default nticks if both axes numeric (no factors) if(is.factor(x[[ipred1]])) # use number of factor levels to nticks <- length(levels(x[[ipred1]])) # avoid e.g. "1.5" on factor axes if(is.factor(x[[ipred2]])) nticks <- max(nticks, length(levels(x[[ipred2]]))) nticks <- max(nticks, 2) # must be at least 2 min(nticks, 6) # but not more than 6 (not enough space) } plot_degree2 <- function( # plot all degree2 graphs # copy of args from plotmo, some have been tweaked slightly object, degree2, all2, center, ylim, type, nresponse, pmethod, clip, trace, trace2, pt.col, jitter, iresponse, inverse.func, grid.func, grid.levels, extend, type2, ngrid2, # the following args are generated in plotmo draw.plot, # draw.plot=FALSE means get and return all.yhat but don't actually plot do.par, x, y, pairs, resp.levs, ux.list, ndiscrete, pred.names, abbr.pred.names, nfigs, nsingles, npairs, xflip, yflip, swapxy, def.cex.main, n.apartdep, ...) { get.degree2.data <- function(ipair) { data <- degree2.data(ipair) if(!is.null(data)) # data is already initialized? return(data) # yes, use it # create data.frame of x values to be plotted, # by updating xgrid for this predictor (two columns get updated) # (but for partdep plots, xframe isn't used, we use just x1grid and x2grid) temp <- get.degree2.xframe(xgrid, x, ipred1, ipred2, ngrid2, xranges, ux.list, ndiscrete) xframe <- temp$xframe # data frame of medians x1grid <- temp$x1grid # vec of values for the first predictor x2grid <- temp$x2grid # vec of values for the second predictor trace2(trace, "degree2 plot%d (pmethod \"%s\") variables %s:%s\n", ipair, pmethod, pred.names[ipred1], pred.names[ipred2]) if(pmethod == "partdep" || pmethod == "apartdep") { # following commented out because causes warning in R 4.2.0: length(x) = 91 > 1' in coercion to 'logical(1)' # stopifnot(!is.na(partdep.x) && !is.null(partdep.x)) yhat <- degree2.partdep.yhat(object, type, nresponse, pmethod, inverse.func, trace, partdep.x, x1grid, ipred1, x2grid, ipred2, pred.names, resp.levs, ...) } else { # classic plotmo plot yhat <- plotmo_predict(object, xframe, nresponse, type, resp.levs, trace2, inverse.func, ...)$yhat } x1grid <- as.numeric(x1grid) x2grid <- as.numeric(x2grid) # image plots for factors look better if not blockified if(type2 != "image") { temp <- blockify.degree2.frame(x, yhat, x1grid, x2grid, ipred1, ipred2, ux.list, ndiscrete) yhat <- temp$yhat x1grid <- temp$x1grid x2grid <- temp$x2grid } if(center) yhat <- my.center(yhat, trace2) data <- list(xframe=xframe, x1grid=x1grid, x2grid=x2grid, yhat=matrix(yhat, nrow=length(x1grid), ncol=length(x2grid)), def.nticks=get.def.nticks(x, ipred1, ipred2)) if(!draw.plot) # save the data, if there is going to be a next time degree2.data(ipair, data) data } draw.degree2 <- function(type2 = c("persp", "contour", "image"), def.nticks, ...) { name1 <- abbr.pred.names[ipred1] name2 <- abbr.pred.names[ipred2] # title of the current plot main <- dota("main", ...) main <- if(is.specified(main)) repl(main, nsingles+ipair)[nsingles+ipair] else { main <- "" if(nfigs > 1 && !is.degree.specified(degree2)) main <- paste0(ipair, " ") # show plot number in headers if(swapxy) paste0(main, name2, ": ", name1) else paste0(main, name1, ": ", name2) } if(clip) { yhat[yhat < ylim[1]] <- NA # we don't clip upper values for persp plot because its own clipping is ok # (whereas its own clipping for lower values tends to allow overwrite of axes). if(type2 != "persp") yhat[yhat > ylim[2]] <- NA } switch(type2, persp=plot.persp( x=x, x1grid=x1grid, x2grid=x2grid, yhat=yhat, name1=name1, name2=name2, ipred1=ipred1, ipred2=ipred2, ipair=ipair, nsingles=nsingles, trace=trace, ylim=ylim, xflip=xflip, yflip=yflip, swapxy=swapxy, ngrid2=ngrid2, main2=main, ticktype2=ticktype, def.cex.main=def.cex.main, def.nticks=def.nticks, ...), contour=plot.contour( x=x, x1grid=x1grid, x2grid=x2grid, yhat=yhat, name1=name1, name2=name2, ipred1=ipred1, ipred2=ipred2, xflip=xflip, yflip=yflip, swapxy=swapxy, main2=main, pt.col=pt.col, jitter=jitter, ux.list=ux.list, ndiscrete=ndiscrete, iresponse=iresponse, ...), image=plot.image( x=x, x1grid=x1grid, x2grid=x2grid, yhat=yhat, name1=name1, name2=name2, ipred1=ipred1, ipred2=ipred2, xflip=xflip, yflip=yflip, swapxy=swapxy, main2=main, pt.col=pt.col, jitter=jitter, ux.list=ux.list, ndiscrete=ndiscrete, iresponse=iresponse, ...)) } #--- plot_degree2 starts here trace2(trace, "--plot.degree2(draw.plot=%s)\n", if(draw.plot) "TRUE" else "FALSE") stopifnot(npairs > 0) # need ticktype to determine degree2 margins ticktype <- dota("persp.ticktype", DEF="simple", EX=0, ...) ticktype <- match.choices(ticktype, c("simple", "detailed"), "ticktype") simple.ticktype <- substr(ticktype, 1, 1) == "s" if(draw.plot) { if(do.par) { opar=par("mar", "mgp") on.exit(par(mar=opar$mar, mgp=opar$mgp)) do.degree2.auto.par(type2, nfigs, simple.ticktype) } else if(nsingles && type2 == "persp") { # persp needs smaller margins than degree1 plots # the nsingles check above prevents us from modifying margins # if the user is simply plotting one or more degree2 plots opar=par("mar", "mgp") on.exit(par(mar=opar$mar, mgp=opar$mgp)) do.persp.auto.par(simple.ticktype) } } # get the x matrix we will plot, will be updated later for each pair of predictors xranges <- get.degree2.xranges(x, extend, ux.list, ndiscrete) if(!is.null(degree2.xgrid.global)) # already have the data? xgrid <- degree2.xgrid.global # yes, use it else { xgrid <- get.degree2.xgrid(x, grid.func, grid.levels, pred.names, ngrid2) if(!draw.plot) # save the data, if there is going to be a next time assignInMyNamespace("degree2.xgrid.global", xgrid) } if(!is.null(partdep.x.global)) # already have partdep.x? partdep.x <- partdep.x.global # yes use it else { partdep.x <- get.partdep.x(pmethod, x, y, n.apartdep, grid.levels, pred.names) if(!draw.plot) # save the data, if there is going to be a next time assignInMyNamespace("partdep.x.global", partdep.x) } all.yhat <- NULL for(ipair in seq_len(npairs)) { ipred1 <- pairs[ipair,1] # index of first predictor ipred2 <- pairs[ipair,2] # index of second predictor if(ipair == 2 && trace2 == 2) { trace2 <- 1 printf("Reducing trace level for subsequent degree2 plots\n") } temp <- get.degree2.data(ipair) xframe <- temp$xframe x1grid <- temp$x1grid x2grid <- temp$x2grid yhat <- temp$yhat all.yhat <- c(all.yhat, yhat) if(draw.plot) draw.degree2(type2, temp$def.nticks, ...) } all.yhat } get.degree2.xranges <- function(x, extend, ux.list, ndiscrete) { # we use a data.frame for xranges so columns can have different types (e.g. Dates) xranges <- as.data.frame(matrix(NA, ncol=ncol(x), nrow=2)) colnames(xranges) <- colnames(x) for(icol in seq_len(ncol(x))) { x1 <- x[,icol] xrange <- range1(x1, na.rm=TRUE) nxvals <- length(ux.list[[icol]]) # TODO this extends xrange correctly but that doesn't suffice # because get.degree2.xframe doesn't necessarily use xranges if(extend != 0 && nxvals > ndiscrete && !is.factor(x1)) { stopifnot(xrange[2] >= xrange[1]) ext <- extend * (xrange[2] - xrange[1]) xrange[1] <- xrange[1] - ext xrange[2] <- xrange[2] + ext } xranges[,icol] <- xrange } xranges } draw.response.sites <- function(x, ipred1, ipred2, pt.col, jitter, ux.list, ndiscrete, iresponse, swapxy, ...) { if(swapxy) { x1 <- x[,ipred2] x2 <- x[,ipred1] } else { x1 <- x[,ipred1] x2 <- x[,ipred2] } points.or.text( x=apply.jitter(as.numeric(x1), jitter, adjust=1.5), y=apply.jitter(as.numeric(x2), jitter, adjust=1.5), pt.col=pt.col, iresponse=iresponse, ...) } get.diag.val <- function(yhat, diag1, diag2) # return first non NA along diag { vals <- yhat[diag1, diag2] (vals[!is.na(vals)])[1] # return first non NA in vals, length zero if all NA } plot.persp <- function(x, x1grid, x2grid, yhat, name1, name2, ipred1, ipred2, ipair, nsingles, trace, ylim, xflip, yflip, swapxy, ngrid2, main2, ticktype2, def.cex.main, def.nticks, ...) { get.theta <- function(...) # theta arg for persp() { theta <- dota("persp.theta theta", EX=c(0,1), ...) if(anyNA(theta)) { # theta not specified by the user? # rotate graph so highest point is farthest (this can swap axes) # imax corner numbering with theta=-35 # 1 # 2 /\ 4 # \/ # 3 theta <- -35 nr <- nrow(yhat) nc <- ncol(yhat) imax <- which.max(c( get.diag.val(yhat, nr:1, nc:1), get.diag.val(yhat, 1:nr, nc:1), get.diag.val(yhat, 1:nr, 1:nc), get.diag.val(yhat, nr:1, 1:nc))) if(length(imax)) # length>0 unless entire diag is NA theta <- theta + switch(imax, 0, 90, 180, 270) } theta } #--- plot.persp starts here # following needed because persp() rejects a reversed xlim or ylim if(xflip) warning0("ignoring xflip=TRUE for persp plot") if(yflip) warning0("ignoring yflip=TRUE for persp plot") theta <- get.theta(...) cex1 <- par("cex") # persp needs an explicit cex arg, doesn't use par("cex") trace2(trace, "persp(%s:%s) theta %.3g\n", name1, name2, theta) if(swapxy) { temp <- x1grid; x1grid <- x2grid; x2grid <- temp # swap x1grid and x2grid temp <- ipred1; ipred1 <- ipred2; ipred2 <- temp # swap ipred1 and ipred2 temp <- name1; name1 <- name2; name2 <- temp # swap name1 and name2 yhat <- t(yhat) } zlab <- dota("ylab", DEF="", ...) # use ylab as zlab if specified zlab <- repl(zlab, nsingles+ipair)[nsingles+ipair] # zlab <- paste0("\n", zlab) # else zlab is too close to axis labels cex.lab <- dota("persp.cex.lab", # make the labels small if multiple figures DEF=if(def.cex.main < 1) .8 * def.cex.main else 1, ...) # persp ignores mgp so prefix a newline to space the axis label # we also prepend spaces else bottom of label tends to get cut off if(theta < 0) theta <- theta + 360 theta <- theta %% 360 if((0 < theta && theta <= 90) || (180 < theta && theta <= 270)) { xlab <- paste0("\n", name1, " ") ylab <- paste0("\n ", name2) } else { xlab <- paste0("\n ", name1) ylab <- paste0("\n", name2, " ") } # We use deprefix directly (and not call.plot) because # we have to do a bit of manipulation of the args for nticks. # Also we cannot use graphics:::persp.default because CRAN check complains # about ":::". Instead we explicitly pass the formal argnames with formals. persp.def.formals <- c( # formal args for persp.default (R version 3.2.0) "x", "y", "z", "xlim", "zlim", "xlab", "ylab", "zlab", "main", "sub", "theta", "phi", "r", "d", "scale", "expand", "col", "border", "ltheta", "lphi", "shade", "box", "axes", "nticks", "ticktype") args <- deprefix(graphics::persp, # calls persp.default FNAME = "persp", KEEP = "PREFIX,PLOT.ARGS", FORMALS = persp.def.formals, TRACE = if(ipair == 1 && trace >= 2) trace-1 else 0, force.x = x1grid, force.y = x2grid, force.z = yhat, force.xlim = range(x1grid), # prevent use of user specified xlim and ylim force.ylim = range(x2grid), # persp won't accept zlim=NULL force.zlim = if(is.null(ylim)) ylim <- range(yhat) else ylim, force.xlab = xlab, force.ylab = ylab, force.theta = theta, force.phi = dota("persp.phi phi", EX=c(0,1), DEF=30, ...), force.d = dota("persp.d dvalue", EX=c(0,1), DEF=1, ...), force.main = main2, def.cex.lab = cex.lab, def.cex.axis = cex.lab, def.zlab = zlab, def.ticktype = "simple", def.nticks = def.nticks, def.cex = cex1, force.col = dota("persp.col col.persp", EX=c(0,1), DEF="lightblue", NEW=1, ...), def.border = NULL, def.shade = .5, ...) # if ticktype="simple" we must call persp without the nticks arg # else persp emits confusing error messages if(substr(ticktype2, 1, 1) == "s") args["nticks"] <- NULL # We use suppressWarnings below to suppress the warning # "surface extends beyond the box" that was introduced in R 2.13-1. # This warning may be issued multiple times and may be annoying to the plotmo user. # (Unfortunately this also suppress any other warnings in persp.) # TODO Want to use lab=c(2,2,7) or similar in persp but persp ignores it suppressWarnings( do.call.trace(graphics::persp, args, fname="graphics::persp", trace=0)) } plot.contour <- function(x, x1grid, x2grid, yhat, name1, name2, ipred1, ipred2, xflip, yflip, swapxy, main2, pt.col, jitter, ux.list, ndiscrete, iresponse, ...) { get.lim <- function(xflip, x1grid, ipred) { # contour() automatically extends ylim, so we don't need to do it here xrange <- range(x1grid) if(xflip) c(xrange[2], xrange[1]) else c(xrange[1], xrange[2]) } #--- plot.contour starts here x1 <- x[,ipred1] x2 <- x[,ipred2] levnames1 <- levels(x1) levnames2 <- levels(x2) is.fac1 <- is.factor(x1) && length(levnames1) <= 12 is.fac2 <- is.factor(x2) && length(levnames2) <= 12 xlab <- if(is.fac1) "" else name1 # no lab if fac else on top of lev name ylab <- if(is.fac2) "" else name2 if(swapxy) { temp <- levnames2; levnames2 <- levnames1; levnames1 <- temp temp <- is.fac2; is.fac2 <- is.fac1; is.fac1 <- temp temp <- ylab; ylab <- xlab; xlab <- temp } xlim <- get.lim(xflip, x1grid, ipred1) ylim <- get.lim(yflip, x2grid, ipred2) if(swapxy) { temp <- xlim; xlim <- ylim; ylim <- temp } levels <- get.contour.levs(yhat) labels <- signif(levels, 2) # else contour prints labels like 0.0157895 cex.lab <- par("cex") * dota("cex.lab", DEF=1, ...) # We use suppressWarnings below to suppress the warning "all z values are # equal" This warning may be issued multiple times and may be annoying to # the plotmo user. (Unfortunately this also suppress any other warnings # in contour.default.) suppressWarnings( call.plot(graphics::contour.default, force.x = if(swapxy) x2grid else x1grid, force.y = if(swapxy) x1grid else x2grid, force.z = if(swapxy) t(yhat) else yhat, force.xlim = xlim, force.ylim = ylim, force.xlab = xlab, force.ylab = ylab, def.xaxt = if(is.fac1) "n" else "s", def.yaxt = if(is.fac2) "n" else "s", def.main = main2, def.levels = levels, def.labels = labels, def.labcex = par("cex") * cex.lab, ...)) if(is.fac1) { levnames1 <- abbreviate(levnames1, minlength=6, strict=TRUE) mtext(levnames1, side=1, at=1:length(levnames1), cex=cex.lab, line=.5, las=get.las(levnames1)) } if(is.fac2) mtext(abbreviate(levnames2, minlength=6, strict=TRUE), side=2, at=1:length(levnames2), cex=cex.lab, line=.5, las=2) if(is.specified(pt.col)) draw.response.sites(x=x, ipred1=ipred1, ipred2=ipred2, pt.col=pt.col, jitter=jitter, ux.list=ux.list, ndiscrete=ndiscrete, iresponse=iresponse, swapxy=swapxy, ...) } get.contour.levs <- function(yhat) { # the default, as calculated internally by plot.contour levs <- pretty(range(yhat, finite=TRUE), 10) # reduce the default if the number of unique yhat values is less # this is mainly for factors unique.yhat <- sort_unique(yhat) if(length(unique.yhat) > 1 && length(unique.yhat) < length(levs)) levs <- unique.yhat levs } plot.image <- function(x, x1grid, x2grid, yhat, name1, name2, ipred1, ipred2, xflip, yflip, swapxy, main2, pt.col, jitter, ux.list, ndiscrete, iresponse, ...) { # like image but fill the plot area with lightblue first so NAs are obvious image.with.lightblue.na <- function(x1grid, x2grid, yhat, ...) { if(anyNA(yhat)) { image(x1grid, x2grid, matrix(0, nrow(yhat), ncol(yhat)), col="lightblue", xlab="", ylab="", xaxt="n", yaxt="n", bty="n", main="") par(new=TRUE) # so next plot is on top of this plot } call.plot(graphics::image.default, force.x=x1grid, force.y=x2grid, force.z=yhat, ...) box() # image() tends to overwrite the borders of the box } get.lim <- function(xflip, x1grid, is.discrete) { xrange <- range(x1grid) if(is.discrete) { xrange[1] <- xrange[1] - .5 xrange[2] <- xrange[2] + .5 } else { range <- xrange[2] - xrange[1] # .025 seems the max we can use without getting unsightly # gaps at the edges of the plot xrange[1] <- xrange[1] - .025 * range xrange[2] <- xrange[2] + .025 * range } if(xflip) c(xrange[2], xrange[1]) else c(xrange[1], xrange[2]) } #--- plot.image starts here x1 <- x[,ipred1] x2 <- x[,ipred2] levnames1 <- levels(x1) levnames2 <- levels(x2) use.fac.names1 <- is.factor(x1) && length(levnames1) <= 12 use.fac.names2 <- is.factor(x2) && length(levnames2) <= 12 xlab <- if(use.fac.names1) "" else name1 # no lab if fac else on top of lev name ylab <- if(use.fac.names2) "" else name2 if(swapxy) { temp <- levnames2; levnames2 <- levnames1; levnames1 <- temp temp <- use.fac.names2; use.fac.names2 <- use.fac.names1; use.fac.names1 <- temp temp <- ylab; ylab <- xlab; xlab <- temp } xlim <- get.lim(xflip, x1grid, use.fac.names1 || length(ux.list[[ipred1]]) <= ndiscrete) ylim <- get.lim(yflip, x2grid, use.fac.names2 || length(ux.list[[ipred2]]) <= ndiscrete) # default col: white high values (snowy mountain tops), dark low values (dark depths) if(swapxy) image.with.lightblue.na(x1grid=x2grid, x2grid=x1grid, yhat=t(yhat), force.col = dota("image.col col.image", EX=c(0,1), DEF=grDevices::gray((0:10)/10), NEW=1, ...), force.main = main2, force.xlim = ylim, force.ylim = xlim, force.xaxt = if(use.fac.names1) "n" else "s", force.yaxt = if(use.fac.names2) "n" else "s", force.xlab = xlab, force.ylab = ylab, ...) else image.with.lightblue.na(x1grid=x1grid, x2grid=x2grid, yhat=yhat, force.col = dota("image.col col.image", EX=c(0,1), DEF=grDevices::gray((0:10)/10), NEW=1, ...), force.main = main2, force.xlim = xlim, force.ylim = ylim, force.xaxt = if(use.fac.names1) "n" else "s", force.yaxt = if(use.fac.names2) "n" else "s", force.xlab = xlab, force.ylab = ylab, ...) cex.lab <- par("cex") * dota("cex.lab", DEF=1, ...) if(use.fac.names1) { levnames1 <- abbreviate(levnames1, minlength=6, strict=TRUE) mtext(levnames1, side=1, at=1:length(levnames1), cex=cex.lab, line=.5, las=get.las(levnames1)) } if(use.fac.names2) mtext(abbreviate(levnames2, minlength=6, strict=TRUE), side=2, at=1:length(levnames2), cex=cex.lab, line=.5, las=2) if(is.specified(pt.col)) draw.response.sites(x=x, ipred1=ipred1, ipred2=ipred2, pt.col=pt.col, jitter=jitter, ux.list=ux.list, ndiscrete=ndiscrete, iresponse=iresponse, swapxy=swapxy, ...) } apply.inverse.func <- function(inverse.func, y, object, trace) { if(!is.null(inverse.func)) { if(!is.numeric(y[1])) stopf("inverse.func cannot be used on \"%s\" values", class(y[1])[1]) y <- process.y(inverse.func(y), object, type="response", nresponse=1, length(y), NULL, trace, "inverse.func")$y } y } # should the factor labels on the x axis be printed horizontally or vertically? get.las <- function(labels) { if(length(labels) * max(nchar(labels)) <= 20) # 20 is arbitrary 0 # horizontal else 2 # vertical } # true if a plot was selected by the user (excluding the default setting) is.degree.specified <- function(degree) { !is.logical(degree) || length(degree) > 1 } my.center <- function(x, trace=FALSE) { if(!is.null(x) && !is.factor(x)) { x <- x - mean(x[is.finite(x)], na.rm=TRUE) if(trace >= 2) { name <- paste0("centered ", trunc.deparse(substitute(x))) cat(name, "length ", length(x)) print_first_few_elements_of_vector(x, trace, name) } } x } plotmo/R/predict.R0000644000176200001440000001270313722310234013542 0ustar liggesusers# predict.R: plotmo wrapper functions for predict() # Returns an n x 1 matrix (unless nresponse=NULL then returns an n x q dataframe) # # The newdata argument can be a positive integer n, which is the same as # newdata=NULL but may return only n rows if that is more efficient. # This is for efficiency in plotmo_meta. plotmo_predict <- function(object, newdata, nresponse, type, expected.levs, trace, inverse.func=NULL, ...) { # handle special case where newdata specifies the number of rows nrows <- 0 if(is.numeric(newdata) && length(newdata) == 1 && newdata > 0) { nrows <- newdata newdata <- NULL } if(is.null(newdata)) { # It generally faster to use newdata=NULL. But not all models correctly # process the type argument with null newdata. So here we check for some # models that are known good that way. The inherits function is not # used here because for example a glm model inherits("lm") but with # NULL newdata doesn't process type as we might hope. if(class(object)[1] %in% c("lm", "earth")) trace2(trace, "calling predict.%s with NULL newdata\n", class.as.char(object)) else { # assume object cannot handle newdata=NULL trace2(trace, "plotmo_predict with NULL newdata%s, %s", if(nrows) sprint(" (nrows=%d)", nrows) else "", "using plotmo_x to get the data\n") newdata <- plotmo_x(object, trace) if(nrows) newdata <- newdata[seq_len(nrows),,drop=FALSE] trace2(trace, "will use the above data instead of newdata=NULL for predict.%s\n", class.as.char(object)) } } else print_summary(newdata, "newdata", trace) yhat <- plotmo.predict(object=object, newdata=newdata, type=type, ..., TRACE=if(trace >= 2) trace else trace.call.global) temp <- process.y(yhat, object, type, nresponse, expected.len=nrow(newdata), expected.levs, trace, fname="predict") yhat <- apply.inverse.func(inverse.func, temp$y, object, trace) list(yhat = yhat, # n x 1 matrix (unless nresponse=NULL then an n x q dataframe) resp.levs = temp$resp.levs, resp.class = temp$resp.class) } # TRACE is passed to do.call.trace (if TRACE>0 print the call to predict) plotmo.predict <- function(object, newdata, type, ..., TRACE) { stopifnot.string(type) UseMethod("plotmo.predict") } # this handles a common mistake # (TODO I think this is now pre-empted by plotmo initial tests on model) plotmo.predict.list <- function(object, ...) { stop0("object does not have a predict method") } # plotmo.predict.default calls predict for the given object, # and does tracing and error handling. # # It also allows use to pre-program default args for predict, # which can be overruled or augmented by args passed in dots. # These defaults args must be specified in the calling function. For example # plotmo.predict.default(object, newdata, type=type, def.foo=3, ...) # will pass foo=3 to predict --- unless the caller of plotmo passes # predict.foo=0 to plotmo, which will override the default and pass foo=0 # to predict. # When specifying defaults, use the full arg name (no abbreviations) # prefixed by "def.". plotmo.predict.default <- function( object, newdata, ..., # extra args to predict, first typically is type="xxx" TRACE, # passed to do.call.trace (if TRACE>0 print the call to predict) FUNC=NULL) # predict function, NULL means use stats::predict { fname <- "PREDICTFUNC" if(is.null(FUNC)) { FUNC <- stats::predict fname <- "stats::predict" } # Create arg list for predict. # We invoke deprefix directly (and not call.dots) because we have to # specify a DROP argument and also do a bit of other processing. # OBJECT and NEWDATA must be passed as unnamed arguments to predict, # because different predict methods use different arg names for these. # We want to allow the user to pass normal (unprefixed) dots argument to # predict. So here we use KEEP=NULL but drop any plot arguments, and # any prefixed dot arguments that are necessary elsewhere in plotmo. # We can't specify a FUNC argument to deprefix because we don't # know which specific predict.method will be called (a few lines down). args <- deprefix(FUNC=NULL, DROP=paste0("w1. SHOWCALL FORCEPREDICT PLOT.ARGS PAR.ARGS PLOTMO.ARGS"), PREFIX="predict.", FNAME=fname, force.anon1=object, force.anon2=newdata, ...) yhat <- do.call.trace(func=FUNC, args=args, fname=fname, trace=TRACE) if(is.null(yhat) || length(yhat) == 0) stopf("failed call to predict(%s)", list.as.char(args)) yhat # plausibility of yhat will be checked shortly in plotmo_predict } # Like plotmo.predict.default but first convert newdata to a matrix. # Needed because some predict methods require a matrix, not a data.frame. plotmo.predict.defaultm <- function(object, newdata, type, ..., TRACE, FUNC=NULL) { stopifnot(is.data.frame(newdata)) check.df.numeric.or.logical(newdata) # following calls predict.xxx where xxx is the class of object plotmo.predict.default(object, data.matrix(newdata), type=type, ..., TRACE=TRACE) } plotmo/R/rpart.R0000644000176200001440000000541313375413624013253 0ustar liggesusers# rpart.R: plotmo methods for rpart objects plotmo.type.rpart <- function(object, ..., TRACE) { # use same default as predict.rpart if(object$method == "class") "prob" else "vector" } plotmo.residtype.rpart <- function(object, ..., TRACE) { "usual" } plotmo.singles.rpart <- function(object, x, nresponse, trace, all1, ...) { if(all1 == 2) # return all variables, not just those used in the model return(seq_len(NCOL(x))) # get all variables used in the tree varnames <- as.character(object$frame$var) # factor to character varnames <- unique(varnames[varnames != ""]) match(varnames, colnames(x)) } plotmo.pairs.rpart <- function(object, x, ...) { # we consider rpart variables paired if one is the direct # parent of the other in the tree. irow <- as.integer(row.names(object$frame)) var.names <- character(length=max(irow)) var.names[irow] <- as.character(object$frame$var) # factor to character ivar <- charmatch(var.names, colnames(x)) # following is the same as var.names != "" & var.names !="" is.split <- !is.na(ivar) & ivar > 0 if(sum(is.split) == 0) # no splits? (intercept-only model) return(NULL) pairs <- NULL for(i in 1:length(ivar)) { if(is.split[i]) { left <- 2 * i if(left <= length(ivar) && is.split[left] && ivar[i] != ivar[left]) pairs <- c(pairs, ivar[i], ivar[left]) right <- left + 1 if(right <= length(ivar) && is.split[right] && ivar[i] != ivar[right]) pairs <- c(pairs, ivar[i], ivar[right]) } } if(!is.null(pairs)) pairs <- matrix(pairs, ncol=2, byrow=TRUE) pairs } plotmo.predict.rpart <- function(object, newdata, type, ..., TRACE) { # change option warnPartialMatchDollar to work around issue within predict.rpart: Warning: partial match of 'split' to 'splits' old.warnPartialMatchDollar <- getOption("warnPartialMatchDollar") if(!is.null(old.warnPartialMatchDollar)) on.exit(options(warnPartialMatchDollar=old.warnPartialMatchDollar)) options(warnPartialMatchDollar=FALSE) # do some hand holding to avoid obscure message from predict.rpart pmatch <- pmatch(object$method, c("anova", "class", "exp", "poisson")) if(pmatch == 2) { # class if(!pmatch(type, c("vector", "prob", "matrix", "class"), nomatch=0)) stop0("predict.rpart does not support type=\"", type, "\"") } else if(!pmatch(type, c("vector", "matrix"), nomatch=0)) stop0("predict.rpart does not support type=\"", type, "\" (for \"", object$method, "\" rpart objects)") plotmo.predict.default(object, newdata, type=type, ..., TRACE=TRACE) } plotmo/R/printcall.R0000644000176200001440000001323713724763146014123 0ustar liggesusers# printcall.R: functions for printing call information # If call is specified, print it (where call is from match.call or similar). # Else use the call stack to determine the call. The n arg tells us how # far to go back in the call stack. # # Examples: printcall() describe the call to the current function # printcall(n=2) describe the call to the caller of the current function # printcall(call) describe call where call is from match.call or similar printcall <- function(prefix="", call=NULL, all=FALSE, n=1) { # check prefix and n here, other args checked in call.as.char stopifnot.string(prefix, allow.empty=TRUE) stopifnot(is.numeric(n)) call <- call.as.char(call, all, n+1) printf.wrap("%s%s\n", prefix, call) } # returns args and concise description of their values, dots are included # all=TRUE to include all formal args (not always avail e.g. for primitives) # # TODO Does not expand the dots (just prints "..."), need fixed version of match.call # to expand the dots see e.g. higher.call.to.deprefix (but that would only work # here if dots for caller at n where the same as the dots to printcall). call.as.char <- function(call=NULL, all=FALSE, n=1) { stopifnot(is.numeric(all) || is.logical(all), length(all) == 1) stopifnot(is.numeric(n), length(n) == 1, n > 0) if(is.null(call)) call <- match.call2(all=all, n=n+1) # +1 to skip call to call.as.char else if(all) # we have the call but not the func itself, so can't get formals stop("all=TRUE is not allowed when the call argument is used") fname <- fname.from.call(call) if(all) { formals <- formals(attr(call, "sys.function")) call[[1]] <- NULL # delete func name from call, leave args formals[["..."]] <- NULL # delete ... in formal args if any call <- merge.list(formals, call) } else call[[1]] <- NULL # delete func name from call, leave args ret <- paste(fname, "(", list.as.char(call, maxlen=50), ")", sep="") attr(ret, "fname") <- fname # needed for alignment with nchar in printcall ret } # Similar to match.call but with args "all" and "n". # Also, this always returns a call, even if it is merely "unknown()". # So you can safely call it with any n (although n must be a positive int). match.call2 <- function(all=FALSE, n=1) { stopifnot(is.numeric(all) || is.logical(all), length(all) == 1) stopifnot(is.numeric(n), length(n) == 1, n > 0) # get sys.function and sys.call for the given n, needed for match.call sys.function <- try(sys.function(-n), silent=TRUE) if(is.try.err(sys.function) || is.null(sys.function)) # typically "not that many frames" return(call("unknown")) sys.call <- try(sys.call(-n), silent=TRUE) if(is.try.err(sys.call) || is.null(sys.call)) return(call("unknown")) # TODO following can cause incorrect "... used in a situation where it does not exist" # R version 3.1.4 will fix that issue in match.call (I hope) # envir <- parent.frame(n+1) # use when new version of match.call is ready call <- try(match.call(definition=sys.function, call=sys.call, expand.dots=TRUE), silent=TRUE) if(is.try.err(call)) { # match.call failed, fallback to a weaker description of call # no expansion of dots and no arg values :( call <- sys.call } attr(call, "sys.function") <- sys.function call } callers.name <- function(n=1) { stopifnot(is.numeric(n), length(n) == 1, floor(n) == n, n >= 0) call <- try(sys.call(-(n+1)), silent=TRUE) fname.from.call(call) # will also check if try error } fname.from.call <- function(call) # call was obtained using sys.call() or similar { if(is.try.err(call)) return("unknown") # most likely n was misspecified (too big) if(is.null(call)) # e.g. NULL->source->withVisible->eval->eval->print->test->callers.name return("NULL") caller <- as.list(call)[[1]] if(is.name(caller)) # e.g. foo3(x=1) caller <- as.character(caller) else { # class(caller) is "call" e.g. plotmo::localfunc(x=1) stopifnot(is.call(call)) caller <- format(caller) } if(grepl("function (", substr(caller[1], 1, 10), fixed=TRUE)) paste0("function(", paste.trunc(strip.space.collapse(substring(caller, 11))), ")") else paste.trunc(strip.space.collapse(caller)) } # if EVAL is FALSE this will print something like xlim=..1, ylim=..2 # TODO add n arg when match.call is fixed (R version 3.2.1) # TODO also then make this callable as printdots() instead of printdots(...) printdots <- function(..., EVAL=TRUE, PREFIX=sprint("%s dots: ", callers.name)) { sys.call <- as.list(sys.call()) ensure.dots.present(sys.call) callers.name <- callers.name() printf.wrap("%s%s\n", PREFIX, dots.as.char(..., EVAL=EVAL)) } dots.as.char <- function(..., EVAL=TRUE) { sys.call <- as.list(sys.call()) ensure.dots.present(sys.call) dots <- match.call(expand.dots=FALSE)$... if(is.null(dots)) return("no dots") if(EVAL) { stopifnot(is.numeric(EVAL) || is.logical(EVAL), length(EVAL) == 1) dots <- eval.dotlist(dots) } list.as.char(dots) } # issue error message if ... wasn't used in the call to dots.as.char ensure.dots.present <- function(sys.call) { dots.present <- FALSE for(i in seq_len(length(sys.call))) if(sys.call[i] == "...") dots.present <- TRUE if(!dots.present) stop0("dots.as.char should be invoked with dots, for example dots.as.char(...)") } plotmo/R/c50.R0000644000176200001440000000323714242002364012501 0ustar liggesusers# c50.R: plotmo functions for model objects from the C50 package plotmo.prolog.C5.0 <- function(object, object.name, trace, ...) # invoked when plotmo starts { # "imp" is a vector of variable indices (column numbers in x), most # important vars first, no variables with relative.influence < 1%. imp <- order.C5.0.vars.on.importance(object) attr(object, "plotmo.importance") <- imp if(trace > 0) cat0("importance: ", paste.trunc(object$predictors[imp], maxlen=120), "\n") object } order.C5.0.vars.on.importance <- function(object) { imp <- C50::C5imp(object) stopifnot(is.data.frame(imp) && all(dim(imp) == c(object$dims[2], 1))) imp <- imp[imp >= 1, , drop=FALSE] stopifnot(length(imp) > 0) imp <- match(rownames(imp), object$predictors) stopifnot(!anyNA(imp)) imp } plotmo.singles.C5.0 <- function(object, x, nresponse, trace, all1, ...) { if(all1) return(1:length(object$predictors)) importance <- attr(object, "plotmo.importance") stopifnot(!is.null(importance)) # uninitialized? # indices of vars with importance >= 1%, max of 10 variables # (10 becauses plotmo.pairs returns 6, total is 16, therefore 4x4 grid) importance[1: min(10, length(importance))] } plotmo.pairs.C5.0 <- function(object, ...) { importance <- attr(object, "plotmo.importance") stopifnot(!is.null(importance)) # uninitialized? # choose npairs so a total of no more than 16 plots # npairs=5 gives 10 pairplots, npairs=4 gives 6 pairplots npairs <- if(length(importance) <= 6) 5 else 4 form.pairs(importance[1: min(npairs, length(importance))]) } plotmo/R/partdep.R0000644000176200001440000001133513717363655013572 0ustar liggesusers# partdep.R: functions for partial dependence plots # get the dataframe of variables we integrate over for partdeps get.partdep.x <- function(pmethod, x, y, n.apartdep, grid.levels, pred.names) { if(pmethod != "partdep" && pmethod != "apartdep") return(NA) partdep.x <- if(pmethod == "partdep" || nrow(x) <= n.apartdep) x else { # apartdep stopifnot(nrow(x) == NROW(y)) # order on y with sample_int randomly break ties in y index <- order(as.numeric(y), sample.int(NROW(y))) # select n.apartdep equally spaced rows index <- index[seq.int(1, nrow(x), length.out=n.apartdep)] x[index, , drop=FALSE] } if(!is.null(grid.levels)) { # grid.levels argument was specified? check.grid.levels.arg(x, grid.levels, pred.names) for(ipred in seq_len(ncol(x))) { grid.val <- get.fixed.gridval.for.partdep(x[[ipred]], ipred, pred.names[ipred], grid.levels) if(!is.na(grid.val)) partdep.x[[ipred]] <- grid.val } } partdep.x } check.grid.class <- function(x1, xgrid, predname) # paranoia { class.x1 <- class(x1)[1] class.xgrid <- class(xgrid)[1] # the integer check is necessary because plotmo converts # integer predictors to a numeric range if(!(class.x1 == class.xgrid || (class.x1 == "integer" && class.xgrid == "numeric"))) { cat("\n") stopf("class(%s) == \"%s\" but class(xgrid) == \"%s\"", predname, class.x1, class.xgrid) } } degree1.partdep.yhat <- function(object, type, nresponse, pmethod, inverse.func, trace, # plotmo args partdep.x, xframe, ipred, pred.names, resp.levs, # internal args ...) { trace0(trace, "calculating %s for %s%s", pmethod, pred.names[ipred], if(trace >= 2) "\n" else " ") xgrid <- xframe[[ipred]] # grid of values for predictor nxgrid <- length(xgrid) stopifnot(nxgrid >= 1) check.grid.class(partdep.x[[ipred]], xgrid, pred.names[ipred]) # For efficiency, predict for all values in xgrid at once. # This reduces the number of calls to plotmo_predict, but requires more memory. expanded.partdep.x <- partdep.x[rep(1:nrow(partdep.x), times=nxgrid), , drop=FALSE] expanded.partdep.x[[ipred]] <- rep(xgrid, each=nrow(partdep.x)) # gets recycled # plotmo_predict always returns a numeric 1 x n matrix yhats <- plotmo_predict(object, expanded.partdep.x, nresponse, type, resp.levs, trace, inverse.func, ...)$yhat trace0(trace, "\n") colMeans(matrix(yhats, ncol=nxgrid), na.rm=TRUE) } degree2.partdep.yhat <- function(object, type, nresponse, pmethod, inverse.func, trace, # plotmo args partdep.x, x1grid, ipred1, x2grid, ipred2, # internal args pred.names, resp.levs, ...) { trace0(trace, "calculating %s for %s:%s %s", pmethod, pred.names[ipred1], pred.names[ipred2], if(trace >= 0 && trace < 2) "0" else if(trace >= 2) "\n") n1 <- length(x1grid) stopifnot(n1 >= 1) check.grid.class(partdep.x[[ipred1]], x1grid, pred.names[ipred1]) n2 <- length(x2grid) stopifnot(n2 >= 1) check.grid.class(partdep.x[[ipred2]], x2grid, pred.names[ipred2]) # For efficiency, predict for all values of xgrid2 for each value of xgrid1. # This reduces the number of calls to plotmo_predict, but requires more memory. yhat <- matrix(0., nrow=n1, ncol=n2) # will store predictions in here pacifier.i <- n1 / 10 # for pacifier pacifier.digit <- -1 expanded.partdep.x <- partdep.x[rep(1:nrow(partdep.x), times=n2), , drop=FALSE] for(i in 1:n1) { while(pacifier.i < i) { # print pacifier if(trace >= 0 && pacifier.digit != floor(10 * pacifier.i / n1)) { pacifier.digit <- floor(10 * pacifier.i / n1) cat(pacifier.digit) } pacifier.i <- pacifier.i + n1 / 10 } expanded.partdep.x[[ipred1]] <- x1grid[i] # whole columm all the same value expanded.partdep.x[[ipred2]] <- rep(x2grid, each=nrow(partdep.x)) # gets recycled # plotmo_predict always returns a numeric 1 x n matrix yhats <- plotmo_predict(object, expanded.partdep.x, nresponse, type, resp.levs, trace, inverse.func, ...)$yhat yhats <- matrix(yhats, ncol=n2) yhat[i,] <- colMeans(yhats, na.rm=TRUE) if(trace > 0) trace <- 0 # only show the first call to plotmo_predict } trace0(trace, "0\n") # print final 0 for pacifier matrix(yhat, nrow=n1 * n2, ncol=1) } plotmo/R/gbm.R0000644000176200001440000001121514566064465012675 0ustar liggesusers# gbm.R: plotmo functions for gbm objects # # TODO Add support for plotmo's level argument (quantile regression). plotmo.prolog.gbm <- function(object, object.name, trace, ...) # invoked when plotmo starts { if(is.null(object$data)) # TODO could do more if object had a call component stop0("use keep.data=TRUE in the call to gbm ", "(cannot determine the variable importances)") # "importance" is a vector of variable indices (column numbers in x), most # important vars first, no variables with relative.influence < 1%. We attach # it to the object to avoid calling summary.gbm twice (it's expensive). importance <- order.gbm.vars.on.importance(object) attr(object, "plotmo.importance") <- importance if(trace > 0) cat0("importance: ", paste.trunc(object$var.names[importance], maxlen=120), "\n") object } order.gbm.vars.on.importance <- function(object) { # order=FALSE so importances correspond to orig variable indices importance <- summary(object, plotit=FALSE, # calls summary.gbm order=FALSE, normalize=TRUE)$rel.inf # NA assignment below so order() drops vars with importance < .01 importance[importance < .01] <- NA stopifnot(length(importance) > 0) importance <- order(importance, decreasing=TRUE, na.last=NA) # return a vector of variable indices, most important vars first importance[!is.na(importance)] } plotmo.singles.gbm <- function(object, x, nresponse, trace, all1, ...) { if(all1) return(1:length(object$var.names)) importance <- attr(object, "plotmo.importance") stopifnot(!is.null(importance)) # uninitialized? # indices of vars with importance >= 1%, max of 10 variables # (10 becauses plotmo.pairs returns 6, total is 16, therefore 4x4 grid) importance[1: min(10, length(importance))] } plotmo.pairs.gbm <- function(object, ...) { # pairs of four most important variables (i.e. 6 plots) importance <- attr(object, "plotmo.importance") stopifnot(!is.null(importance)) # uninitialized? # choose npairs so a total of no more than 16 plots # npairs=5 gives 10 pairplots, npairs=4 gives 6 pairplots npairs <- if(length(importance) <= 6) 5 else 4 form.pairs(importance[1: min(npairs, length(importance))]) } # following is used by plotmo.x.gbm and plotmo.x.GBMFit plotmo_x_gbm_aux <- function(x, x.order, var.levels) { stopifnot(!is.null(x)) stopifnot(!is.null(x.order) && !is.null(dim(x.order))) stopifnot(!is.null(var.levels) && is.list(var.levels)) # Return the first ntrain rows of the x matrix. The x matrix is stored # with the gbm object as a vector, so we must convert it back to # a data.frame here, one column for each variable. ntrain <- nrow(x.order) if(is.null(dim(x))) # for efficiency (new versions of gbm don't require this) x <- matrix(x, ncol=ncol(x.order)) stopifnot(ncol(x) == ncol(x.order)) x <- data.frame(x[seq_len(ntrain), ]) colnames(x) <- colnames(x.order) # convert numeric columns that are actually factors # TODO this only works correctly if default ordering of factors was used for(i in seq_len(ncol(x))) if(typeof(var.levels[[i]]) == "character") x[[i]] <- factor(x[[i]], labels=var.levels[[i]]) x } # following is used by plotmo.y.gbm and plotmo.y.GBMFit plotmo_y_gbm_aux <- function(y, x.order) { stopifnot(!is.null(y)) stopifnot(!is.null(x.order) && !is.null(dim(x.order))) ntrain <- nrow(x.order) y[seq_len(ntrain)] } plotmo.x.gbm <- function(object, ...) { plotmo_x_gbm_aux(object$data$x, object$data$x.order, object$var.levels) } plotmo.y.gbm <- function(object, ...) { plotmo_y_gbm_aux(object$data$y, object$data$x.order) } plotmo.predict.gbm <- function(object, newdata, type, ..., TRACE) { # TODO I've only tested the distributions listed below although more may work dist <- gbm.short.distribution.name(object) if(!(dist %in% c("ga", "la", "td", "be", "hu", "ad"))) stop0("gbm distribution=\"", object$distribution$name, "\" is not yet supported\n", " (A direct call to plot_gbm may work)") # The following invokes predict.gbm. # predict.gbm doesn't do partial matching on type so we do it here with pmatch. # n.trees is defaulted so first time users can call plotmo(gbm.model) easily. type = match.choices(type, c("link", "response"), "type") n.trees <- gbm.n.trees(object) plotmo.predict.default(object, newdata, type=type, def.n.trees=n.trees, ..., TRACE=TRACE) } plotmo/R/response.R0000644000176200001440000001570114566065135013765 0ustar liggesusers# response.R: plotmo functions to get the response column from the given newdata # mostly used for calculating RSq on newdata # # TODO overall structure here needs a bit of work plotmo_rsq <- function(object, newdata=NULL, trace=0, nresponse=NA, type=NULL, ...) { init.global.data() # needed if plotmo has never been invoked object.name <- quote.deparse(substitute(object)) use.submodel <- dota("USE.SUBMODEL", DEF=TRUE, ...) # undoc arg (for parsnip models) use.submodel <- is.specified(use.submodel) # TODO revisit, not really reliable because it may use parent.frame attr(object, ".Environment") <- get.model.env(object, object.name, trace, use.submodel) meta <- plotmo_meta(object, type, nresponse, trace, ...) plotmo_rsq1(object=object, newdata=newdata, trace=trace, meta=meta, ...) } plotmo_rsq1 <- function(object, newdata, trace, meta, ...) { trace2(trace, "--plotmo_response for plotmo_rsq1\n") ynew <- plotmo_response(object=object, newdata=newdata, trace=max(0, trace), nresponse=meta$nresponse, type=meta$type, meta=meta, ...) trace2(trace, "--plotmo_predict for plotmo_rsq1\n") yhat <- plotmo_predict(object=object, newdata=newdata, nresponse=meta$nresponse, type=meta$type, expected.levs=meta$expected.levs, trace=trace, inverse.func=NULL, ...)$yhat if(ncol(yhat) != 1 || ncol(ynew) != 1 || nrow(yhat) != nrow(ynew)) { if(trace > -1) { printf("\n") print_summary(ynew, "response", trace=2) printf("\n") print_summary(yhat, "predicted values", trace=2) printf("\n") } stopf("response or predicted values have the wrong dimensions%s", if(trace > -1) " (see above)" else "") } get.weighted.rsq(ynew, yhat) } # If newdata is null, return the fitted response (same as plotmo_y). # # Else extract the response column from newdata. # Use the model object to figure out which column is the response column. plotmo_response <- function(object, newdata=NULL, trace=0, nresponse=NA, type=NULL, meta=NULL, ...) { print_summary(newdata, "--plotmo_response for newdata", trace) object.name <- quote.deparse(substitute(object)) # TODO revisit, not really reliable because it may use parent.frame attr(object, ".Environment") <- get.model.env(object, object.name, trace) if(is.null(meta)) meta <- plotmo_meta(object, type, nresponse, trace, msg.if.predictions.not.numeric="RSq is not available", ...) expected.len <- if(is.null(newdata)) NROW(meta$fitted) else NROW(newdata) y <- NULL if(is.null(newdata)) y <- plotmo_y(object, meta$nresponse, trace, expected.len=expected.len, resp.levs=meta$resp.levs)$y else if(length(dim(newdata)) != 2) stop0("plotmo_response: newdata must be a matrix or data.frame") else { terms <- try(terms(object), silent=TRUE) if(is.try.err(terms) || is.null(terms)) # model doesn't have terms? y <- response.from.xy.model(object, newdata, trace, meta$resp.name) else # model has terms, presumably it was created with a formula y <- get.x.or.y.from.model.frame(object, field="y", trace, naked=FALSE, na.action=na.pass, newdata)$x } if(!is.good.data(y, "response", trace, check.colnames=FALSE)) stop0("response with newdata", format_err_field(y, "response", trace)) y <- cleanup.x.or.y(object, y, "y", trace, check.naked=FALSE) if(!is.good.data(y, check.colnames=FALSE)) stop0("response with newdata", format_err_field(y, "response", trace)) y <- convert.glm.response(object, y, trace) # TODO test this and factor responses # TODO following will sometimes give the wrong results? if(!is.null(meta$nresponse) && meta$nresponse > NCOL(y)) { trace2(trace, "plotmo_response: forcing meta$nresponse=%g to 1 because response has one column\n", nresponse) meta$nresponse <- 1 } process.y(y, object, meta$type, meta$nresponse, expected.len=expected.len, meta$resp.levs, trace, "plotmo_response")$y } # the model was created with the x,y interface (no formula) response.from.xy.model <- function(object, newdata, trace, resp.name) { if(!is.character(resp.name) || length(resp.name) != 1 || !nzchar(resp.name)) { if(trace > 2) { printf("\nresp.name:\n") print(resp.name) printf("\n") } stop0("could not get the response name") } trace2(trace, "response.from.xy.model: resp.name \"%s\"\n", resp.name) # following is for e.g. trees$Volume to Volume in earth(trees[,1:2], trees$Volume) resp.name <- sub(".*\\$", "", resp.name) # Hackery: look for responses of the form trees[,3] or trees[,3,drop=FALSE] # This happens if you build a model like lm(trees[,1:2], trees[,3]) if(grepl("\\[.*,.+\\]", resp.name)) { col.name <- sub("[^,]*,", "", resp.name) # delete up to the comma and the comma col.name <- gsub(",.*", "", col.name) # delete (2nd) comma if any, and all after col.name <- gsub("\\]", "", col.name) # delete final ] if above gsub didn't do it # print a message because we don't always get this right if(trace >= 0) printf("Assuming response %s implies that the response column is %s\n", resp.name, paste(col.name)) # the following will do something like eval(3, env) col.index <- try.eval(parse(text=col.name), model.env(object), trace=trace, expr.name=col.name) if(is.try.err(col.index)) stopf("could not parse the response name %s", resp.name) if(is.null(colnames(newdata))) resp.name <- paste0("newdata[,", col.index, "]") else # TODO is the following correct? resp.name <- paste0(colnames(newdata)[col.index]) y <- newdata[, col.index, drop=FALSE] } else { # resp.name doesn't have [] in it, hopefully it's just a name colnames.newdata <- colnames(newdata) if(is.null(colnames.newdata)) stop0("cannot get response from newdata because newdata has no column names") which <- which(colnames.newdata == resp.name) if(length(which) == 0) stop0("no column names in newdata match the original response name\n", sprint(" Response name: %s\n", resp.name), " Column names in newdata: ", paste.collapse(colnames.newdata)) if(length(which) > 1) stopf("multiple column names in newdata match the original response name %s", resp.name) y <- newdata[, colnames.newdata[which], drop=FALSE] } y } plotmo/R/dotlib.R0000644000176200001440000000664213723577313013410 0ustar liggesusers# dotlib.R: miscellaneous functions for the dots routines # Arguments for par() which take a vector value (i.e. length of value is not one). PAR.VEC <- c("fig", "fin", "lab", "mai", "mar", "mfcol", "mfg", "mfrow", "mgp", "oma", "omd", "omi", "pin", "plt", "usr", "xaxp", "yaxp") # Add the elements of the extra list to the original list. Elements of the # original list that have the same names as extra elements get overwritten. # # Like utils::modifyList(keep.null=TRUE) except: # (i) input args can be NULL (NULL is treated as an empty list) # (ii) unnamed elements in extra are added to original (modifyList drops them) merge.list <- function(original, extra) { if(is.null(original)) original <- list() if(is.null(extra)) return(original) stopifnot(is.list(original)) stopifnot(is.list(extra)) # pairlist would probably be ok too for(i in seq_along(extra)) { e <- extra[[i]] name <- names(extra)[i] if(is.null(name) || !nzchar(name)) # extra element is unnamed? original <- c(original, if(is.null(e)) list(NULL) else e) else if(is.null(e)) original[name] <- list(NULL) # avoid "assign deletes elem if rhs is null" else original[[name]] <- e } original } # Evaluate each element of the list dots in the environment specified by n. # (This function can actually be used any list, but the evaluating # environment and enclosure are set up for dot arg lists.) # # TODO "scalar" is ugly, it is for par() alone and prevents # e.g. error: graphical parameter "lty" has the wrong length eval.dotlist <- function(dots, n=1, scalar=FALSE) { stopifnot(is.list(dots) || is.pairlist(dots)) env <- parent.frame(n) dotnames <- names(dots) for(i in seq_along(dots)) { e <- try(eval(dots[[i]], envir=env, enclos=env), silent=TRUE) if(!is.try.err(e)) { if(is.null(e)) dots[i] <- list(NULL) # avoid "assign deletes elem if rhs is null" else if(!scalar || (dotnames[i] %in% PAR.VEC) || length(e) == 1) dots[[i]] <- e else dots[[i]] <- e[[1]] # select first element of e only # TODO it would be better to drop the element entirely } } dots } # Is the string s a valid R lexigraphic identifier? # If allow.specials=TRUE we allow special chars used in DROP and KEEP strings. # The name argument is used only in error messages. stopifnot.identifier <- function(s, name=short.deparse(substitute(s)), allow.empty=FALSE, allow.specials=FALSE) { if(!is.character(s)) stop0(name, " is not a character variable (class(", name, ") is \"", class(s)[1], "\")") if(length(s) != 1) stop0(name, " has more than one element\n ", name, " = c(", paste.trunc("\"", s, "\"", sep=""), ")") if(!allow.empty && !nzchar(s)) stop0(name, " is an empty string") # TODO the following allows integers (no alphabetic characters), it shouldn't start <- if(allow.specials) # include , * $ regexpr("[^._:[:alnum:],*$]", s) else regexpr("[^._:[:alnum:]]", s) if(start > 0) stop0("illegal character \"", substr(s, start, start), "\" in ", name, " = \"", s, "\"") } plotmo/R/lib.R0000644000176200001440000012676214565634614012712 0ustar liggesusers# lib.R: miscellaneous functions for plotmo and related packages # functions in this file are in alphabetical order any1 <- function(x) { any(x != 0) # like any but no warning if x not logical } cat0 <- function(...) # cat with no added spaces { cat(..., sep="") } check <- function(object, object.name, check.name, check.func, na.ok=FALSE) { any <- check.func(object) if(na.ok) any <- any[!is.na(any)] else { which.na <- which(is.na(any)) if(length(which.na)) { stopf("NA in %s\n %s[%d] is %g", object.name, object.name, which.na[1], object[which.na[1]]) } } if(any(any)) { which <- which(check.func(object)) stopifnot(length(which) > 0) stopf("%s in %s\n %s[%d] is %g", check.name, object.name, object.name, which[1], object[which[1]]) } } # TODO commented out the following because it is too slow for big data # (the as.character is very slow) # # # The args argument is assumed to be a list of arguments for do.call. # # An argument in args will be an unforced promise if it couldn't be # # evaluated earlier e.g. if call.plot was invoked with arg=nonesuch. # # If an argument is such an unforced promise, issue an error message now # # to prevent very confusing error messages later. To do this, we have to # # determine if the arg is a promise, which we do with the if statement # # below. # # This makes me nervous, because the R language manual says "There is # # generally no way in R code to check whether an object is a promise or not". # # check.do.call.args <- function(func, args, fname) # { # stopifnot(is.list(args)) # for(i in seq_along(args)) { # if(length(args[i]) == 1 && !is.na(args[i]) && # substr(as.character(args[i]), 1, 2) == "..") { # printf("\n") # s <- paste0(strwrap(list.as.char(args), # width=getOption("width"), exdent=7), collapse="\n") # stop0("cannot evaluate ", quotify(names(args)[i], "'"), # " in\n ", fname, "(", s, ")") # } # } # } # mostly for checking user arguments (so error wording is for that) # but also occasionally used for other sanity checking check.boolean <- function(b) # b==0 or b==1 is also ok { if(length(b) != 1) stop0("the ", short.deparse(substitute(b), "given"), " argument is not FALSE, TRUE, 0, or 1") if(!(is.logical(b) || is.numeric(b)) || is.na(b) || !(b == 0 || b == 1)) stop0(short.deparse(substitute(b), "the argument"), "=", as.char(b), " but it should be FALSE, TRUE, 0, or 1") b != 0 # convert to logical } is.boolean <- function(b) # b==NA or b==0 or b==1 { length(b) == 1 && (is.logical(b) || is.numeric(b)) && (is.na(b) || b == 0 || b == 1) } check.classname <- function(object, substituted.object, allowed.classnames) { expected.classname <- quotify(allowed.classnames) if(length(allowed.classnames) > 1) expected.classname <- sprint("one of\n%s", expected.classname) if(is.null(object)) stopf("object is NULL but expected an object of class of %s", expected.classname) if(!inherits(object, allowed.classnames)) { stopf("the class of %s is \"%s\" but expected the class to be %s", quotify(paste.trunc(substituted.object, maxlen=30)), class(object)[1], expected.classname) } } # adjust name so e.g. error message is "argument is NULL" not "NULL is NULL" tweak.name <- function(name, quote=TRUE) { quoted.name <- quotify(name, quote="'") if(name %in% c("NULL", "NA") || (substr(name[1], 1, 1) %in% c("+", "-")) || grepl("[0-9]", substr(name[1], 1, 1))) { quoted.name <- name <- "argument" } if(quote) quoted.name else name } check.integer.scalar <- function(object, min=NA, max=NA, null.ok=FALSE, na.ok=FALSE, logical.ok=TRUE, char.ok=FALSE, object.name=short.deparse(substitute(object))) { stop.msg <- function(s) { s.null <- if(null.ok) ", or NULL" else "" s.na <- if(na.ok) ", or NA" else "" s.logical <- if(logical.ok) ", or TRUE or FALSE" else "" s.char <- if(char.ok) ", or a string" else "" stop0(s, " but it should be an integer", s.null, s.na, s.logical, s.char) } if(is.character(object)) { if(!char.ok || length(object) != 1) stop.msg(paste0(tweak.name(object.name), " is a string")) } else { check.numeric.scalar(object, min, max, null.ok, na.ok, logical.ok, char.ok.msg=char.ok, object.name=object.name) if(!is.null(object) && !is.na(object) && object != floor(object)) stop.msg(paste0(tweak.name(object.name, quote=FALSE), "=", object[1])) } object } check.level.arg <- function(level, zero.ok) { if(anyNA(level) || is.null(level)) # treat NA and NULL as 0 level <- 0 check.numeric.scalar(level) if(!((zero.ok && level == 0) || level >= .5 || level < 1)) { stop0("level=", level, " but it should be ", if(zero.ok) "zero or " else "", "between 0.5 and 1") } level } check.no.na.in.mat <- function(object) { if(anyNA(object)) { # quick initial check # detailed check for detailed error message for(icol in seq_along(ncol(object))) { check.name <- if(!is.null(colnames(object))) colnames(object)[icol] else sprint("%s[,%d]", short.deparse(substitute(object), "matrix"), icol) check(object[,icol], check.name, "NA", is.na, na.ok=FALSE) } } } # x can be a data.frame or matrix check.df.numeric.or.logical <- function(x, xname=trunc.deparse(substitute(x))) { stopifnot(!is.null(x), length(dim(x)) == 2) for(icol in seq_len(NCOL(x))) { if(!is.numeric(x[,icol]) && !is.logical(x[,icol])) stopf("the class of %s is \"%s\" (expected numeric or logical)", colname(x, icol, xname), class(x[,icol])) is.na <- is.na(x[,icol]) if(any(is.na)) stopf("%s[%g] is NA", colname(x, icol, xname), which(is.na)[1]) is.infinite <- !is.finite(x[,icol]) if(any(is.infinite)) stopf("%s[%g] is Inf", colname(x, icol, xname), which(is.infinite)[1]) } } check.numeric.scalar <- function(object, min=NA, max=NA, null.ok=FALSE, na.ok=FALSE, logical.ok=FALSE, char.ok.msg=FALSE, # only affects error msg object.name=short.deparse(substitute(object))) { s.logical <- if(logical.ok) ", or TRUE or FALSE" else "" if(na.ok) logical.ok <- TRUE # needed because NA is a logical any.na <- !is.null(object) && # following needed because anyNA gives error on some objects (is.numeric(object) || is.logical(object) || is.list(object) || is.character(object)) && anyNA(object) if(is.null(object)) { if(!null.ok) stop0(tweak.name(object.name), " is NULL") } else if(any.na && !na.ok) stop0(tweak.name(object.name), " is NA") else if(!is.numeric(object) && !(is.logical(object) && logical.ok)) { s.na <- if(na.ok) ", or NA" else "" s.null <- if(null.ok) ", or NULL" else "" s.char <- if(char.ok.msg) ", or a string" else "" stopf("%s must be numeric%s%s%s%s (whereas its current class is %s)", tweak.name(object.name), s.null, s.na, s.char, s.logical, class.as.char(object, quotify=TRUE)) } else if(length(object) != 1) stopf("the length of %s must be 1 (whereas its current length is %d)", tweak.name(object.name), length(object)) if(!is.null(object) && !any.na) { if(!is.na(min) && !is.na(max) && (object < min || object > max)) { stop0(tweak.name(object.name, quote=FALSE), "=", object, " but it should be between ", min, " and ", max) } if(!is.na(min) && object < min) { stop0(tweak.name(object.name, quote=FALSE), "=", object, " but it should be at least ", min) } if(!is.na(max) && object > max) { stop0(tweak.name(object.name, quote=FALSE), "=", object, " but it should not be greater than ", max) } } object } # We allow 20% of x to be nonpositive, useful if the response is essentially # positive, but the predicted response has a few nonpositive values at the extremes. # Needed for example if we will later take log(x) or sqrt(x). check.that.most.are.positive <- function(x, xname, user.arg, non.positive.msg, frac.allowed=.2) { check.numeric.scalar(frac.allowed) stopifnot(frac.allowed >= 0, frac.allowed <= 1) nonpos <- x <= 0 if(sum(nonpos, na.rm=TRUE) > frac.allowed * length(x)) { # more than frac.allowed nonpos? ifirst <- which(nonpos)[1] stop0(sprint( "%s is not allowed because too many %ss are %s\n", user.arg, unquote(xname), non.positive.msg), sprint( " %.2g%% are %s (%g%% is allowed)\n", 100 * sum(nonpos) / length(x), non.positive.msg, 100 * frac.allowed), sprint(" e.g. %s[%d] is %g", unquote(xname), ifirst, x[ifirst])) } } check.vec <- function(object, object.name, expected.len=NA, logical.ok=TRUE, na.ok=FALSE) { if(!(NROW(object) == 1 || NCOL(object) == 1)) stop0(tweak.name(object.name), " is not a vector\n ", "It has dimensions ", NROW(object), " by ", NCOL(object)) if(!((logical.ok && is.logical(object)) || is.numeric(object))) stop0(tweak.name(object.name), " is not numeric") if(!is.na(expected.len) && length(object) != expected.len) stop0(tweak.name(object.name), " has the wrong length ", length(object), ", expected ", expected.len) if(na.ok) object[is.na(object)] <- 1 # prevent check is.finite from complaining else check(object, object.name, "NA", is.na) check(object, object.name, "non-finite value", function(object) {!is.finite(object)}) } cleantry <- function(err) # clean up a try.err (remove "Error: " etc.) { stopifnot(is.try.err(err)) attributes(err) <- NULL err <- gsub("^[^:]*: *", "", err) # remove "Error: " (actually everything up to the first colon) err <- gsub("\n", " ", err, fixed=TRUE) # remove newlines err <- gsub(" +", " ", err) # multiple spaces to single spaces gsub(" $", "", err) # remove trailing space } # returns the column name, if that is not possible then something like x[,1] colname <- function(object, i, object.name=trunc.deparse(substitute(object))) { check.numeric.scalar(i) check.index(i, object.name, object, is.col.index=TRUE, allow.negatives=FALSE) colnames <- safe.colnames(object) if(!is.null(colnames)) colnames[i] else if(NCOL(object) > 1) sprint("%s[,%g]", object.name, i) else sprint(object.name) } # if trace>0 or the func fails, then print the call to func do.call.trace <- function(func, args, fname=short.deparse(deparse(func), "FUNC"), trace=0) { stopifnot(is.logical(trace) || is.numeric(trace), length(trace) == 1) # TODO commented out the following because it is too slow for big data # check.do.call.args(func, args, fname) trace <- as.numeric(trace) if(trace > 0) printf.wrap("%s(%s)\n", fname, list.as.char(args)) try <- try(do.call(what=func, args=args), silent=TRUE) if(is.try.err(try)) { if(trace == 0) # didn't print call above? then print it now printf.wrap("\n%s(%s)\n\n", fname, list.as.char(args)) else if(trace >= 2) # TODO is this best? printf("\n") # Re-call func so user can do a traceback within the function. Note that # if do.call.trace was called with try, this will be caught by that try. # TODO is there a better way to achieve this, perhaps using tryCatch # this could be confusing if func has side effects (unlikely) do.call(what=func, args=args) # should never get here stop0("second do.call(", fname, ", ...) did not give the expected error: ", try[1]) } invisible(try) # TODO is invisible necessary? } # identical to base::eval() but has trace and expr.name arguments eval.trace <- function( expr, envir = parent.frame(), enclos = if(is.list(envir) || is.pairlist(envir)) parent.frame() else baseenv(), trace = 0, expr.name = NULL) { stopifnot(is.environment(envir)) stopifnot(is.environment(enclos)) if(trace >= 2) printf("eval(%s, %s)\n", if(is.null(expr.name)) trunc.deparse(substitute(expr)) else expr.name, environment.as.char(envir)) eval(expr, envir, enclos) } exp10 <- function(x) # e.g. exp10(-3) = 1e-3 { exp(x * log(10)) } # This function is used for checking both xlim and ylim. # This checks that lim is is a 2 element numeric vector. # Also, if xlim[1] == xlim[2], then plot() issues a confusing message. # We don't want that, so use this function to make sure xlim[2] # is different to xlim[1]. fix.lim <- function(lim) { if(!is.null(lim) && !inherits(lim, "Date")) { stopifnot(is.numeric(lim), length(lim) == 2) # constants below are arbitrary small <- max(1e-6, .01 * abs(lim[1] - lim[2])) if(abs(lim[2] - lim[1]) < small) # illegal lim? lim <- c(lim[1] - small, lim[2] + small) } lim } # Ensure all columns of x have column names. Won't overwrite existing column names. gen.colnames <- function(x, prefix="x", alt.prefix=prefix, trace=0) { if(NCOL(x) == 0) return(NULL) # If prefix is long and has characters like ( or [ then use the # alternate prefix. This is sometimes necessary when prefix is # generated using deparse and the arg is something like # "cbind(trees$Volume,trees$Volume+100)" if(any(nchar(prefix) > 30) && grepany("[([,]", prefix)) { trace2(trace, "using alt.prefix \"%s\" instead of prefix \"%s\"\n", alt.prefix, prefix) prefix <- alt.prefix } stopifnot(length(prefix) <= NCOL(x)) prefix <- substr(prefix, 1, 60) new.colnames <- if(NCOL(x) == length(prefix)) prefix else if(grepany("\\[", prefix)) new.colnames <- paste0(prefix, "[", seq_len(NCOL(x)), "]") else new.colnames <- paste0(prefix, seq_len(NCOL(x))) colnames <- org.colnames <- colnames(x) if(is.null(colnames)) colnames <- new.colnames else { missing <- !nzchar(colnames) if(any(missing)) colnames[missing] <- new.colnames[missing] } if(length(unique(colnames)) != length(colnames)) stop0("Duplicate colname in ", paste.trunc(prefix), " (colnames are ", paste.with.quotes(colnames, maxlen=60), ")") if(trace >= 2 && !identical(org.colnames, colnames)) trace2(trace, "colname%s %s now %s\n", if(length(colnames) > 1) "s were" else " was", if(is.null(org.colnames)) "NULL" else paste.trunc(quotify(org.colnames)), paste.trunc(quotify(colnames))) colnames } get.mean.rsq <- function(rss, tss, wp) { if(is.null(wp)) wp <- repl(1, length(rss)) stopifnot(length(rss) == length(tss), length(wp) == length(tss)) total.rsq <- 0 for(iresp in seq_along(rss)) total.rsq <- total.rsq + wp[iresp] * get.rsq(rss[iresp], tss[iresp]) sum(total.rsq) / sum(wp) } # Get the environment for evaluating the model data: # 1. Return the environment in which the model function # was originally called. # 2. Else if the model already has an attribute .Environment, use that. # 3. Else return the environment in which the caller of this function # was called (e.g. return the environment of plotmo's caller). get.model.env <- function(object, object.name="object", trace=0, use.submodel=FALSE) { # check args, because this func is called very early in plotmo (and friends) check.numeric.scalar(trace, logical.ok=TRUE) if(trace >= 2) { callers.name <- callers.name() my.call <- call.as.char(n=2) printf.wrap("%s trace %g: %s\n", callers.name, trace, my.call) printf("--get.model.env for object with class %s\n", class.as.char(object)) } stopifnot.string(object.name) if(is.null(object)) stopf("argument %s is NULL", object.name) if(!is.list(object)) stopf("%s is not an S3 model", object.name) if(class(object)[1] == "list") # some packages build models without a specific class stopf("%s is a plain list, not an S3 model", object.name) obj <- object # Special handling for parsnip models. Their class is like c("_earth", "model_fit"). # For these models, use the env if any saved with the submod (e.g. earth) # (We don't do this for caret models because caret models have a terms field.) # # TODO this code is preliminary (works with parsnip 0.1.3) # and only works if model saves the data (e.g. lm, earth(keepxy=TRUE), not rpart if(use.submodel && inherits(object, "model_fit")) { # parsnip trace2(trace, "plotmo parsnip model: will plot %s$fit, not %s itself\n", gsub("'", "", object.name), object.name) obj <- object[["fit"]] if(!is.list(obj)) # sanity check stopf("plotmo parsnip model: %s$fit is not an S3 model", gsub("'", "", object.name)) # TODO following is temporary, hopefully if(inherits(obj, "rpart") && is.null(obj$model)) stop0( "Cannot plot parsnip rpart model: need model=TRUE in call to rpart\n", " Do it like this: set_engine(\"rpart\", model=TRUE)") } if(trace >= 2) { call <- getCall(obj) if(is.null(call)) printf("object has no call field (it's class is %s)\n", class.as.char(object)) else printf.wrap("object call is %s\n", strip.deparse(call), maxlen=120) } terms <- try(terms(obj), silent=trace < 3) # Following will fail (correctly) for non-formula models because they have no terms. # # TODO Also, if use.submodel, don't use terms (because the term env was # inside the parsnip func that created the submodel) # But that also fails later when we eval the formula because # eval will use GlobalEnv instead of the data passed to the model if(!is.null(terms) && !is.try.err(terms)) { model.env <- attr(terms, ".Environment") if(is.null(model.env)) { if(inherits(obj, "glmnet.formula") || # glmnetUtils package inherits(obj, "cv.glmnet.formula")) if(inherits(obj, "glmnet.formula")) stop0( "for this plot, glmnet.formula must be called with use.model.frame=TRUE") if(inherits(obj, "cv.glmnet.formula")) stop0( "for this plot, cv.glmnet.formula must be called with use.model.frame=TRUE") stop0("attr(terms, \".Environment\") is NULL") } if(!is.environment(model.env)) stop0("attr(terms, \".Environment\") is not an environment") else { trace2(trace, "using the environment saved in $terms of the %s model: %s\n", class.as.char(obj), environment.as.char(model.env)) return(model.env) } } model.env <- attr(obj, ".Environment") if(is.environment(model.env)) { trace2(trace, "using attr(obj,\".Environment\") saved with %s model: %s\n", class.as.char(obj), environment.as.char(model.env)) return(model.env) } if(!is.null(model.env)) stop0("attr(obj, \".Environment\") is not an environment") # n=2 is the caller of the function that called get.model.env # for plotmo it will be the caller of plotmo, typically R_GlobalEnv model.env <- parent.frame(n=2) trace2(trace, "assuming the environment of the %s model is that of %s's caller: %s\n", class.as.char(obj), callers.name, environment.as.char(model.env)) model.env } get.rsq <- function(rss, tss) { rsq <- 1 - rss / tss # following makes testing easier across machines in presence of numerical error rsq[rsq > -1e-5 & rsq < 1e-5] <- 0 rsq } get.weighted.rsq <- function(y, yhat, w=NULL) # NAs will be dropped before calc { stopifnot(length(y) > 0, length(y) == length(yhat)) if(is.null(w)) { is.na <- is.na(y) | is.na(yhat) y <- y[!is.na] yhat <- yhat[!is.na] if(length(y) == 0) stop0("length(y) == 0 after deleting NAs in y or yhat") rss <- sos(y - yhat) tss <- sos(y - mean(y)) } else { stopifnot(length(w) == length(yhat)) is.na <- is.na(y) | is.na(yhat) | is.na(w) y <- y[!is.na] yhat <- yhat[!is.na] w <- w[!is.na] if(length(y) == 0) stop0("length(y) == 0 after deleting NAs in y or yhat or w") rss <- sos(y - yhat, w) tss <- sos(y - weighted.mean(y, w), w) } get.rsq(rss, tss) } # TRUE if pattern is in any of the strings in x grepany <- function(pattern, x, ignore.case=FALSE, ...) { any(grepl(pattern, x, ignore.case=ignore.case, ...)) } # scalar form of ifelse, with short name :-) # only evaluates the "no" argument if necessary ife <- function(ife.test, ife.yes, ife.no) { ife.test <- check.boolean(ife.test) stopifnot(!missing(ife.yes)) stopifnot(!missing(ife.no)) if(ife.test) ife.yes else ife.no } # returns an index, choices is a vector of strings imatch.choices <- function(arg, choices, argname=short.deparse(substitute(arg), "function"), errmsg.has.index=FALSE, # TRUE if integer "arg" is legal elsewhere errmsg="", # error message, "" for automatic errmsg.ext="") # extension to error message { errmsg.ext <- paste0( if(errmsg.has.index) " an integer index or" else "", if(nchar(errmsg.ext)) paste0(" ", errmsg.ext, " or") else "") if(nchar(errmsg) == 0) errmsg <- sprint("Choose%s one of: %s", errmsg.ext, quotify(choices)) if(!is.character(arg) || length(arg) != 1 || !nzchar(arg)) stopf("illegal %s argument\n%s", quotify(argname, "'"), errmsg) if(argname %in% c("NULL", "NA")) argname <- "argument" imatch <- pmatch(arg, choices) if(anyNA(imatch)) { imatch <- NULL for(i in seq_along(choices)) if(pmatch(arg, choices[i], nomatch=0)) imatch <- c(i, imatch) if(length(imatch) == 0) { if(length(choices) == 1) stopf("%s=\"%s\" is not allowed\n Only%s %s is allowed", argname, paste(arg), errmsg.ext, quotify(choices)) else stopf("%s=\"%s\" is not allowed\n%s", argname, paste(arg), errmsg) } if(length(imatch) > 1) stopf("%s=\"%s\" is ambiguous\n%s", argname, paste(arg), errmsg) } imatch } # TRUE if all values in object are integers, ignoring NAs # assumes object is numeric or logical (check this before call this function) is.integral <- function(object) { object <- object[!is.na(object)] length(object) > 0 && is.null(dim(object)) && # prevent error in floor for e.g. survival objects all(floor(object) == object) } # is.specified's main purpose is to see if a plot component should be # drawn, i.e., to see if the component "has a color" is.specified <- function(object) { try <- try(!is.null(object) && !anyNA(object) && !is.zero(object) && # following needed for e.g. col=c("red", 0) because 0 is converted to string !identical(object, "0") && !identical(object, "0L") && !identical(object, "NA"), silent=FALSE) if(is.try.err(try)) { # this occurs if object is say a closure and anyNA fails # anyNA was introduced in R 3.1.0 printf("\n") # separate from any message printed by try() above stop0(deparse(substitute(object)), ": illegal value") } try } is.try.err <- function(object) { class(object)[1] == "try-error" } is.zero <- function(object) # needed because identical(object, 0) fails if object is 0L { identical(object, 0) || identical(object, 0L) } # Lighten color by amount 0 ... 1 where 1 is white. # If amount is negative, then darken the color, -1 is black. lighten <- function(col, lighten.amount, alpha=1) { # stopifnot.scalar(lighten.amount) # stopifnot(lighten.amount >= -1 && lighten.amount <= 1) rgb <- col2rgb(col) / 255 # empirically, sqrt makes visual effect of lighten.amount more linear lighten.amount2 <- sqrt(abs(lighten.amount)) rgb <- if(lighten.amount > 0) rgb + lighten.amount2 * (c(1,1,1) - rgb) # move each r,g,b towards 1 else # darken rgb - lighten.amount2 * rgb # move each r,g,b towards 0 rgb[rgb < 0] <- 0 # clamp rgb[rgb > 1] <- 1 if(alpha == 1) rgb(rgb[1,], rgb[2,], rgb[3,]) else rgb(rgb[1,], rgb[2,], rgb[3,], alpha) } # returns the expanded arg (error msg if arg is not an allowed choice in calling func) match.arg1 <- function(arg, argname=deparse(substitute(arg))) { formal.args <- formals(sys.function(sys.parent())) formal.argnames <- eval(formal.args[[argname]]) formal.argnames[imatch.choices(arg[1], formal.argnames, argname)] } # returns a string, choices is a vector of strings # error msg if arg is not an allowed choice match.choices <- function(arg, choices, argname=deparse(substitute(arg)), errmsg="", # error message ("" for automatic) errmsg.ext="") # extension to error message { choices[imatch.choices(arg, choices, argname, errmsg=errmsg, errmsg.ext=errmsg.ext)] } # This uses the object's .Environment attribute, which was # pre-assigned to the object via get.model.env # If this gives an error saying that class(model.env) is "NULL" # then that pre-assignment wasn't done. model.env <- function(object) { model.env <- attr(object, ".Environment") if(!is.environment(model.env)) stopf("class(model.env) is \"%s\"", class(model.env)[1]) model.env } # Like as.data.frame() but retains the original colnames, if any, and can # handle matrices from the Matrix etc. packages, if as.matrix() works for # them. Also it has a stringsAsFactors argument which works even if x is # already a data.frame. my.data.frame <- function(x, trace, stringsAsFactors=TRUE) { if(is.data.frame(x)) { if(stringsAsFactors) { # Convert any character columns to factors. Note as.data.frame # won't do this for us when x is already a data.frame. # We don't have a levels argument to pass to factor() # but I believe that this will not be a problem in the # context in which we use my.data.frame (plotmo_x). for(i in seq_len(length(x))) if(is.character(x[[i]])) x[[i]] <- factor(x[[i]]) } return(x) } df <- try(as.data.frame(x, stringsAsFactors=stringsAsFactors), silent=TRUE) if(is.try.err(df)) { # come here for sparse matrices from the Matrix package df <- try(as.matrix(x)) if(is.try.err(df)) stopf("Cannot convert %s object to a data.frame or matrix", quotify(class(x)[1])) df <- as.data.frame(df, stringsAsFactors=stringsAsFactors) trace2(trace, "converted %s object to data.frame\n", class(x)[1]) } colnames(df) <- safe.colnames(x) # restore original column names df } # default min.nrow=3 to use fixed point only if more than intercept and one other term my.fixed.point <- function(x, digits, min.nrow=3) { if(is.null(dim(x))) x <- as.matrix(x) if(NROW(x) >= min.nrow) x <- apply(x, 2, zapsmall, digits+1) x } # If s is a string vector s, return the number of lines in # the element that has the most lines # Examples: nlines(c(" ", " \n ") is 2 # nlines(c(" ", " \n") is 2 # nlines(" ") is 1 # nlines("") is 0 (special case) nlines <- function(s) { if(!nzchar(s[1])) # special case, caption="" is not printed 0 else if(anyNA(s)) 0 else length(strsplit(s, "\n")[[1]]) } paste.c <- function(object, maxlen=16) # return 'x1' or 'c(x1, x2)' { if(length(object) == 1) paste.trunc(object) else paste0("c(", paste.trunc(object, collapse=",", maxlen=maxlen), ")") } paste.with.quotes <- function(object, maxlen=16) # return '"x1"' or '"x1", "x2"' { if(is.null(object[1])) "NULL" else if(length(object) == 0) "EMPTY" else paste0(paste.trunc("\"", object, "\"", collapse=", ", sep="", maxlen=maxlen)) } paste.collapse <- function(...) { paste(..., collapse=" ") } # collapse, and truncate if strings in ... are too long paste.trunc <- function(..., sep=" ", collapse=" ", maxlen=60) { s <- paste(..., sep=sep, collapse=collapse) if(nchar(s) > maxlen) { stopifnot(maxlen > 3) s <- paste0(substr(s, 1, maxlen-3), if(substr(s, maxlen-3, maxlen-3) == ".") ".." # avoid 4 dots else "...") } s } pastef <- function(s, fmt, ...) # paste the printf style args to s { paste0(s, sprint(fmt, ...)) } print_first_few_elements_of_vector <- function(x, trace, name=NULL) { try(cat(" min", min(x), "max", max(x)), silent=TRUE) spaces <- " " if(!is.null(name)) spaces <- sprint("%*s", nchar(name), " ") # nchar spaces cat0("\n", spaces, " value") len <- if(trace >= 4) length(x) else min(if(is.logical(x)) 20 else 10, length(x)) if(is.logical(x)) for(i in 1:len) cat0(if(x[i]) " T" else " F") else for(i in 1:len) cat0(" ", x[i]) if(length(x) > len) cat(" ...") cat("\n") if(trace >= 4) { cat("\n") print(summary(x)) } } # A safe version of sprintf. # Like sprintf except that %s on NULL prints "NULL" rather than # preventing the entire string from being printed # # e.g. sprintf("abc %s def", NULL) returns an empty string -- a silent failure! # but sprint("abc %s def", NULL) returns "abc NULL def" # # e.g. sprintf("abc %d def", NULL) returns an empty string! # but sprint("abc %d def", NULL) causes an error msg (not a silent failure) sprint <- function(fmt, ...) { dots <- list(...) dots <- lapply(dots, function(e) if(is.null(e)) "NULL" else e) do.call(sprintf, c(fmt, dots)) } printf <- function(fmt, ...) # like c printf { cat(sprint(fmt, ...), sep="") } # like printf but wrap at terminal width # exdent=NULL for automatic determination of xdent (line up to func opening paren) # TODO maxlen seems to be ignored, strwrap truncates before that? printf.wrap <- function(fmt, ..., exdent=NULL, maxlen=2000) { s <- paste.trunc(paste.collapse(sprint(fmt, ...)), maxlen=maxlen) if(is.null(exdent)) { # align to opening paren of func call e.g. "graphics::par(xxx)" or "foo$method(" # TODO this doesn't account for leading newlines if any exdent <- 4 igrep <- gregexpr("[ ._$:[:alnum:]]+\\(", s)[[1]] if(igrep[1] == 1) { len <- attr(igrep, "match.length")[1] exdent <- min(25, len) } } # strwrap doesn't preserve newlines in the input string, so do it manually :( for(i in seq_len(nchar(s))) # print leading newlines if(substr(s, i, i) == "\n") cat0("\n") else break cat(paste0(strwrap(s, width=getOption("width"), exdent=exdent), collapse="\n")) if(nchar(s) > i) for(j in nchar(s):i) # print trailing newlines if(substr(s, j, j) == "\n") cat0("\n") else break } pt.cex <- function(ncases, npoints=ncases) { n <- if(npoints > 0) min(npoints, ncases) else ncases if (n >= 20000) .2 else if(n >= 5000) .3 else if(n >= 3000) .4 else if(n >= 1000) .6 else if(n >= 300) .8 else if(n >= 30) 1 else 1.2 } # like short.deparse but quotify the deparsed obj (unless the alternative is used) quote.deparse <- function(object, alternative="object") { s <- strip.deparse(object) if(nchar(s) > 60) alternative else quotify(s, quote="'") } quote.with.c <- function(names) # return "x" or c("x1", "x2") { if(length(names) == 1) sprint("\"%s\"", names) else sprint("c(%s)", paste0("\"", paste(names, collapse="\", \""), "\"")) } quotify <- function(s, quote="\"") # add quotes and collapse to a single string { # called quotify because quote is taken if(is.null(s)) "NULL" else if(length(s) == 0) paste0(quote, quote) else if(substr(s[1], 1, 1) == "'" || substr(s[1], 1, 1) == "\"") paste.collapse(s) # already has quotes else paste0(quote, paste(s, collapse=paste0(quote, " ", quote)), quote) } # like quotify, but use the alternative name if s is too long quotify.short <- function(s, alternative="object", quote="\"") { stopifnot(is.character(s)) s <- paste0(s, collapse="") if(nchar(s) > 60) # 60 is arb but seems ok for plot titles etc alternative else quotify(s, quote) } quotify.trunc <- function(s, quote="\"", maxlen=60) { stopifnot(is.character(s)) s <- quotify(s, quote) if(nchar(s) > maxlen) { stopifnot(maxlen > 3) paste0(substr(s, 1, maxlen-3), "...") } else s } range1 <- function(object, ...) { stopifnot(length(dim(object)) <= 2) if(!is.null(dim(object))) object <- object[,1] if(is.factor(object)) c(1, nlevels(object)) else if(inherits(object, "Date")) # Sep 2020, R 4.0.2: range no longer works with Date objects c(min(object), max(object)) else range(object, finite=TRUE, ...) } recycle <- function(object, ref.object) { repl(object, length.out=length(ref.object)) } repl <- function(object, length.out) { # following "if" added for R-2.15.3 otherwise # get warning: 'x' is NULL so the result will be NULL if(is.null(object)) return(NULL) check.numeric.scalar(length.out) stopifnot(floor(length.out) == length.out) stopifnot(length.out > 0) rep(object, length.out=length.out) } # the standard colnames() can crash for certain objects # TODO figure out when and why safe.colnames <- function(object) { colnames <- try(colnames(object), silent=TRUE) if(is.try.err(colnames)) NULL else colnames } # if deparse(object) is too long, return the alternative short.deparse <- function(object, alternative="object") { s <- strip.deparse(object) if(nchar(s) > 60) alternative else s } # Remove duplicates in x, then sort (smallest first). # Also works for Dates. sort_unique <- function(x) { sort(unique(x), na.last=NA) # na.last=NA drops NAs } sos <- function(x, weights=NULL) # sum of squares { if(is.null(weights)) sum(as.vector(x^2)) else { stopifnot(length(weights) == length(x)) sum(weights * as.vector(x^2)) } } stop0 <- function(...) { stop(..., call.=FALSE) } stopf <- function(fmt, ...) # args like printf { stop(sprint(fmt, ...), call.=FALSE) } # stop if s is not a one element character vector stopifnot.string <- function(s, name=short.deparse(substitute(s)), null.ok=FALSE, allow.empty=FALSE) { if(name %in% c("NULL", "NA")) name <- "argument" if(is.null(s)) { if(null.ok) return() else stop0(quotify(name, "'"), " is NULL (it should be a string)") } if(!is.character(s)) stop0(quotify(name, "'"), " is not a character variable (class(", name, ") is \"", class(s), "\")") if(length(s) == 0) stop0(quotify(name, "'"), " is empty (it has no elements)") if(length(s) != 1) stop0(quotify(name, "'"), " has more than one element\n ", name, " = c(", paste.trunc("\"", s, "\"", sep=""), ")") if(!allow.empty && !nzchar(s)) stop0(quotify(name, "'"), " is an empty string") } strip.deparse <- function(object) # deparse, collapse, remove most white space { s <- strip.space.collapse(deparse(object)) gsub(",", ", ", s) # put back space after commas } strip.space <- function(s) { gsub("[ \t\n]", "", s) } strip.space.collapse <- function(s) # returns a single string { gsub("[ \t\n]", "", paste(s, collapse="")) # paste converts vec to single } # like text, but with a white background # TODO sign of adj is backwards? text.on.white <- function(x, y, label, cex=1, adj=.5, font=1, xmar=.3, srt=0, white="white", ...) { stopifnot(length(label) == 1) if(length(adj) == 1) adj <- c(adj, .5) width <- strwidth(label, cex=cex, font=font) char.width <- strwidth("X", cex=cex, font=font) height <- strheight(label, cex=cex, font=font) char.height <- strheight("X", cex=cex, font=font) if(srt == 0) { if(is.specified(label)) rect(x - adj[1] * width - xmar * char.width, y - adj[2] * height - .3 * char.height, # .3 for extra space at bottom x + (1-adj[1]) * width + xmar * char.width, y + (1-adj[2]) * height + .1 * char.height, col=white, border=NA) text(x=x, y=y, labels=label, cex=cex, adj=adj, font=font, ...) } else if(srt == 90 || srt == -90) { # width and height are in usr coords, adjust these for flip of coords usr <- par("usr") # xmin, xmax, ymin, ymax xrange <- abs(usr[2] - usr[1]) yrange <- abs(usr[4] - usr[3]) height <- xrange / yrange * height width <- yrange / xrange * width char.height <- xrange / yrange * char.height char.width <- yrange / xrange * char.width if(is.specified(label)) rect(x + (1-adj[1]) * height, # left y + (1-adj[2]) * width + xmar * char.width, # bottom x - adj[1] * height, # right y - adj[2] * width - xmar * char.width, # top col=white, border=NA) text(x=x, y=y, labels=label, cex=cex, adj=adj, font=font, srt=srt, ...) } else stop0("srt=", srt, " is not allowed (only 0, 90, and -90 are supported)") } to.logical <- function(object, len) # object can be a boolean or numeric vector { xlogical <- repl(FALSE, len) xlogical[object] <- TRUE xlogical } trace0 <- function(trace, fmt, ...) { stopifnot(!(is.numeric(trace) && is.logical(trace))) if(trace >= 0) cat(sprint(fmt, ...), sep="") } trace1 <- function(trace, fmt, ...) { stopifnot(!(is.numeric(trace) && is.logical(trace))) if(trace >= 1) cat(sprint(fmt, ...), sep="") } trace2 <- function(trace, fmt, ...) { stopifnot(is.numeric(trace)) if(trace >= 2) cat(sprint(fmt, ...), sep="") } # Truncate deparse(object) if it is too long. # Necessary because deparse(substitute(x)) might return something very # long, like c(1000, 1001, 1002, 1003, 1004, 1005, 1006, 1008, 1009, etc.) # Return a one element character vector. trunc.deparse <- function(object, maxlen=60) { s <- strip.deparse(object) if(nchar(s) > maxlen) { stopifnot(maxlen > 3) paste0(substr(s, 1, maxlen-3), "...") } else s } # Return the number of lines in s (where lines are separated by \n). try.eval <- function( expr, envir = parent.frame(), trace = 0, expr.name = NULL, silent = trace < 2) { if(trace && is.null(expr.name)) expr.name <- trunc.deparse(substitute(expr)) try(eval.trace(expr, envir, trace=trace, expr.name=expr.name), silent=silent) } unquote <- function(s) # remove leading and trailing quotes, if any { if(is.character(s)) { s <- gsub("^\"|^'", "", s) # leading quotes s <- gsub("\"$|'$", "", s) # trailing quotes } s } # warn.if.not.all.finite helps preempt confusing message from code later. # Return TRUE if warning issued. warn.if.not.all.finite <- function(object, text="unknown") { is.factors <- sapply(object, is.factor) if(any(is.factors)) { if(NCOL(object) == 1 || all(is.factors)) # TODO suspect return(FALSE) object <- object[, !is.factors] # remove factor columns before is.finite check } if(any(sapply(object, is.na))) { warning0("NA in ", text) return(TRUE) } if(!all(sapply(object, is.finite))) { warning0("non finite value in ", text) return(TRUE) } FALSE } warnf <- function(fmt, ...) # args like printf { warning(sprint(fmt, ...), call.=FALSE) } warning0 <- function(...) { warning(..., call.=FALSE) } # Binomial pairs response: fraction true for each row. # # This function is used by both earth and plotmo. # If you change it here, change it there too. # # The first column of y is considered to be "true", the second "false". # # Example y: # survived died # 1 1 # 0 0 # both values zero # 3 4 # # becomes: # survived # .5 # 1 / (1 + 1) # 0 # special case (both survived and died equal to 0) # .43 # 3 / (3 + 4) bpairs.yfrac <- function(y, trace) { stopifnot(NCOL(y) == 2) both.zero <- (y[,1] == 0) & (y[,2] == 0) y[both.zero, 2] <- 1 # so zero rows will be translated to 0 in next line yfrac <- y[, 1, drop=FALSE] / (y[,1] + y[,2]) # fraction true trace.bpairs.yfrac(yfrac, trace) yfrac } trace.bpairs.yfrac <- function(yfrac, trace) { # based on code in print.earth.fit.args if(trace >= 4) cat("\n") if(trace >= 1 && trace < 7) { # don't print matrices when doing very detailed earth.c tracing tracex <- if(trace >= 5) 4 else 2 # adjust trace for print_summary details <- if(trace >= 4) 2 else if(trace >= 1) -1 else 0 print_summary(yfrac, "yfrac", tracex, details=details) if(details > 1) printf("\n") } } plotmo/R/xgboost.R0000644000176200001440000000037213710442111013571 0ustar liggesusers# xgboost.R: plotmo.prolog.xgb.Booster <- function(object, object.name, trace, ...) # xgboost model { stop0("xgboost models do not conform to standard S3 model guidelines ", "and are thus not supported by plotmo and plotres") } plotmo/R/plotcum.R0000644000176200001440000001153214563612461013605 0ustar liggesusers# plotcum.R plotmo_cum <- function(rinfo, info, nfigs=1, add=FALSE, cum.col1, grid.col, jitter=0, cum.grid="percentages", ...) { trans.resids <- abs(rinfo$scale * rinfo$resids) # TODO what happens here if NA in trans.resids (leverage==1) ecdf <- ecdf(trans.resids[,1]) xlab <- rinfo$name xlab <- sprint("abs(%ss)", xlab) cum.grid <- match.choices(cum.grid, c("none", "grid", "percentages")) annotation.cex <- .7 * dota("cum.cex", DEF=1, ...) if(!add && info && cum.grid == "percentages") { # ensure right margin big enough for right hand labels old.mar <- par("mar") if(old.mar[4] < 3.5) { on.exit(par(mar=old.mar)) par(mar=c(old.mar[1:3], annotation.cex * 5)) } } if(is.na(cum.col1)) cum.col1 <- dota("cum.col", DEF=1, ...) cum.col1 <- cum.col1[1] # no recycling # user can set xlim and ylim if this is the only figure xlim <- dota("xlim", DEF=NULL, ...) if(nfigs > 1 || !is.specified(xlim)) xlim <- range(abs(rinfo$scale * rinfo$resids), na.rm=TRUE) xlim <- fix.lim(xlim) ylim <- dota("ylim", DEF=NULL, ...) if(nfigs > 1 || !is.specified(ylim)) ylim <- c(ylim=if(info) -.1 else 0, ymax=if(cum.grid == "percentages") 1 + annotation.cex * .06 else 1) ylim <- fix.lim(ylim) call.plot(stats::plot.stepfun, PREFIX="cum.", drop.cum.grid=1, force.x = ecdf, force.add = add, force.main = dota("main", DEF="Cumulative Distribution", ...), force.xlim = xlim, force.ylim = ylim, force.xlab = xlab, force.ylab = "Proportion", force.col.points = NA, # finer resol graph (points are big regardless of pch) force.col = cum.col1, force.col.hor = cum.col1, force.col.vert = cum.col1, ...) if(!add) { if(info) draw.density.along.the.bottom(abs(trans.resids), ...) if(cum.grid %in% c("grid", "percentages")) { linecol <- if(is.specified(grid.col)) grid.col else "lightgray" # add annotated grid lines, unattractive but useful for(h in c(0,.25,.5,.75,.90,.95,1)) # horizontal lines abline(h=h, lty=1, col=linecol) probs <- c(0, .25, .50, .75, .9, .95, 1) q <- quantile(trans.resids, probs=probs, names=FALSE) for(v in q) # vertical lines at 0,25,50,75,90,95,100% quantiles abline(v=v, lty=1, col=linecol) box() # abline overwrite the box, so restore it if(cum.grid == "percentages") { draw.percents.on.top(probs, q, annotation.cex) if(info) draw.quantiles.on.right.side(probs, q, annotation.cex) } # replot data over grid call.plot(stats::plot.stepfun, PREFIX="cum.", drop.cum.grid=1, force.x = ecdf, force.add = TRUE, force.xlim = xlim, force.col.points = NA, force.col = cum.col1, force.col.hor = cum.col1, force.col.vert = cum.col1, ...) } } } # Adding percents and quantiles on the wrong axes is considered a no no, # but here we are more-or-less forced into it because the percentile text # can be too long to display on the "correct" axis. draw.percents.on.top <- function(probs, q, annotation.cex) { is.space.available <- function(i) # is horizontal space available { q[i] - q[i-1] > 1.2 * strwidth && q[i+1] - q[i] > 1.2 * strwidth } draw.percent <- function(i, label) { # xpd=NA to allow text out of plot region (usually not needed) x <- q[i] if(i == 1) x <- x + .05 * strwidth # so 0% doesn't overwrite box else if(i == 7) x <- x - .3 * strwidth # so 100% doesn't overwrite box text.on.white(x=x, y=1.05, label, annotation.cex, xmar=0, xpd=NA) } #--- draw.percents starts here --- strwidth <- strwidth("25%", cex=annotation.cex) draw.percent(1, "0%") if(is.space.available(2)) draw.percent(2, "25%") draw.percent(3, "50%") if(is.space.available(4)) draw.percent(4, "75%") draw.percent(5, "90%") if(is.space.available(6)) draw.percent(6, "95%") draw.percent(7, "100%") } draw.quantiles.on.right.side <- function(probs, q, annotation.cex) { y <- spread.labs(x=probs, mindiff=1.2 * annotation.cex * strheight("A"), min=-.1) q[q < max(q) / 1e4] <- 0 # prevent labels like 2.22e-16 text(1.01 * par("usr")[2], y, sprint("%.3g", q), xpd=TRUE, cex=annotation.cex, adj=0) } plotmo/R/grid.func.R0000644000176200001440000002070414241606077014001 0ustar liggesusers# grid.func: apply grid.levels or grid.func to x (a column from the input x mat) # to get a scalar value for the given background variable get.fixed.gridval <- function(x, pred.name, grid.func, grid.levels) { gridval.method <- "grid.levels" # used only in warning messages gridval <- get.fixed.gridval.from.grid.levels.arg(x, pred.name, grid.levels) if(is.na(gridval)) { # pred.name is not in grid.levels? gridval.method <- "grid.func" if(is.null(grid.func)) { grid.func <- default.grid.func gridval.method <- "default.grid.func" } check.grid.func(grid.func) if(length(x) == 0) # paranoia stop0("length(", pred.name, ") is zero") x <- x[!is.na(x)] if(length(x) == 0) # paranoia stop0("all values of ", pred.name, " are NA") gridval <- try(grid.func(x, na.rm=TRUE), silent=TRUE) } check.fixed.gridval(gridval, gridval.method, x, pred.name) # returns gridval } default.grid.func <- function(x, ...) { if(inherits(x, "integer")) # return median rounded to integer return(as.integer(round(median(x)))) if(inherits(x, "logical")) # return most common value return(median(x) > .5) if(inherits(x, "factor")) { # return most common value lev.names <- levels(x) ilev <- which.max(table(x)) if(is.ordered(x)) return(ordered(lev.names, levels=lev.names)[ilev]) return(factor(lev.names, levels=lev.names)[ilev]) } median(x) # default to median } # Check grid.levels arg passed in by the user. This checks that the names # of the list elements are indeed predictor names. The actual levels will # be checked later in get.fixed.gridval.from.grid.levels.arg. check.grid.levels.arg <- function(x, grid.levels, pred.names) { if(!is.null(grid.levels)) { # null is the default value if(!is.list(grid.levels)) stop0("grid.levels must be a list. ", "Example: grid.levels=list(sex=\"male\")") for(name in names(grid.levels)) { if(nchar(name) == 0) stop0( "All elements of grid.levels must be named\n You have grid.levels=", as.char(grid.levels)) if(!pmatch(name, pred.names, 0)) stop0("illegal variable name '", name, "' in grid.levels") } } } # this returns NA if pred.name is not in grid.levels get.fixed.gridval.from.grid.levels.arg <-function(x, pred.name, grid.levels) { if(is.null(grid.levels)) return(NA) gridval <- NA names.grid.levels <- names(grid.levels) # look for pred.name in the grid.levels list, if found use its value iname <- which(pmatch(names.grid.levels, pred.name, duplicates.ok=TRUE) == 1) if(length(iname) == 0) # no match? return(NA) if(length(iname) > 1) # more than one match? stop0("illegal grid.levels argument (\"", names.grid.levels[iname[1]], "\" and \"", names.grid.levels[iname[2]], "\" both match \"", pred.name, "\")") # a name in grid.levels matches pred.name stopifnot(length(iname) == 1) gridval <- grid.levels[[iname]] if(length(gridval) > 1) stop0("length(", pred.name, ") in grid.levels is not 1") if(is.na(gridval)) stop0(pred.name, " in grid.levels is NA") if(is.numeric(gridval) && !all(is.finite(gridval))) stop0(pred.name, " in grid.levels is infinite") if(is.factor(x)) { lev.name <- grid.levels[[iname]] if(!is.character(lev.name) || length(lev.name) != 1 || !nzchar(lev.name)) stop0("illegal level for \"", pred.name, "\" in grid.levels ", "(specify factor levels with a string)") lev.names <- levels(x) ilev <- pmatch(lev.name, lev.names, 0) if(ilev == 0) stop0("illegal level \"", lev.name, "\" for \"", pred.name, "\" in grid.levels (allowed levels are ", quotify(lev.names), ")") gridval <- if(is.ordered(x)) ordered(lev.names, levels=lev.names)[ilev] else factor(lev.names, levels=lev.names)[ilev] } # do type conversions for some common types # (e.g. allow 3 instead of 3L for integer variables) class.gridval <- class(gridval)[1] class.x <- class(x)[1] if(class.gridval != class.x) { if(class.gridval == "numeric" && class.x == "integer") gridval <- as.integer(round(gridval)) else if(class.gridval == "integer" && class.x == "numeric") gridval <- as.numeric(gridval) else if(class.x == "logical") { if(!is.logical(gridval) && !is.numeric(gridval)) stop0("expected a logical value in grid.levels for ", pred.name) gridval <- gridval > .5 } } return(gridval) } check.grid.func <- function(grid.func) { if(!is.function(grid.func)) stop0("'grid.func' is not a function"); formals <- names(formals(grid.func)) # check grid.func signature, we allow argname "na.rm" for mean and median if(length(formals) < 2 || formals[1] != "x" || (!any(formals == "na.rm") && formals[2] != "...")) stop0("The formal arguments of 'grid.func' should be 'x' and '...'\n", " Your 'grid.func' has ", if(length(formals) == 0) "no formal arguments" else if(length(formals) == 1) "a single formal argument " else "formal arguments ", if(length(formals) > 0) paste0("'", formals, "'", collapse=" ") else "") } check.fixed.gridval <- function(gridval, gridval.method, x, pred.name) { if(is.try.err(gridval)) { if(inherits(x, "logical") || inherits(x, "factor")) warning0(gridval.method, " failed for ", pred.name, ", so will use the most common value of ", pred.name) else warning0(gridval.method, " failed for ", pred.name, ", so will use the default grid.func for ", pred.name) gridval <- default.grid.func(x) } if(length(gridval) != 1) { warning0(gridval.method, " returned multiple values for ", pred.name, ", so will use the default grid.func for ", pred.name) gridval <- default.grid.func(x) # revert to default.grid.func } if(is.na(gridval)) { warning0(gridval.method, " returned NA for ", pred.name, ", so will use the default grid.func for ", pred.name) gridval <- default.grid.func(x) # revert to default.grid.func } # possibly type convert gridval class.gridval <- class(gridval)[1] if(class.gridval != class(x)[1]) { if(inherits(x, "integer")) # silently fix so e.g. grid.func=mean works gridval <- as.integer(round(median(gridval))) else if(inherits(x, "logical")) { # silently fix if possible if(!is.logical(gridval) && !is.numeric(gridval)) stop0("expected a logical value in grid.levels for ", pred.name) gridval <- gridval > .5 } else if(inherits(x, "factor")) { warning0(gridval.method, " returned class \"", class.gridval, "\" for ", pred.name, ", so will use the most common value of ", pred.name) gridval <- default.grid.func(x) } else { warning0(gridval.method, " returned class \"", class.gridval, "\" for ", pred.name, ", so will use the default grid.func for ", pred.name) gridval <- default.grid.func(x) } } gridval } # this retunrs NA if pred.name is not in grid.levels get.fixed.gridval.for.partdep <- function(x, ipred, pred.name, grid.levels) { gridval <- get.fixed.gridval.from.grid.levels.arg(x, pred.name, grid.levels) # common type conversions were already done in get.fixed.gridval.from.grid.levels.arg # check here if that wasn't possible if(!is.na(gridval)[1] && class(gridval)[1] != class(x)[1]) stop0("the class \"", class(gridval)[1], "\" of \"", pred.name, "\" in grid.levels does not match its class \"", class(x)[1], "\" in the input data") gridval } plotmo/R/plotresids.R0000644000176200001440000010713014566065135014315 0ustar liggesusers# plotresids.R plotresids <- function( object, which, info, standardize, level, versus1, id.n, smooth.col, grid.col, jitter, npoints, center, type, fitted, rinfo, rsq, iresids, nversus, colname.versus1, force.auto.resids.xlim, force.auto.resids.ylim, SHOWCALL=NA, # this is here to absorb SHOWCALL from dots ...) { stopifnot(length(which) == 1) info <- check.boolean(info) ok <- which %in% c(W3RESID,W5ABS:W9LOGLOG) if(!all(ok)) stop0("which=", which[!ok][1], " is not allowed") # id.n has already been checked in plotres.data id.indices.specified <- FALSE if(which %in% c(W3RESID, W4QQ:W8CUBE) && id.n != 0) id.indices.specified <- TRUE level <- check.level.arg(level, zero.ok=TRUE) if(which %in% (W5ABS:W9LOGLOG)) level <- 0 # no pints pints <- NULL cints <- NULL level.shade <- dota("level.shade shade.pints", DEF="mistyrose2", ...) level.shade2 <- dota("level.shade2 shade.cints", DEF="mistyrose4", ...) if(which == W3RESID && is.specified(level)) { p <- plotmo.pint(object, newdata=NULL, type, level, trace=0) if(!is.null(p$fit) && max(abs(p$fit - fitted)) != 0) { # TODO $$ happens with test.unusual.vars.R:earth.glm.spaced.bx warning0("Internal inconsistency: p$fit != fitted", if(inherits(object, "earth")) "\n Workaround: no 'glm' arg in call to earth, or no 'level' arg n call to plotres" else "") fitted <- p$fit # hack } if(is.specified(level.shade) && !is.null(p$upr)) { pints <- data.frame(upr=rinfo$scale * (p$upr - fitted), lwr=rinfo$scale * (p$lwr - fitted)) colnames(pints) <- c("upr", "lwr") } if(is.specified(level.shade2) && !is.null(p$cint.upr)) { cints <- data.frame(upr=rinfo$scale * (p$cint.upr - fitted), lwr=rinfo$scale * (p$cint.lwr - fitted)) colnames(cints) <- c("upr", "lwr") } } if(is.null(pints) && is.null(cints)) level <- 0 resids <- rinfo$scale * rinfo$resids if((which %in% W7VLOG:W9LOGLOG)) check.that.most.are.positive( versus1, "fitted", sprint("which=%d", which), "nonpositive") # TODO following is redundant after above check? # abs(resids) must be nonnegative to take their log if(which %in% W7VLOG:W9LOGLOG) check.that.most.are.positive( abs(resids), "abs(residuals)", sprint("which=%d", which), "zero") trans.versus <- trans.versus(versus1[iresids], which) trans.resids <- trans.resids(resids[iresids], which) x <- if(nversus == V2INDEX) 1:length(trans.versus) else trans.versus jitter <- as.numeric(check.numeric.scalar(jitter, logical.ok=TRUE)) stopifnot(jitter >= 0, jitter <= 10) # 10 is arbitrary jittered.x <- x jittered.trans.resids <- trans.resids if(jitter > 0) { # we use amount=0 (same as S) which seems to work better in this context jittered.x <- jitter(x, factor=jitter, amount=0) jittered.trans.resids <- jitter(trans.resids, factor=jitter, amount=0) } derived.xlab <- derive.xlab(dota("xlab", DEF=NULL, ...), which, colname.versus1, nversus) derived.ylab <- derive.ylab(dota("ylab", DEF=NULL, ...), which, rinfo$name) main <- derive.main(main=dota("main", DEF=NULL, ...), derived.xlab, derived.ylab, level, attr(object, "plotmo.s")) # allow col.response as an argname for compat with old plotmo pt.col <- dota("col.response col.resp", DEF=1, ...) pt.col <- dota("pt.col col.points col.point col.residuals col.resid col", EX=c(0,1,1,1,1,1), DEF=pt.col, NEW=1, ...) # recycle pt.col <- repl(pt.col, length(resids)) pt.cex <- dota("response.cex cex.response", DEF=1, ...) pt.cex <- dota("pt.cex cex.points cex.point cex.residuals cex", EX=c(0,1,1,1,1), DEF=pt.cex, NEW=1, ...) pt.cex <- pt.cex * pt.cex(length(x), npoints) pt.cex <- repl(pt.cex, length(resids)) pt.pch <- dota("response.pch pch.response", DEF=20, ...) pt.pch <- dota("pt.pch pch.points pch.point pch.residuals pch", EX=c(0,1,1,1,1), DEF=pt.pch, NEW=1, ...) pt.pch <- repl(pt.pch, length(resids)) ylim <- get.resids.ylim(ylim=dota("ylim", ...), force.auto.resids.ylim, object, fitted, trans.resids, which, info, standardize, id.indices.specified, center, pints, cints, rinfo$scale, nversus) xlim <- get.resids.xlim(xlim=dota("xlim", ...), force.auto.resids.xlim, which, x, trans.versus, ylim, nversus, id.indices.specified) id.indices <- NULL if(id.indices.specified) id.indices <- get.id.indices(rinfo$scale * rinfo$resids, id.n, if(nversus == V4LEVER) hatvalues1(object, sprint("versus=%g", V4LEVER)) else NULL) call.plot(graphics::plot.default, PREFIX="pt.", force.x = x, force.y = jittered.trans.resids, force.main = main, force.xlab = derived.xlab, force.ylab = derived.ylab, force.xlim = xlim, force.ylim = ylim, force.col = NA, # no points will actually be plotted at this stage ...) if(is.specified(grid.col)) grid(col=grid.col, lty=1) else if(which != W9LOGLOG) abline(h=0, lty=1, col="lightgray") # axis if(level && nversus != V4LEVER) { if(is.specified(level.shade)) draw.pint.resids(pints=pints, x=versus1, shade=level.shade, nversus=nversus, ...) if(is.specified(level.shade2)) draw.pint.resids(pints=cints, x=versus1, shade=level.shade2, nversus=nversus, ...) } if(nversus == V4LEVER) { # vertical line at mean leverage mean <- mean(x, na.rm=TRUE) abline(v=mean, col="gray") # add label "mean" if(which == W3RESID) { # not for others otherwise put text over the points usr <- par("usr") # xmin, xmax, ymin, ymax text(mean, if(info) usr[3] + .1 * (usr[4] - usr[3]) # beyond density plot else usr[3] + .02 * (usr[4] - usr[3]), "mean", adj=c(0, -.2), cex=.8, srt=90) } if(standardize && inherits(object, "lm")) draw.cook.levels(object, ...) } call.plot(graphics::points, PREFIX="pt.", force.x = jittered.x, force.y = jittered.trans.resids, force.col = pt.col[iresids], force.cex = pt.cex[iresids], force.pch = pt.pch[iresids], ...) box() # plot points with unity leverage as stars draw.bad.leverage.as.star(jittered.x, rinfo, iresids, pt.cex, smooth.col) coef.rlm <- NULL if(info && nversus != V4LEVER && (which == W5ABS || which == W9LOGLOG)) coef.rlm <- draw.rlm.line(which, versus1, resids, nversus, ...) if(which != W9LOGLOG) draw.smooth(x, trans.resids, rinfo$scale[iresids], smooth.col, ...) col.cv <- dota("col.cv", ...) oof.meanfit.was.plotted <- FALSE if(level && !is.null(object$cv.oof.fit.tab) && is.specified(col.cv)) { draw.oof.meanfit(object$cv.oof.fit.tab, fitted, versus1, rinfo, which, col.cv, nversus) oof.meanfit.was.plotted <- TRUE } # TODO implement id.indices for nversus=V2INDEX if(id.indices.specified && nversus != V2INDEX) { # TODO as.numeric is needed if versus1 is a factor # is.na test needed for which=7 (if some are negative?) x1 <- as.numeric(trans.versus(versus1, which)[id.indices]) if(!anyNA(x1)) plotrix::thigmophobe.labels(x=x1, # TODO labels should take into account jitter y=trans.resids(resids, which)[id.indices], labels=rinfo$labs[id.indices], offset=.33, xpd=NA, font=dota("label.font", DEF=1, ...)[1], cex=.8 * dota("label.cex", DEF=1, ...)[1], col=dota("label.col", DEF=if(is.specified(smooth.col)) smooth.col else 2, ...)[1]) } if(info) draw.resids.info(which, info, versus1, resids, nversus, rsq, coef.rlm, ...) else possible.plotres.legend(which=which, level=level, smooth.col=smooth.col, oof.meanfit.was.plotted=oof.meanfit.was.plotted, ...) list(x=x, y=trans.resids) # does not include jittering } get.plotres.data <- function(object, object.name, which, standardize, delever, level, versus, id.n, labels.id, trace, npoints, type, nresponse, ..., must.get.rsq) { # the dot argument FORCEPREDICT is to check compat with old plot.earth meta <- plotmo_meta(object, type, nresponse, trace, avoid.predict=!dota("FORCEPREDICT", DEF=FALSE, ...), ...) nresponse <- meta$nresponse # column index resp.name <- meta$resp.name # used only in automatic caption, may be NULL type <- meta$type # always a string (converted from NULL if necessary) residtype <- meta$residtype # ditto # we get rsq only if necessary, because error reporting if we can't get it # is weak (because of nested try blocks, here and in do.call.trace) rsq <- NA if(must.get.rsq) { rsq <- try(plotmo_rsq1(object=object, newdata=NULL, trace=if(trace == 1) -1 else trace, meta=meta, ...), silent=trace < 2) if(is.try.err(rsq)) { trace0(trace, "Cannot get training rsq (%s)\n", cleantry(rsq)) rsq <- NA } } # get the residuals and fitted info rinfo <- plotmo_rinfo(object=object, type=type, residtype=residtype, nresponse=nresponse, standardize=standardize, delever=delever, trace=trace, leverage.msg= if(any(which %in% c(W3RESID,W5ABS:W9LOGLOG))) "plotted as a star" else "ignored", expected.levs=meta$resp.levs, labels.id=labels.id, ...) fitted <- rinfo$fitted # n x 1 numeric matrix rinfo$fitted <- NA # prevent accidental use of rinfo$fitted later stopifnot(NCOL(fitted) == 1) stopifnot(length(dim(fitted)) == 2) colnames(fitted) <- "Fitted" # colname will be used in labels in plots # get the values we will plot against (by default the fitted values) vinfo <- get.versus.info(which, versus, object, fitted, nresponse, trace) stopifnot(nrow(fitted) == length(rinfo$resids)) ncases <- length(rinfo$resids) id.n <- get.id.n(id.n, ncases) # convert special values of id.n # convert special values of npoints check.integer.scalar(npoints, min=-1, null.ok=TRUE, logical.ok=TRUE) npoints.was.neg <- FALSE if(is.null(npoints)) npoints <- 0 else if(is.logical(npoints)) npoints <- if(npoints) ncases else 0 else if(npoints == -1) { npoints.was.neg <- TRUE npoints <- ncases } else if(npoints > ncases) npoints <- ncases # Use a maximum of NMAX residuals (unless npoints is bigger or negative). # Allows plotres to be fast even on models with millions of cases. NMAX <- 1e4 nmax <- max(NMAX, npoints) if(!npoints.was.neg && nrow(fitted) > nmax) { if(trace >= 1) printf("using %g of %g residuals%s\n", nmax, ncases, if(id.n > 0) ", forcing id.n=0 because of that (implementation restriction)" else "") # see comment in plotres for use of V4LEVER here isubset <- get.isubset(rinfo$resids, nmax, id.n, use.all=(vinfo$nversus == V4LEVER), rinfo$scale) fitted <- fitted [isubset, , drop=FALSE] rinfo$resids <- rinfo$resids[isubset, , drop=FALSE] rinfo$scale <- rinfo$scale [isubset] vinfo$versus.mat <- vinfo$versus.mat [isubset, , drop=FALSE] # Can no longer draw point labels because row numbers are different. # TODO Come up with a solution so it doesn't have to be that way. id.n <- 0 } list(nresponse = nresponse, # col index in the response (converted from NA if necessary) resp.name = resp.name, # used only in automatic caption, may be NULL type = type, # always a string (converted from NULL if necessary) rinfo = rinfo, # resids, scale, name, etc. vinfo = vinfo, # versus.mat, icolumns, nversus, etc. fitted = fitted, # n x 1 numeric matrix, colname is "Fitted" id.n = id.n, # forced to zero if row indexing changed npoints = npoints, # special values have been converted rsq = rsq) } get.id.n <- function(id.n, ncases) # convert special values of id.n { check.integer.scalar(id.n, null.ok=TRUE, logical.ok=TRUE) if(is.null(id.n)) id.n <- 0 else if(is.logical(id.n)) { id.n <- if(id.n) ncases else 0 } else if(id.n == -1) id.n <- ncases else if(abs(id.n) > ncases) id.n <- ncases id.n } get.versus.info <- function(which, versus, object, fitted, nresponse, trace=0) { versus.mat <- fitted icolumns <- 1 trim.which <- FALSE got.versus <- FALSE nversus <- versus if(is.numeric(versus)) { got.versus <- TRUE trim.which <- TRUE if(length(versus) != 1) stop0( "illegal 'versus' argument (length of 'versus' must be 1 when 'versus' is numeric)") if(floor(versus) != versus) versus.err() if(versus == V1FITTED) trim.which <- FALSE else if(versus == V2INDEX) NULL else if(versus == V3RESPONSE) { versus.mat <- plotmo_y(object, nresponse, trace, expected.len=NROW(fitted), object$levels)$y colnames(versus.mat) <- "Response" } else if(versus == V4LEVER) { # TODO handle constant leverages for factors in the same way as plot.lm versus.mat <- matrix(hatvalues1(object, sprint("versus=%g", V4LEVER)), ncol=1) colnames(versus.mat) <- "Leverage" } else versus.err() } else if(!is.character(versus)) versus.err() else if(length(versus) == 1 && nchar(versus) >= 2 && (substr(versus, 1, 2) == "b:" || substr(versus, 1, 2) == "B:")) { # use the basis matrix got.versus <- TRUE trim.which <- TRUE nversus <- 0 plotmo_bx <- plotmo_bx(object, trace, versus=substring(versus, 3)) # substring drops "bx:" versus.mat <- plotmo_bx$bx icolumns <- plotmo_bx$icolumns } if(!got.versus) { # user specified x variables trim.which <- TRUE prefix <- substr(versus, 1, 1) nversus <- 0 # following are needed if versus is a vector if(any(prefix == "*")) stop0("\"*\" is not allowed in this context in the 'versus' argument\n", " Your 'versus' argument is ", quote.with.c(versus)) versus.mat <- plotmo_x(object, trace) versus.mat <- as.matrix(versus.mat) colnames(versus.mat) <- gen.colnames(versus.mat, "x", "x", trace) icolumns <- check.index(versus, "versus", seq_len(NCOL(versus.mat)), colnames=colnames(versus.mat)) } if(trim.which) { # remove all entries from which except standard resid and abs resid plots org.which <- which which <- which[which %in% c(W3RESID,W5ABS)] if(length(which) == 0) warnf( "which=%s is now empty because plots were removed because versus=%s", paste.c(org.which, maxlen=50), paste.c(versus, maxlen=30)) } list(which = which, # which after possibly removing some plots versus.mat = versus.mat, # either fitted, response, x, or bx icolumns = icolumns, # desired column indices in versus.mat nversus = nversus) # versus as a number, 0 if versus is character } get.resids.xlim <- function(xlim, force.auto.resids.xlim, which, x, trans.versus, ylim, nversus, id.indices.specified) { if(force.auto.resids.xlim || !is.specified(xlim)) { # auto xlim? if(which == W9LOGLOG) { # don't show lower 5% of points quant <- quantile(trans.versus, probs=c(.05, 1), names=FALSE) min <- quant[1] max <- quant[2] # extra left margin so slope of linear fit not flattened if(min > .2 * ylim[1]) min <- .2 * ylim[1] xlim <- c(min, max) } else if(nversus == V4LEVER) # room for labels on high leverage points xlim <- c(0, 1.1 * max(x, na.rm=TRUE)) else xlim <- range1(x, na.rm=TRUE) range <- xlim[2] - xlim[1] if(id.indices.specified) # space for point labels xlim <- c(xlim[1] - .04 * range, xlim[2] + .04 * range) } stopifnot(is.numeric(xlim), length(xlim) == 2) fix.lim(xlim) } get.resids.ylim <- function(ylim, force.auto.resids.ylim, object, fitted, resids, which, info, standardize, id.indices.specified, center, pints, cints, scale, nversus) { if(force.auto.resids.ylim || !is.specified(ylim)) { # auto ylim? if(!is.null(pints)) { min <- min(resids, pints$lwr, na.rm=TRUE) max <- max(resids, pints$upr, na.rm=TRUE) } else if(!is.null(cints)) { min <- min(resids, cints$lwr, na.rm=TRUE) max <- max(resids, cints$upr, na.rm=TRUE) } else { min <- min(resids, na.rm=TRUE) max <- max(resids, na.rm=TRUE) } maxa <- mina <- 0 # adjustments to max and min if(which %in% (W5ABS:W8CUBE)) min <- 0 else if(which == W3RESID && center) { # want symmetric ylim so can more easily see asymmetry if(abs(min) > abs(max)) max <- -min else if(abs(max) > abs(min)) min <- -max } else if(which == W9LOGLOG) maxa <- .5 # more space on top, looks better range <- abs(max - min) if(id.indices.specified) { # space for point labels # TODO only do this if point labels are near the edges mina <- max(mina, .03 * range) maxa <- max(maxa, .03 * range) } if(nversus == V4LEVER && standardize && inherits(object, "lm")) { maxa <- max(maxa, maxa + .2 * range) # space for cook distance legend mina <- max(mina, mina + .1 * range) # space for "mean" label } if(info) { # space for extra text (on top) and density plot (in the bottom) maxa <- maxa + max * if(id.indices.specified) .2 else .1 mina <- mina + max * if(id.indices.specified) .2 else .1 } ylim <- c(min-mina, max+maxa) } fix.lim(ylim) } draw.pint.resids <- function(pints, x, shade, nversus, ...) { if(!is.null(pints)) { # abscissa must be ordered for polygon to work order <- order(x) x <- x[order] pints <- pints[order,] x <- if(nversus == V2INDEX) c(1:length(x), length(x):1) else trans.versus(c(x, rev(x)), 0) call.plot(graphics::polygon, PREFIX="level.", drop.shade=1, drop.shade2=1, force.x = x, force.y = trans.resids(c(pints$lwr, rev(pints$upr)), 0), force.col = shade, def.border = shade, def.lty = 0, ...) } } # this should be used only for models with homoscedastic errors draw.cook.levels <- function(object, ...) { cook.levels <- dota("cook.levels", DEF=c(0.5, 1.0), ...) stopifnot(is.numeric(cook.levels), all(cook.levels > 0)) col <- dota("cook.col", DEF="slategray4", ...) lty <- dota("cook.lty", DEF=1, ...) lwd <- dota("cook.lwd", DEF=1, ...) # based on code in stats::plot.lm.R leverage <- hatvalues1(object, "'standardize'") p <- length(coef(object)) leverage.range <- range(leverage, na.rm=TRUE) # though should never have NA x <- seq.int(0, 1, length.out=101) for(cook.level in cook.levels) { cl <- sqrt(cook.level * p *(1 - x) / x) lines(x, cl, col=col, lty=lty, lwd=lwd) lines(x, -cl, col=col, lty=lty, lwd=lwd) } # we don't use bottomleft like plot.lm because we may plot the density there usr <- par("usr") # xmin, xmax, ymin, ymax legend(usr[1]-.7 * strwidth("X"), # jam it into the corner usr[4]+.5 * strheight("X"), legend="Cook's distance", col=col, lty=lty, lwd=lwd, box.col="white", bg="white", x.intersp=.2, seg.len=1.5) xmax <- min(0.99, usr[2]) ymult <- sqrt(p * (1 - xmax) / xmax) axis(4, at=c(-sqrt(rev(cook.levels)) * ymult, sqrt(cook.levels)*ymult), labels=paste(c(rev(cook.levels), cook.levels)), mgp=c(.25,.15,0), las=2, tck=0, cex.axis=.7, col.axis=col, font=2) # makes the gray labels a bit more legible } # Plot points with unity leverage as stars. We plot them on # the axis, which is arguably incorrect but still useful. # TODO add a test for this to the test suite draw.bad.leverage.as.star <- function(x, rinfo, iresids, pt.cex, smooth.col) { which <- which(is.na(rinfo$scale[iresids])) if(length(which) > 0) { points(x[which], 0, col=1, cex=pt.cex[iresids], pch=8) # pch 8 is a star # add label if possible (not poss if not all points plotted, see npoints) if(length(iresids) == length(rinfo$scale)) { label <- which(is.na(rinfo$scale)) text.on.white(x=x[which], y=0, label=label, col=if(is.specified(smooth.col)) smooth.col else 2, cex=.8, adj=-.5, xpd=NA) } } } draw.smooth <- function(x, resids, scale, smooth.col, ...) { if(!is.specified(smooth.col)) return(NULL) # na.rm is needed if we take logs of nonpos, see check.that.most.are.positive. # That's why we calculate delta explicitly instead of using lowess default. delta <- .01 * diff(range1(x, na.rm=TRUE)) # Replace points with NA scale with 0 (else lowess stops at the NA). # Zero is appropriate because the points are 0 resids with leverage 1. resids[which(is.na(scale))] <- 0 # we use lowess rather than loess because loess tends to give warnings smooth.f <- dota("smooth.f loess.f", DEF=2/3, NEW=1, ...) smooth.iter <- dota("smooth.iter", DEF=3, ...) check.numeric.scalar(smooth.f) stopifnot(smooth.f > .01, smooth.f < 1) smooth <- lowess(x, resids, f=smooth.f, iter=smooth.iter, delta=delta) call.plot(graphics::lines.default, PREFIX="smooth.", drop.f=1, force.x = smooth$x, force.y = smooth$y, force.col = smooth.col, force.lwd = dota("smooth.lwd lwd.smooth lwd.loess", EX=c(0,1,1), DEF=1, NEW=1, ...), force.lty = dota("smooth.lty lty.smooth", EX=c(0,1), DEF=1, NEW=1, ...), ...) } derive.xlab <- function(xlab, which, colname.versus1, nversus) { if(is.specified(xlab)) { stopifnot.string(xlab, allow.empty=TRUE) if(!nzchar(xlab)) return("") } if(!is.specified(xlab)) xlab <- colname.versus1 stopifnot.string(xlab) if(which %in% (W7VLOG:W9LOGLOG)) xlab <- sprint("Log %s", xlab) if(nversus == V2INDEX) xlab <- sprint("%s index", xlab) xlab } derive.ylab <- function(ylab, which, rinfo.name) { if(is.specified(ylab)) { stopifnot.string(ylab, allow.empty=TRUE) if(!nzchar(ylab)) return("") } if(!is.specified(ylab)) ylab <- sprint("%ss", rinfo.name) if(which == W5ABS) ylab <- sprint("Abs %s", ylab) else if(which == W6SQRT) ylab <- sprint("Sqrt Abs %s", ylab) else if(which == W7VLOG) ylab <- sprint("Abs %s", ylab) else if(which == W8CUBE) ylab <- sprint("Cube Root Squared %s", ylab) else if(which == W9LOGLOG) ylab <- sprint("Log Abs %s", ylab) ylab } derive.main <- function(main, xlab, ylab, level, predict.s) # title of plot { # TODO should really use strwidth for newline calculation # The "Fitted" helps with limitations of the formula below newline <- xlab != "Fitted" && xlab != "Fitted index" && xlab != "Response" && nchar(ylab) + nchar(xlab) > 15 if(xlab == "Leverage" && ylab == "Residuals") # special case, mainly for which=1 with lm newline <- FALSE else if(grepl("Standardized", ylab[1]) || grepl("Delevered", ylab[1])) newline <- TRUE if(!is.specified(main)) { # generate a main only if user didn't specify main main <- sprint("%s vs%s%s", ylab, if(newline) "\n" else " ", xlab) if(!is.null(predict.s)) { # include the s argument that is used to make the model predictions if(is.character(predict.s)) # "lambda.1se" or "lambda.min" main <- sprint("%s (s=\"%s\")", main, predict.s) else if(is.numeric(predict.s)) { main <- sprint("%s (s=%s)", main, if(predict.s == 0) "0" else signif(predict.s,2)) } else warning0("predict.s has an unexpected class ", quotify(class(predict.s))) } } if(xlab != "Leverage" && level && !newline) # two newlines is too many main <- sprint("%s\n%g%% level shaded", main, 100*(level)) main } # plot resids of oof meanfit with col.cv (default lightblue) draw.oof.meanfit <- function(cv.oof.fit.tab, fitted, versus1, rinfo, which, col.cv, nversus) { # mean of each row of oof.fit.tab meanfit <- apply(cv.oof.fit.tab, 1, mean) meanfit <- rinfo$scale * (meanfit - fitted) order <- order(versus1) trans.versus1 <- trans.versus(versus1[order], which) x <- if(nversus == V2INDEX) 1:length(trans.versus1) else trans.versus1 lines(x, trans.resids(meanfit[order], which), col=col.cv) } draw.density.along.the.bottom <- function(x, den.col=NULL, scale=NULL, ...) { if(is.null(den.col)) den.col <- dota("density.col", DEF="gray57", EX=0, ...) den <- try(density(x, adjust=dota("density.adjust", DEF=.5, EX=0, ...), na.rm=TRUE), silent=TRUE) if(is.try.err(den)) warning0("draw.density.along.the.bottom: cannot determine density") else { usr <- par("usr") # xmin, xmax, ymin, ymax if(is.null(scale)) scale <- .08 / (max(den$y) - min(den$y)) den$y <- usr[3] + den$y * scale * (usr[4] - usr[3]) call.plot(graphics::lines.default, PREFIX="density.", drop.adjust=1, force.x=den, force.y=NULL, def.col=den.col, ...) } } draw.rlm.line <- function(which, versus1, resids, nversus, ...) { trans.resids <- trans.resids(resids, which) trans.versus <- trans.versus(versus1, which) x <- if(nversus == V2INDEX) 1:length(trans.versus) else trans.versus if(which == W9LOGLOG) { # ignore lower 10% of points (very small residuals i.e. very neg logs) quant <- quantile(trans.versus, probs=.1, na.rm=TRUE, names=FALSE) ok <- which(x > quant) x <- x[ok] trans.resids <- trans.resids[ok] } # # regression on 10 bootstrap samples so we can see variance of versus1 # for(i in 1:10) { # j <- sample.int(length(x), replace=TRUE) # trans.resids1 <- trans.resids[j] # trimmed.trans.fit1 <- x[j] # rlm <- MASS::rlm(trans.resids1~trimmed.trans.fit1, # method="MM", na.action="na.omit") # if(draw) # abline(coef(rlm), col="lightgray", lwd=.6) # } # robust linear regression of trans.resids on x # na.omit is needed if some versus1 (or resids) were nonpos so log(versus1) is NA rlm <- MASS::rlm(trans.resids~x, method="MM", na.action="na.omit") call.dots(abline, force.coef = coef(rlm), force.col = "lightblue", force.lwd = dota("smooth.lwd lwd.smooth lwd.loess", EX=c(0,1,1), DEF=1, NEW=1, ...) + 1, ...) box() # abline overplots the box coef(rlm) } draw.resids.info <- function(which, info, versus1, resids, nversus, rsq, coef.rlm, ...) { trans.versus <- trans.versus(versus1, which) x <- if(nversus == V2INDEX) 1:length(trans.versus) else trans.versus # TODO consider also drawing the density along the right side draw.density.along.the.bottom(x, ...) if(nversus != V4LEVER) { lm.text <- "" slope.text <- "" if(which == W5ABS || which == W9LOGLOG) { # added linear regression line? stopifnot(length(coef.rlm) == 2) slope.text <- sprint(" slope %.2g", coef.rlm[2]) } # exact=FALSE else get warning "Cannot compute exact p-value with ties" cor.abs <- cor.test(versus1, abs(resids), method="spearman", exact=FALSE) if(nversus == V3RESPONSE) { cor <- cor.test(versus1, resids, method="spearman", exact=FALSE) text <- sprint("spearman abs %.2f resids %.2f\n%s", cor.abs$estimate, cor$estimate, slope.text) } else if(which == W3RESID && nversus == V1FITTED) text <- sprint("rsq %.2f spearman abs %.2f", rsq, cor.abs$estimate) else text <- sprint("spearman abs %.2f%s", cor.abs$estimate, slope.text) cex <- .9 usr <- par("usr") # xmin, xmax, ymin, ymax text.on.white(x = usr[1] + strwidth("x", font=1), y = usr[4] - cex * (strheight(text, font=1) + .5 * strheight("X", font=1)), label = text, cex = cex, adj=c(0, 0), font=1, col=1, xpd=NA) } } my.log10 <- function(x) # log of very small values is silently set to NA { i <- which(x < max(x) / 1e6) x[i] <- 1 x <- log10(x) x[i] <- NA x } trans.versus <- function(versus, which) { if(which %in% (W7VLOG:W9LOGLOG)) my.log10(versus) else versus } trans.resids <- function(resid, which) # transform the residuals { if(which == W5ABS) abs(resid) else if(which == W6SQRT) sqrt(abs(resid)) else if(which == W7VLOG) abs(resid) else if(which == W8CUBE) { # do it in two steps so no problem with negative numbers resid <- resid^2 resid^(1/3) } else if(which == W9LOGLOG) my.log10(abs(resid)) else resid } # Get a subset of x. Size of subset is nsubset. Returns an index vector. # The subset includes the 20 biggest absolute values in x. # If you want more than the 20 biggest values, set nbiggest. get.isubset <- function(x, nsubset, nbiggest=0, use.all=FALSE, scale=NULL) { check.vec(x, "x passed to get.isubset", length(x)) ix <- seq_len(length(x)) if(nsubset > 0 && nsubset < length(x) && !use.all) { # TODO move this into caller # take a sample, but make sure it includes the 20 biggest absolute values nsubset <- min(nsubset, length(x)) nbiggest <- min(max(20, nbiggest), nsubset) isorted <- order(abs(x), decreasing=TRUE) # expensive ikeep <- seq_len(nbiggest) if(nsubset > nbiggest) ikeep <- c(ikeep, seq(from=nbiggest + 1, to=length(x), length.out=nsubset - nbiggest)) ix <- isorted[ikeep] # force in points with unity leverage if(!is.null(scale)) { which <- which(is.na(scale)) if(length(which) > 0) ix <- sort_unique(c(which, ix)) } } ix # index vector } # get the indices of the id.n biggest resids (requires a sort) get.id.indices <- function(resids, id.n, hatvalues=NULL) { # id.n has already been checked in plotres.data if(id.n == 0) return(NULL) if(id.n > 0) { # same as plot.lm i <- sort.list(abs(resids), decreasing=TRUE, na.last=NA) if(length(i) > id.n) i <- i[1:id.n] } else { # id.n is negative: most positive and most negative residuals id.n <- -id.n i <- sort.list(resids, decreasing=TRUE, na.last=NA) if(length(i) > id.n) i <- i[c(1:id.n, length(i) + 1 - (1:id.n))] } if(!is.null(hatvalues)) { # add the worst hatvalues i.e. the worst leverages i <- unique(c(i, order(hatvalues, decreasing=TRUE)[1:id.n])) } i } possible.plotres.legend <- function(which, level, smooth.col, oof.meanfit.was.plotted, ...) { # add legend, else red and blue may confuse the user legend.pos <- dota("legend.pos", DEF=NULL, ...) if(level && oof.meanfit.was.plotted && (is.null(legend.pos) || !all(is.na(legend.pos)))) { if(is.null(legend.pos)) { # auto? legend.x <- "bottomleft" legend.y <- NULL } else { # user specified legend position legend.x <- legend.pos[1] legend.y <- if(length(legend.pos) > 1) legend.pos[2] else NULL } legend.txt <- NULL legend.col <- NULL legend.lwd <- NULL legend.lty <- NULL if(which != W9LOGLOG && is.specified(smooth.col)) { # smooth plotted? legend.txt <- "smooth" legend.col <- smooth.col legend.lwd <- dota("smooth.lwd lwd.smooth lwd.loess", EX=c(0,1,1), DEF=1, NEW=1, ...) legend.lty <- 1 } if(oof.meanfit.was.plotted) { legend.txt <- c(legend.txt, "cross validated oof fit") legend.col <- c(legend.col, dota("col.cv", ...)) legend.lwd <- c(legend.lwd, 1) legend.lty <- c(legend.lty, 1) } if(!is.null(legend.txt)) call.dots(graphics::legend, DROP="*", KEEP="PREFIX", force.x = legend.x, force.y = legend.y, force.legend = legend.txt, def.col = legend.col, def.lwd = legend.lwd, def.lty = legend.lty, def.bg = "white", def.cex = .8, ...) } } plotmo/R/caret.R0000644000176200001440000000640013723055003013204 0ustar liggesusers# caret.R: plotmo functions for caret objects # # TODO Currently only caret "train" objects have explicit support. # sanity check that object a caret train object # (since "train" is a quite generic name) check.is.caret.train.object <- function(object) { class <- class(object)[1] stopifnot.string(class) mod <- object[["finalModel"]] # S3 models are lists, S4 models aren't lists. # Plotmo support S4 models only if they are wrapped in a caret model. # Example S4 model: kernlab::ksvm created with train(..., method="svmRadial", ...). if(class != "train" || is.null(mod) || (!is.list(mod) && !isS4(mod))) stop0("unrecognized \"train\" object ", "(was expecting a train object from the caret package)") } plotmo.prolog.train <- function(object, object.name, trace, ...) { check.is.caret.train.object(object) # call plotmo.prolog for the finalModel for its side effects # (e.g. may attach plotmo.importance to the finalModel) finalModel <- try(plotmo.prolog(object$finalModel, object.name, trace, ...), silent=trace < 2) is.err <- is.try.err(finalModel) trace1(trace, "plotmo.prolog(object$finalModel) %s\n", if(is.err) "failed, continuing anyway" else "succeeded (caret model)") if(!is.err) object$finalModel <- finalModel object } plotmo.singles.train <- function(object, x, nresponse, trace, all1, ...) { check.is.caret.train.object(object) singles <- try(plotmo.singles(object$finalModel, x, nresponse, trace, all1, ...), silent=trace < 2) is.err <- is.try.err(singles) trace2(trace, "plotmo.singles(object$finalModel) %s\n", if(is.err) "failed" else "succeeded") if(is.err) plotmo.singles.default(object, x, nresponse, trace, all1, ...) else singles } plotmo.pairs.train <- function(object, x, nresponse, trace, all2, ...) { check.is.caret.train.object(object) pairs <- try(plotmo.pairs(object$finalModel, x, nresponse, trace, all2, ...), silent=trace < 2) is.err <- is.try.err(pairs) trace2(trace, "plotmo.pairs(object$finalModel) %s\n", if(is.err) "failed" else "succeeded") if(is.err) plotmo.pairs.default(object, x, nresponse, trace, all2, ...) else pairs } # determine "type" arg for predict() plotmo.type.train <- function(object, ..., TRACE) { "raw" # check.is.caret.train.object(object) # trace <- TRACE # type <- try(plotmo.type(object$finalModel, ..., TRACE=TRACE), silent=trace < 2) # is.err <- is.try.err(type) # trace2(trace, "plotmo.type(object$finalModel) %s\n", # if(is.err) "failed" else "succeeded") # if(is.err) # "raw" # else # type } # determine "type" arg for residuals() plotmo.residtype.train <- function(object, ..., TRACE) { "raw" # check.is.caret.train.object(object) # trace <- TRACE # type <- try(plotmo.residtype(object$finalModel, ...), silent=trace < 2) # is.err <- is.try.err(type) # trace2(trace, "plotmo.residtype(object$finalModel) %s\n", # if(is.err) "failed" else "succeeded") # if(is.err) # "raw" # else # type } plotmo/R/pint.R0000644000176200001440000001241513724524740013075 0ustar liggesusers# pint.R: plotmo functions for confidence and prediction intervals # Handle plotmo's "level" argument. Return a prediction interval dataframe # with either or both of the following sets of columns. What columns get # returned depends on the capabilities of the object's predict method. # For example, predict.lm allows us to return both i and ii, and for # earth models we can return only i. # # (i) lwr, upr intervals for prediction of new data # # (ii) cint.lwr, cint.upr intervals for prediction of mean response plotmo_pint <- function(object, newdata, type, level, trace, ipred, inverse.func) { if(!is.specified(level)) return(NULL) trace2(trace, "plotmo_pint for %s object\n", class.as.char(object)) stopifnot.string(type) # call plotmo.pint.xxx where xxx is object's class intervals <- plotmo.pint(object, newdata, type, level, trace) if(!is.null(intervals$lwr)) { intervals$lwr <- apply.inverse.func(inverse.func, intervals$lwr, object, trace) intervals$upr <- apply.inverse.func(inverse.func, intervals$upr, object, trace) } if(!is.null(intervals$cint.lwr)) { intervals$cint.lwr <- apply.inverse.func(inverse.func, intervals$cint.lwr, object, trace) intervals$cint.upr <- apply.inverse.func(inverse.func, intervals$cint.upr, object, trace) } print_summary(intervals, "prediction intervals", trace) intervals } # Return a data.frame with either or both of the following variables: # (i) lwr, upr intervals for prediction of new data # (ii) cint.lwr, cint.upr intervals for prediction of mean response plotmo.pint <- function(object, newdata, type, level, trace, ...) { UseMethod("plotmo.pint") } plotmo.pint.default <- function(object, ...) { stop0("the level argument is not supported for ", class.as.char(object, quotify=TRUE), " objects") } plotmo.pint.lm <- function(object, newdata, type, level, ...) { # lm objects with weights do not support confidence intervals on new data if(!is.null(object$weights)) stop0("the level argument is not supported on lm objects with weights") pints <- predict(object, newdata, interval="prediction", level=level) cints <- predict(object, newdata, interval="confidence", level=level) data.frame( lwr = pints[,"lwr"], # intervals for prediction of new data upr = pints[,"upr"], cint.lwr = cints[,"lwr"], # intervals for prediction of mean response cint.upr = cints[,"upr"]) } plotmo.pint.glm <- function(object, newdata, type, level, ...) { if(!is.null(object$weights) && !all(object$weights == object$weights[1])) warnf( "the level argument may not work correctly on glm objects built with weights") quant <- 1 - (1 - level) / 2 # .95 becomes .975 predict <- predict(object, newdata, type=type, se.fit=TRUE) data.frame(cint.lwr = predict$fit - quant * predict$se.fit, cint.upr = predict$fit + quant * predict$se.fit) } # package mgcv, or package gam version less than 1.15 plotmo.pint.gam <- function(object, newdata, type, level, ...) { if(!is.null(object$weights) && !all(object$weights == object$weights[1])) warnf( "the level argument may not work correctly on gam objects built with weights") quant <- 1 - (1 - level) / 2 # .95 becomes .975 predict <- predict(object, newdata, type=type, se.fit=TRUE) # special handling for where user used gam::gam instead of mgcv::gam # (applies only package gam version less than 1.15) if(class(predict)[1] == "numeric" && "package:gam" %in% search()) { cat("\n") stop0("gam objects in the 'gam' package do not support ", "confidence intervals on new data") } data.frame(cint.lwr = predict$fit - quant * predict$se.fit, cint.upr = predict$fit + quant * predict$se.fit) } # package gam version 1.15 or higher plotmo.pint.Gam <- function(object, newdata, type, level, ...) { if(!is.null(object$weights) && !all(object$weights == object$weights[1])) warnf( "the level argument may not work correctly on Gam objects built with weights") quant <- 1 - (1 - level) / 2 # .95 becomes .975 predict <- predict(object, newdata, type=type, se.fit=TRUE) if(class(predict)[1] == "numeric") { cat("\n") stop0("Gam objects do not support confidence intervals on new data") } data.frame(cint.lwr = predict$fit - quant * predict$se.fit, cint.upr = predict$fit + quant * predict$se.fit) } plotmo.pint.quantregForest <- function(object, newdata, type, level, ...) { q0 <- (1 - level) / 2 # .95 becomes .025 q1 <- 1 - q0 # .975 predict <- predict(object, newdata, quantiles=c(q0, q1)) data.frame(lwr = predict[,1], upr = predict[,2]) } plotmo.pint.earth <- function(object, newdata, type, level, ...) { pints <- predict(object, newdata=newdata, type=type, interval="pint", level=level) if(is.null(newdata)) { cints <- predict(object, newdata=NULL, type=type, interval="cint", level=level) pints$cint.upr <- cints$upr pints$cint.lwr <- cints$lwr } pints } plotmo/R/spread.labs.R0000644000176200001440000000757214563577756014352 0ustar liggesusers# Copied from the orphaned package TeachingDemos version 2.12.1 on Feb 16, 2024. # ------------------------------------------------------------------------------ # # --Title-- # # Spread out close points for labeling in plots # # --Description-- # # This function takes as set of coordinates and spreads out the close # values so that they can be used in labeling plots without overlapping. # # --Usage-- # # spread.labs(x, mindiff, maxiter = 1000, stepsize = 1/10, min = -Inf, max = Inf) # # --Arguments-- # # x The coordinate values (x or y, not both) to spread out. # mindiff The minimum distance between return values # maxiter The maximum number of iterations # stepsize How far to move values in each iteration # min Minimum bound for returned values # max Maximum bound for returned values # # --Details-- # # Sometimes the desired locations for labels in plots results in the # labels overlapping. This function takes the coordinate values (x or #- y, not both) and finds those points that are less than mindiff # (usually a function of strheight or strwidth ) apart and # increases the space between them (by stepsize * mindiff ). # This may or may not be enough and moving some points # away from their nearest neighbor may move them too close to another # neighbor, so the process is iterated until either maxiter steps # have been tried, or all the values are at least mindiff apart. # # The min and max arguments prevent the values from going # outside that range (they should be specified such that the original # values are all inside the range). # # The values do not need to be presorted. # # --Return Value-- # # A vector of coordinates (order corresponding to the original x ) # that can be used as a replacement for x in placing labels. # # --Author-- # # Greg Snow email 538280@gmail.com # # --See Also-- # # The spread.labels function in the plotrix package. # # --Examples-- # # # overlapping labels # plot(as.integer(state.region), state.x77[,1], ylab='Population', # xlab='Region',xlim=c(1,4.75), xaxt='n') # axis(1, at=1:4, lab=levels(state.region) ) # # text( as.integer(state.region)+.5, state.x77[,1], state.abb ) # segments( as.integer(state.region)+0.025, state.x77[,1], # as.integer(state.region)+.375, state.x77[,1] ) # # # now lets redo the plot without overlap # # tmp.y <- state.x77[,1] # for(i in levels(state.region) ) { # tmp <- state.region == i # tmp.y[ tmp ] <- spread.labs( tmp.y[ tmp ], 1.2*strheight('A'), # maxiter=1000, min=0 ) # } # # plot(as.integer(state.region), state.x77[,1], ylab='Population', # xlab='Region', xlim=c(1,4.75), xaxt='n') # axis(1, at=1:4, lab=levels(state.region) ) # # text( as.integer(state.region)+0.5, tmp.y, state.abb ) # segments( as.integer(state.region)+0.025, state.x77[,1], # as.integer(state.region)+0.375, tmp.y ) # } spread.labs <- function(x, mindiff, maxiter=1000, stepsize=1/10, min=-Inf, max=Inf) { unsort <- order(order(x)) x <- sort(x) df <- x[-1] - x[ -length(x) ] stp <- mindiff * stepsize i <- 1 while( any( df < mindiff ) ) { tmp <- c( df < mindiff, FALSE ) if( tmp[1] && (x[1] - stp) < min ) { # don't move bottom set tmp2 <- as.logical( cumprod(tmp) ) tmp <- tmp & !tmp2 } x[ tmp ] <- x[ tmp ] - stp tmp <- c( FALSE, df < mindiff ) if( tmp[length(tmp)] && (x[length(x)] + stp) > max ) { # don't move top tmp2 <- rev( as.logical( cumprod( rev(tmp) ) ) ) tmp <- tmp & !tmp2 } x[ tmp ] <- x[ tmp] + stp df <- x[-1] - x[-length(x)] i <- i + 1 if( i > maxiter ) { warning("Maximum iterations reached") break } } x[unsort] } plotmo/R/naken.R0000644000176200001440000001326513724000770013213 0ustar liggesusers# naken.R: # Like naken.collapse but don't collapse a vector of strings into a single string. # # e.g. c("num","sqrt(num)","ord","offset(off)") # becomes c("num","num" "ord", "off") naken <- function(s) { naked <- character(length(s)) for(i in seq_along(s)) naked[i] <- naken.collapse(s[i]) naked } # Collapse s to s single string and then "naken" it # (i.e. return only the variables in the string, separated by "+"). # # e.g. "x1" becomes "x1" # "sqrt(x1)" becomes "x1" # "s(x1,x4,df=4)" becomes "x1+x4" # "sqrt(x1) as.numeric(x4)" becomes "x1" # c("sqrt(x1)", "as.numeric(x4)") becomes "x1" # `x 3` becomes "`x 3`" (variables in backquotes unchanged) naken.collapse <- function(s, warn.if.minus=FALSE) { s <- paste.collapse(s) s.org <- s untouchable <- get.untouchable.for.naken(s) s <- strip.space(untouchable$s) # strip space from everything except untouchables # for "ident" gsubs below if(grepl("--", s, fixed=TRUE)) # '--'causes problems because '-' gets turned to '+' below warning0("Consecutive '-' in formula may cause problems\n Formula:", s.org) # # check for "- ident" in formula (but -1 is ok) # # # commented out because this is invisible to the user, because # # plotmo does not plot the -ident variable # # if(warn.if.minus && grepl("\\- *[._[:alpha:]]", s)[1]) # warnf("plotmo will include the variable prefixed by \"-\" in the formula\n Formula: %s", s) # TODO we can't ignore "-" below because of the paste0(collapse=" + ") later below s <- gsub("[-*/:]", "+", s) # replace - / * : with + # next two gsubs allow us to retain "x=x1" but drop "df=99" from "bs(x=x1, df=99)" s <- gsub("\\(._$[[:alnum:]]+=", "(", s) # replace "(ident=" with "(" s <- gsub("[._$[:alnum:]]+=[^,)]+", "", s) # delete "ident=any" # replace ",ident" with ")+f(ident", thus "s(x0,x1)" becomes "s(x0)f(x1)" s <- gsub(",([._$[:alpha:]])", ")+f(\\1", s) regex <- "[._$[:alnum:]]*\\(" if(grepl(regex, s)) { s <- gsub(regex, "", s) # replace ident( s <- gsub("[,)][^+-]*", "", s) # remove remaining ",arg1,arg2)" } # s is now something like x1+x2, split it on "+" for further processing s <- strsplit(s, "+", fixed=TRUE)[[1]] s <- unique(s) # remove duplicates # remove numbers e.g. sin(x1*x2/12) is nakened to x1+x1+12, we don't want the 12 is.num <- sapply(s, function(x) grepl("^([0-9]|\\.[0-9])", x)) # but keep the intercept if there is one which1 <- which(s == "1") is.num[which1] <- FALSE s <- paste0(s[!is.num], collapse=" + ") replace.untouchable.for.naken(s, untouchable$replacements) } # In the function naken.collapse(), terms such as [string] and `string` # must remain the same (regardless of the enclosed string). # That is, strings in brackets or backquotes must remain untouched. # # This function searches for such terms, replaces them with dummies, and # remembers where they were in the original string (for re-replacement later). # # For example, if s = "x1 + x[,2] + `x 3`" we return: # # out: "x1 + x!00000! + !00001!" # note the dummies !00000! and !00001! # # replacements: # replacement original # "[00000]" "[,2]" # "[00001]" "`x 3`" get.untouchable.for.naken <- function(s) # utility for naken { # for efficiency, check for most common case (no [ or ` in s) if(!grepl("[\\[\`]", s)[1]) return(list(s=s, replacements=NULL)) # no [ or ` in s stopifnot(length(s) == 1) # out and untouchables will be the returned string and table of untouchables # for simplicity, create untouchables as a vec and convert to a mat at the end out <- "" untouchables <- NULL cs <- strsplit(s, split="")[[1]] # split into individual chars for loop efficiency len <- length(cs) i <- 1 while(i <= len) { c <- cs[i] # i==len below is for malformed strings with extra [ or ` on end if((c != "[" && c != "\`") || i == len) # normal character out <- paste0(out, c) else { # char is [ or `, skip to matching ] or ` istart <- i nestdepth <- 0 endchar <- if(c == "[") "]" else "\`" for(i in (istart+1):len) { if(c == "[" && cs[i] == "[") nestdepth <- nestdepth + 1 # nested brackets if(cs[i] == endchar) { if(nestdepth <= 0) break else nestdepth <- nestdepth - 1 } } replacement <- sprint("!%05.5g!", length(untouchables) / 2) out <- paste0(out, replacement) untouchables <- c(untouchables, replacement, substr(s, istart, i)) } i <- i + 1 } if(length(untouchables)== 0) # malformed s="[" or s="`" return(list(s=s, replacements=NULL)) replacements <- matrix(untouchables, byrow=TRUE, ncol=2, nrow=length(untouchables) / 2) colnames(replacements) <- c("replacement", "original") list(s=out, replacements=replacements) } # undo the effect of get.untouchable.for.naken replace.untouchable.for.naken <- function(s, replacements) { for(i in seq_len(NROW(replacements))) s <- gsub(replacements[i, 1], replacements[i, 2], s, fixed=TRUE) s } plotmo/R/type.R0000644000176200001440000000666613722310235013105 0ustar liggesusers# type.R: plotmo functions for getting the default type arg for predict() and residuals() # this is used when plotmo's argument "type" is NULL (the default) # get the default type for predict() plotmo.type <- function(object, ..., TRACE) { UseMethod("plotmo.type") } plotmo.type.default <- function(object, ..., TRACE) { "response" } plotmo.type.nnet <- function(object, ..., TRACE) { "raw" } plotmo.type.knn3 <- function(object, ..., TRACE) { "prob" } plotmo.type.tree <- function(object, ..., TRACE) # tree package { "vector" } plotmo.type.fda <- function(object, ..., TRACE) # mda package { "class" } # get the type for residuals() plotmo.residtype <- function(object, ..., TRACE) { UseMethod("plotmo.residtype") } plotmo.residtype.default <- function(object, ..., TRACE) { plotmo.type(object, ..., TRACE=TRACE) # use the predict type } # TRUE if we are predicting probabilities. # This is used for setting the default ylim to c(0,1). # Not always reliable (but if wrong, the user can override with explicit ylim arg). # It can save a call get.ylim.by.dummy.plots, and also works for objects # for which get.ylim.by.dummy.plots doesn't automatically figure out c(0,1) is.yaxis.a.probability.aux <- function(object, type, trace) { if(inherits(object, "WrappedModel")) { # mlr package # will be we be predicting probabilities? # TODO this will be wrong if use say nresponse="response" in call to plotmo call <- object[["call"]] if(!is.null(call)) { # TODO assumes environment for learner is available and correct learner <- eval(call[["learner"]]) if(!is.null(learner)) { predict.type <- mlr::getLearnerPredictType(learner) if(substr(predict.type[1], 1, 1) == "p") # prob return(TRUE) } } # continue processing, but use the learner.model object <- object$learner.model } type.firstchar <- substr(type[1], 1, 1) # type argument to predict() substr(type[1], 1, 4) == "prob" || # catchall (inherits(object, "rpart") && object$method[1] == "class" && type.firstchar == "p") || # following not strictly necessary for earth models because # get.ylim.by.dummy.plots can also figure this out # The "r" below is for "response" (inherits(object, "earth") && is.nomial(object$glm.list[[1]]) && type.firstchar == "r") || # the "r" below is for "response" (inherits(object, c("glm", "glmnet", "pre")) && is.nomial(object) && type.firstchar == "r") || (inherits(object, "cv.glmnet") && !is.null(object$glmnet.fit$classnames)) || (inherits(object, "randomForest") && is.character(object$type) && object$type[1] == "classification" && type.firstchar == "p") || (inherits(object, "C5.0") && type.firstchar == "p") } is.yaxis.a.probability <- function(object, type, trace) { # This wrapper exists because we don't want plotmo to completely stop # (issue an error) if a package changes the model fields. (This function is # vulnerable to changes because it accessess internal fields in multiple # different models.) is.prob <- try(is.yaxis.a.probability.aux(object, type, trace), silent=trace < 2) if(is.try.err(is.prob)) FALSE else is.prob } plotmo/R/xy.R0000644000176200001440000014776414566065135012606 0ustar liggesusers# xy.R: get a model's x or y (the plotmo_x and plotmo_y functions) # # Tracing is verbose and error messages are detailed throughout this # file, to facilitate diagnosis when a model doesn't work with plotmo. #------------------------------------------------------------------------------ # Return the "x" matrix for a model. This returns a data.frame which # always has column names. It tries hard to get x regardless of the model. # It can be used for models without a formula, provided that getCall(object) # or model$x is available. # # The returned columns are for the "naked" predictors e.g. "x3" instead of # "ns(x3,4)". Column names are manufactured when necessary, as "x1", # "x2", etc. This is needed for example for rpart(x,y) where x does not # have column names. # # It can handle sparse matrices from the Matrix package. These get # returned as a (non sparse) data.frame. # # If stringsAsFactors=FALSE, strings do not get converted to factors. plotmo_x <- function(object, trace, stringsAsFactors=TRUE) { trace2(trace, "--plotmo_x for %s object\n", class.as.char(object)) x <- plotmo.x(object, trace) do.subset <- TRUE # plotmo.x.default returns list(field, do.subset), so handle that if(is.list(x) && !is.data.frame(x) && !is.null(x$do.subset)) { do.subset <- check.boolean(x$do.subset) x <- x$field } # Following are mainly for when plotmo.x didn't invoke plotmo.x.default. # It shouldn't be needed but is included here to make sure. x <- cleanup.x.or.y(object, x, "x", trace, check.naked=FALSE) stopifnot(is.good.data(x, "plotmo_x", check.colnames=FALSE)) x <- my.data.frame(x, trace, stringsAsFactors) if(do.subset) { subset <- get.and.check.subset(x, object, trace) if(!is.null(subset)) { trace2(trace, "subset applied to x[%d,%d] ", NROW(x), NCOL(x)) x <- x[subset, , drop=FALSE] trace2(trace, "to yield x[%d,%d]\n", NROW(x), NCOL(x)) } } colnames(x) <- gen.colnames(x, "x", "x", trace) print_summary(x, "plotmo_x returned", trace) x } plotmo.x <- function(object, trace, ...) { # returns x or list(field=x, do.subset=do.subset) UseMethod("plotmo.x") } plotmo.x.default <- function(object, trace, ...) { # returns list(field=x, do.subset=do.subset) get.x.or.y(object, "x", trace, naked=TRUE) } # plotmo_y is similar to model.response but can handle models # that were created without a formula. # # For more details on the args and return value, see process.y. # If nresponse is not NULL we return the naked response variables # e.g. Volume not log(Volume). # # If convert.glm.response=TRUE and the model is a glm model we may # convert the response. See convert.glm.response() for details. plotmo_y <- function(object, nresponse=NULL, trace=0, expected.len=NULL, resp.levs=NULL, convert.glm.response=!is.null(nresponse)) { trace2(trace, "--plotmo_y with nresponse=%s for %s object\n", if(is.null(nresponse)) "NULL" else format(nresponse), class.as.char(object)) y <- plotmo.y(object, trace, naked=FALSE, expected.len, nresponse) do.subset <- TRUE # plotmo.y.default returns list(field, do.subset), so handle that if(is.list(y) && !is.data.frame(y) && !is.null(y$do.subset)) { do.subset <- check.boolean(y$do.subset) y <- y$field } if(convert.glm.response) y <- convert.glm.response(object, y, trace) if(do.subset) { subset <- get.and.check.subset(y, object, trace) if(!is.null(subset)) { trace2(trace, "subset applied to y[%d,%d] ", NROW(y), NCOL(y)) y <- if(is.null(dim(y))) y[subset] else y[subset, , drop=FALSE] trace2(trace, "to yield y[%d,%d]\n", NROW(y), NCOL(y)) } } process.y(y, object, type="response", nresponse, expected.len, resp.levs, trace, "plotmo_y") } # Note that the naked argument is irrelevant unless the response was # specified with a wrapper function like log(Volume) instead of plain Volume. # # The default for nresponse allows this to work with old versions of earth # (old plotmo.y.earth doesn't have a nresponse argument). plotmo.y <- function(object, trace, naked, expected.len, nresponse=1, ...) { # returns y or list(field=y, do.subset=do.subset) UseMethod("plotmo.y") } plotmo.y.default <- function(object, trace, naked, expected.len, ...) { # returns list(field=y, do.subset=do.subset) get.x.or.y(object, "y", trace, try.object.x.or.y=TRUE, argn=2, nrows.argn=expected.len, naked) } # Get x or y from the given model object # Returns list(field=x, do.subset=do.subset) where x is "x" or "y". get.x.or.y <- function( object, # the model field, # "x" or "y" trace, try.object.x.or.y=TRUE, # FALSE if object[[field]] should be ignored argn=0, # if nonzero, consider argument nbr argn of the model call nrows.argn=NULL, # expected NROWS of argument argn naked=TRUE) # TRUE to return colnames like "x3" not "ns(x3,4)" { ret.good.field <- function(x, do.subset=TRUE, source) { if(trace.call.global >= 1 && field == "y") { field <- if(field == "x") "predictors" else "response" if(grepl("model.frame(", source, fixed=TRUE)) source <- sub(",", # insert newline after first comma if(field == "response") ",\n " else ",\n ", source) printf("got model %s from %s\n", field, source) } list(field=x, do.subset=do.subset) } stopifnot(is.list(object)) stopifnot(field == "x" || field == "y") # try using object$x (where x is actually x or y throughout this file) object.x <- get.object.x.or.y.field(object, field, trace, try.object.x.or.y, naked) # object.x is object$x or NULL or an err msg if(is.good.data(object.x)) return(ret.good.field(object.x, FALSE, sprint("object$%s", field))) call <- getCall(object) if(!is.null(call)) trace2(trace, "\nobject call is %s\n", trunc.deparse(call, maxlen=80)) # try getting x or y from the model formula and model frame temp <- get.x.or.y.from.model.frame(object, field, trace, naked) model.frame.x <- temp$x do.subset <- temp$do.subset # TRUE when newdata is NULL source <- temp$source # model.frame.x is now x or y or NULL or an err msg if(is.good.data(model.frame.x)) { formula.as.char <- paste.collapse(format(temp$formula)) if(naked && grepl("\`", formula.as.char)) { # exception for hinge funcs etc trace2(trace, "setting check.naked=FALSE because backtick in formula\n") naked <- FALSE } model.frame.x <- cleanup.x.or.y(object, model.frame.x, field, trace, check.naked=naked && field != "y") if(!is.errmsg(model.frame.x)) return(ret.good.field(model.frame.x, do.subset, source)) } # try getCall(object)$x call.x <- get.data.from.object.call.field(object, field, trace) # call.x is getCall(object)$x or an error message if(is.good.data(call.x)) return(ret.good.field(call.x, TRUE, sprint("getCall(object)$%s", field))) # else { # TODO may not want to do this if x is ok except for no colnames # # try getCall(object)$X (note upper case "X") # upfield <- toupper(field) # call.x <- get.data.from.object.call.field(object, upfield, trace) # # call.x is getCall(object)$X or an error message # if(is.good.data(call.x)) { # # paranoia, check that argument number is correct # ifield <- if(field == "x") 2 else 3 # ok <- names(getCall(object))[ifield] == upfield # if(!is.na(ok) && length(ok == 1) && ok) # return(ret.good.field(call.x, TRUE, # sprint("getCall(object)$%s", upfield))) # else if(trace >= 2) # printf("ignoring getCall(object)$%s because it isn't arg number %d\n", # upfield, ifield) # } # } trace2(trace, "\n") # consider argument number argn of the model call (ignoring its name) temp <- get.argn.from.call(argn, object, field, trace, nrows.argn) argn.x <- temp$x argn <- temp$argn # may clear argn (for uncluttered errmsg later) # argn.x is the evaluated n'th arg or NULL or an err msg argn.name <- sprint("argument %g of the model call", argn) if(is.good.data(argn.x)) return(ret.good.field(argn.x, TRUE, argn.name)) # We don't have an x with colnames, so see if we have one without colnames. # We re-call is.errmsg() below to prevent re-issuing messages # in is.good.data() which we have already issued previously. if(try.object.x.or.y && !is.errmsg(object.x) && is.good.data(object.x, sprint("object$%s", field), trace, check.colnames=FALSE)) return(ret.good.field(object.x, FALSE, sprint("object$%s", field))) if(!is.errmsg(call.x) && is.good.data(call.x, sprint("call$%s", field), trace, check.colnames=FALSE)) return(ret.good.field(call.x, TRUE, sprint("getCall(object)$%s", field))) if(argn && !is.errmsg(argn.x) && is.good.data(argn.x, argn.name, trace, check.colnames=FALSE)) return(ret.good.field(argn.x, TRUE, sprint("object$%s", field))) # unsuccessful errmsg.for.get.x.or.y(field, trace, try.object.x.or.y, argn, object.x, model.frame.x, call.x, argn.x) is.earth.cv.model <- is.null(object.x) && !is.null(object$ifold) && inherits(object, "earth") stopf("cannot get the original model %s%s", if(field == "x") "predictors" else "response", if(is.earth.cv.model) " (use keepxy=2 in the call to earth)" else "") } is.errmsg <- function(x) { is.try.err(x) || (is.character(x) && length(x) == 1) } # Is the x argument a valid x or y for a model? # This returns TRUE or FALSE, silently unless trace >= 2. is.good.data <- function(x, xname="field", trace=0, check.colnames=TRUE) { good <- !is.null(x) && !is.try.err(x) && NROW(x) >= 3 has.colnames <- good && !is.null(colnames(x)) && !any(colnames(x) == "") if(trace >= 2) trace.data(good, has.colnames, x, xname, trace, check.colnames) good && (!check.colnames || has.colnames) } trace.data <- function(good, has.colnames, x, xname, trace, check.colnames) { stopifnot.string(xname) colnames.msg <- if(good && has.colnames) { sprint(" and has column name%s %s", if(length(colnames(x)) == 1) "" else "s", paste.trunc(colnames(x), maxlen=100)) } else if(good) sprint(" but without colnames %s", if(check.colnames) "so we will keep on searching" else "but we will use it anyway") else "" if(good) printf("%s is usable%s\n", xname, colnames.msg) else if(is.null(x)) printf("%s is NULL%s\n", xname, if(check.colnames) " (and it has no colnames)" else "") else if(!is.character(x) && NROW(x) < 3) printf("%s has less than three rows\n", xname, if(check.colnames) " (and it has no colnames)" else "") else printf("%s is not usable%s\n", xname, colnames.msg) # print bad data, but only on the first go around for this data # (use check.colnames as an indicator of first go around) if(!is.null(x) && check.colnames) { if(!good) printf("%s:%s\n", xname, format_err_field(x, xname, trace)) else if(trace >= 4) { printf("trace>=4: ") print_summary(x, xname, trace=2) } } } errmsg.for.get.x.or.y <- function(field, trace, try.object.x.or.y, argn, object.x, model.frame.x, call.x, argn.x) { printf("\nLooked unsuccessfully for the original %s in the following places:\n", if(field == "x") "predictors" else "response") ifield <- 1 if(try.object.x.or.y) { printf("\n(%d) object$%s:%s\n", ifield, field, format_err_field(object.x, field, trace)) ifield <- ifield + 1 } printf("\n(%d) model.frame:%s\n", ifield, format_err_field(model.frame.x, field, trace)) ifield <- ifield + 1 printf("\n(%d) getCall(object)$%s:%s\n", ifield, field, format_err_field(call.x, field, trace)) ifield <- ifield + 1 if(argn) printf("\n(%d) argument %d of the model call:%s\n", ifield, argn+1, format_err_field(argn.x, field, trace)) printf("\n") } format_err_field <- function(x, xname, trace=0) { if(is.try.err(x)) { errmsg <- sub(".* : *", "", x[1]) # strip prefix "Error in xxx : " errmsg <- gsub("\n *\\^", "", errmsg) # strip " ^" in some err msgs errmsg <- gsub("[\n\t ]+", " ", errmsg) # collapse newlines and multiple spaces errmsg <- gsub("^ *| *$", "", errmsg) # delete remaining leading and trailing space sprint(" %s", errmsg) } else if(is.errmsg(x)) sprint(" %s", x) else if(is.null(x)) sprint(" NULL") else if(NROW(x) < 3) sprint(" less than three rows") else if(!is.null(dim(x))) { print_summary(x, xname, trace=2) sprint(" is not usable (see above)") } else sprint(" class \"%s\" with value %s", class(x), try(paste.trunc(format(x))[1])) } # Get object$x or object$y from the model. # Return x (or y) or NULL or an error message. # # The approach taken in all helper routines for get.x.or.y # (such as get.object.x.or.y.field) is that we issue trace messages # here in the helper routine, and the caller silently checks # the returned value for good data. # # For a model with a formula, the standard path is to apply the # naked formula to the data using model.frame(). # Example with argument field="x": # # formula(object) resp~num + sqrt(num) + bool + ord:num + fac # naked formula resp~num + bool + ord + fac # data colnames resp bool ord fac str num nx int date # returned colnames num bool ord fac get.object.x.or.y.field <- function( # get object$x or object$y object, # the model field, # "x" or "y" trace, try.object.x.or.y=TRUE, # FALSE if object[[field]] should be ignored naked=TRUE) # TRUE for columns like "x3" not "ns(x3,4)" { trace2(trace, "\nget.object.%s:\n", field) x <- NULL xname <- sprint("object$%s", field) # for tracing if(!try.object.x.or.y) # e.g. we must ignore object$x for mda::mars models trace2(trace, "ignoring %s for this %s object\n", xname, class.as.char(object)) else { # note we use object[["x"]] rather than object$x to prevent partial # matching (but the error messages use object$x for readability) x <- object[[field]] if(is.good.data(x, xname, trace)) x <- cleanup.x.or.y(object, x, field, trace, check.naked=naked && field != "y") else if(!is.null(x) && !is.good.data(x, check.colnames=FALSE)) { # Issue a warning because predict.lm will probably crash # later when it internally accceses object$x. # We call is.good.data(check.colnames=FALSE) above to check if the # prior call to is.good.data() failed merely because of a colname # issue (if it's just a colname issue then don't issue warning). warnf("object$%s may be corrupt", field) } } x # return x or NULL or an error message } # Get getCall(object)$x (or similar) from the model's call field. # Return x (or similar) or NULL or an error message. get.data.from.object.call.field <- function(object, field, trace, check.is.good.data=TRUE) { trace2(trace, "\nget.data.from.object.call.field:\n") x <- NULL xname <- sprint("getCall(object)$%s", field) call <- getCall(object) if(is.null(call)) trace2(trace, "getCall(object) is NULL so cannot get %s\n", xname) else if(!is.call(call)) trace2(trace, "getCall(object) is not actually a call so cannot get %s", xname) else { x <- try.eval(call[[field]], model.env(object), trace=trace, expr.name=xname) if(is.errmsg(x)) trace2(trace, "%s\n", x) else if(check.is.good.data) # invoke is.good.data purely for issuing trace messages is.good.data(x, xname, trace) } x } # Get the n'th arg in the call to the model function. # # This is for those model functions whose second argument is the # response (what we call "y"), although that argument's name is # not "y". For example, argn=2 will select the "grouping" arg in # qda(x=lcush[,2:3], grouping=lcush[,1]). # # Returns list(argn.x, argn) # where argn.x is the evaluated n'th argument or NULL or an error message. # and argn will be set 0 if routine processing says we should ignore argn. get.argn.from.call <- function(argn, object, field, trace, nrows.argn) { x <- NULL if(argn) { temp <- get.argn.from.call.aux(argn, object, field, trace, nrows.argn) x <- temp$x argn <- temp$argn if(is.errmsg(x)) trace2(trace, "%s\n", x) else # invoke is.good.data purely for issuing trace messages is.good.data(x, sprint("argument %d of the model call", argn), trace) } list(x=x, argn=argn) } # auxilary function for get.argn.from.call get.argn.from.call.aux <- function(argn, object, field, trace, nrows.argn) { ret <- function(x, argn) { list(x=x, argn=argn) } #--- get.argn.from.call.x starts here stopifnot(argn > 0) call <- getCall(object) if(is.null(call)) return(ret("getCall(object) is NULL so cannot use argn", argn)) if(!is.call(call)) return(ret("getCall(object) is not actually a call so cannot use argn", argn)) if(length(call) <= argn) return(ret(sprint( "cannot use argn %d because getCall(object) does not have %d arguments", argn, argn), argn)) names.call <- names(call) # some names may be "" trace2(trace, "names(call) is %s\n", quotify(names.call)) # If argn is field (i.e. "x" or "y"), don't process it here because # we process call$x and call$y elsewhere (in get.data.from.object.call.field). # This is a common case, so we clear argn for uncluttered message # later in errmsg.for.get.x.or.y. # If the arg name is "" in getCall(object) this won't work, not serious. if(identical(names.call[argn+1], field)) return(ret(sprint( "the name of argument %d is \"%s\" so we will not process it with argn", argn, field), argn=0)) # If an argument of the call is "formula" then return, because # any arg named "x" or "y" is unlikely to be model data. # This is a a common case, so clear argn. if(pmatch("formula", names.call[2], 0)) return(ret(sprint( "ignoring argn %g because there is a formula argument", argn), argn=0)) x <- try.eval(call[[argn+1]], model.env(object), trace=trace, sprint("argument %d of the model call", argn)) if(is.data.frame(x)) x <- x[[1]] if(!(is.numeric(x[1]) || is.logical(x[1]) || is.factor(x[1]))) return(ret(sprint( "cannot use argn %d because it is not numeric, logical, or a factor", argn), argn)) if(is.null(nrows.argn)) # should never happen stop0("cannot use argn because the expected number of rows is unspecified") if(NROW(x) != nrows.argn) return(ret(sprint( "cannot use argn %g because it has %g rows but expected %g rows", argn, NROW(x), nrows.argn), argn)) list(x=x, argn=argn) } # If object has a formula, use that formula to get x or y (field is "x" or "y"). # Returns list(x, do.subset, form.as.char, source) where x may be an err msg and source # is a string describing where we got the data from (only used if no err msg). get.x.or.y.from.model.frame <- function(object, field, trace, naked, na.action="auto", newdata=NULL) { ret <- function(...) # ... is an err msg in printf form { errmsg <- sprint(...) trace2(trace, "%s\n", errmsg) list(x=errmsg, do.subset=FALSE, formula=NULL, source="model frame") } #--- get.x.or.y.from.model.frame starts here stopifnot(field == "x" || field == "y") trace2(trace, "\nget.%s.from.model.frame:\n", field) mf <- get.model.frame(object, field, trace, naked, na.action, newdata) if(!is.good.data(mf$x)) return(mf) model.frame <- mf$x if(field == "x") { # Check if any vars have $ in their name, this confuses predict() later. # They cause "Error in model.frame.default: variable lengths differ" # or "newdata had 50 rows but variables found have 330 rows" ibad <- grep("[._[:alnum:]]\\$", colnames(model.frame)) if(any(ibad)) { warnf("%s: \"$\" in colnames(model.frame) is not supported by plotmo, %s", colnames(model.frame)[ibad[1]], "will try to get the data elsewhere") return(ret("\"$\" in colnames(model.frame)")) } } # got the model.frame, now get the column index(s) of the response in the model.frame iresponse.col <- get.iresponse.col(object, model.frame, mf$isFormula, trace=if(field=="y") trace else 0) # reduce number of msgs if(field == "x") { # drop the response column(s) x <- model.frame[, -iresponse.col, drop=FALSE] if(!is.good.data(x, sprint("x=model.frame[,-%s]", paste.c(iresponse.col)), trace)) return(ret("invalid model.frame[,-iresponse]")) } else { # field == "y" # select the response column(s) # we don't use model.response() here because that drops the column name x <- model.frame[, iresponse.col, drop=FALSE] if(!is.good.data(x, sprint("y=model.frame[,%s]", paste.c(iresponse.col)), trace)) return(ret("invalid model.frame[,iresponse]")) } list(x=x, do.subset=mf$do.subset, formula=mf$formula, source=mf$source) } # The following is derived from stats::model.frame.default but tries to # also handle models that didn't save the terms etc. in a standard way. # It never uses parent.frame (as some model.frame methods do). # # We will use the given na.action. But if na.action="auto" then get # na.action from the model itself, and do a little special handling. # # Returns list(x, do.subste, formula, source, isFormula) # where x may be an err msg # source s a string describing where we got the data from (only used if no err msg) get.model.frame <- function(object, field, trace, naked, na.action="auto", newdata=NULL) { ret <- function(x, do.subset=FALSE, formula=NULL, source="model frame", isFormula=FALSE) { list(x=x, do.subset=do.subset, formula=formula, source=source, isFormula=isFormula) } #--- get.model.frame starts here # get.model.formula returns a Formula or formula with an environment, or an error string modform <- get.model.formula(object, trace, naked) formula <- modform$formula if(is.errmsg(formula)) return(ret(formula)) # return errmsg isFormula <- inherits(formula, "Formula") # Formula vs formula trace2(trace, "formula is valid, now looking for data for the model.frame\n") if(!is.null(newdata)) { if(!is.good.data(newdata, "newdata", trace)) return(ret("bad newdata")) # return errmsg data <- newdata data.source <- "newdata" } else { # use object$model if possible (e.g. lm) # TODO the following code really belongs in get.data.for.model.frame? x <- object[["model"]] if(is.good.data(x, "object$model", trace)) { # Drop column named "(weights)" created by lm() if called with weights # (must drop else x will be rejected because non-naked colname). x <- x[, which(colnames(x) != "(weights)"), drop=FALSE] if(trace >= 3) print_summary(x, "model.frame", trace) # Note that we call check.naked even when the naked=FALSE. # Not essential, but gives more consistency so we select the same object$x, # getCall(object), or etc. regardless of whether naked is set or clear. if(is.null(check.naked(x, "object$model", trace))) # good object$model? return(ret(x, FALSE, formula, "object$model", isFormula)) } temp <- get.data.for.model.frame(object, trace) data <- temp$data data.source <- temp$source if(!is.good.data(data)) { # data is not usable (could be NULL) # following is for when no data argument when model was built data <- model.env(object) data.source <- "model.env(object)" } } if(is.character(na.action) && length(na.action) == 1 && na.action == "auto") { na.action <- na.action(object) class.na.action <- class(na.action) # following is for rpart's and ctree's (special but useful) NA handling if(is.null(na.action)) na.action <- if(inherits(object, "rpart") || inherits(object, "party_plotmo")) "na.pass" else "na.fail" else if(length(class.na.action) == 2 && class.na.action[1] == "na.rpart") na.action <- paste0("na.", class(na.action)[2]) else if(class.na.action[1] %in% c("exclude", "fail", "omit", "pass")) na.action <- paste0("na.", class(na.action)[1]) trace2(trace, "na.action(object) is %s\n", as.char(na.action)) } if(!is.function(na.action) && !is.character(na.action)) { errmsg <- sprint("bad na.action: %s", as.char(na.action)) trace2(trace, "%s\n", errmsg) return(ret(errmsg)) } if(trace >= 3) { printf("model.env is %s\n", environment.as.char(model.env(object))) print_summary(data, "data", trace) } data.source <- if(is.environment(data)) environment.as.char(data) else if(is.null(data)) "NULL" else data.source mfcall.as.char <- sprint("model.frame(%s, data=%s, na.action=%s)", paste.trunc(modform$form.as.char, maxlen=40), data.source, trunc.deparse(na.action)) trace2(trace, "stats::%s\n", mfcall.as.char) x <- try(do.call(stats::model.frame, # calls model.frame.default args=list(formula=formula, data=data, na.action=na.action)), silent=trace < 2) if(trace >= 3) print_summary(x, "model.frame returned", trace) ret(x, if(is.null(newdata)) TRUE else FALSE, formula, mfcall.as.char, isFormula) } get.data.for.model.frame <- function(object, trace) { ret <- function(errmsg, data=NULL, source="model frame") { if(!is.null(errmsg)) trace2(trace, "%s\n", errmsg) list(data=data, source=source) } # try object$data e.g. earth models with formula and keepxy=T # the inherits check is becauses party objects for e.g. "medv ~ log(lstat) + rm^2" # save "log(lstat)" not "lstat" in object data, that confuses model.frame.default if(!inherits(object, "party_plotmo")) { data <- object[["data"]] if(is.good.data(data, "object$data", trace)) return(ret(NULL, data, "object$data")) } # look for the data in getCall(object) call <- object[["call"]] if(is.null(call)) return(ret("getCall(object) is NULL so cannot get the data from the call")) if(!is.call(call)) return(ret("getCall(object) is not actually a call so cannot get the data from the call")) data <- NULL argname <- "NULL" # try getCall(object)$data idata <- match(c("data"), names(call), 0)[1] if(idata > 0) { trace2(trace, "argument %g of the call is 'data'\n", idata-1) argname <- "call$data" # Mar 2019: TODO this doesn't work (if model was built internally to another # function?) because it tries to get data from .RGlobalEnv (which in that # environment is a function "data"). Perhaps failure is because terms(mf) seems # to generate a terms field ".GlobalEnv" regardless of where the mf was evaluated. # Workaround for earth models: use keepxy=TRUE (to avoid this code) data <- try(eval.trace(call[[idata]], model.env(object), trace=trace, expr.name=argname), silent=FALSE) # so user can see what went wrong is.good.data(data, argname, trace) # purely for tracing } else { # no getCall(object)$data, search for an arg that looks like good data trace2(trace, "getCall(object) has no arg named 'data', will search for an arg that looks like data\n") if(length(call) >= 3) { # start at 3 to ignore fname and first arg (the formula) for(icall in 3:length(call)) { arg <- call[[icall]] if(class(arg)[1] == "name") { # paranoia, will always be true? argname <- sprint("call$%s", quotify(as.character(arg))) data <- eval.trace(arg, model.env(object), trace=trace, expr.name=argname) if(is.good.data(data, argname, trace=trace)) { trace2(trace, "%s appears to be the model data\n", argname) idata <- icall break } else { trace2(trace, "%s is not the model data\n", argname) data <- NULL } } } } } if(is.good.data(data, argname)) { # following needed for e.g. nnet(O3~., data=scale(ozone1), size=2) # Else get Error in model.frame.default: 'data' must be a data.frame. if(!is.data.frame(data)) { data <- try(my.data.frame(data, trace)) # invoke is.good.data purely for issuing trace messages is.good.data(data, sprint( "%s converted from \"%s\" to \"data.frame\"", argname, class(data)[1]), trace) } } ret(NULL, data, argname) } # get the column index(s) of the response in the model.frame, return 1 if can't (best guess is 1) get.iresponse.col <- function(object, model.frame, isFormula, trace) { assuming <- sprint("assuming \"%s\" in the model.frame is the response, because", gen.colnames(model.frame, prefix="model.frame", trace=trace)[1]) iresponse.col <- 1 terms <- try(terms(object), silent=TRUE) if(is.null(terms)) { # e.g. bagEarth.formula and nn trace1(trace, "%s terms(object) is NULL\n", assuming) return(1) # assume iresponse.col is 1 } if(is.try.err(terms)) { trace1(trace, "%s terms(object) did not return the terms\n", assuming) return(1) } # object seems to have a valid terms field iresponse.col <- attr(terms, "response") if(is.null(iresponse.col) || !is.numeric(iresponse.col) || length(iresponse.col) != 1) { trace1(trace, "%s attr(terms, \"response\") is invalid\n", assuming) return(1) } if(iresponse.col != 0) { if(isFormula) { trace1(trace, "%s object used Formula (not formula) yet attr(terms, \"response\") is nonzero\n", assuming) return(1) } iresponse.col <- try(check.index(iresponse.col, "attr(terms, \"response\")", model.frame, is.col.index=TRUE, allow.negatives=FALSE)) } else { # iresponse.col == 0 if(!isFormula) { trace1(trace, "%s attr(terms, \"response\") is 0\n", assuming) return(1) } # isFormula iresponse.col <- attr(terms, "Response") if(is.null(iresponse.col)) { # will happen for any model that uses Formula (not formula), except earth trace1(trace, "%s the model was built with Formula (not formula)\n", assuming) return(1) } if(is.null(iresponse.col) || !is.numeric(iresponse.col)) { trace1(trace, "%s attr(terms, \"Response\") is invalid\n", assuming) return(1) } iresponse.col <- try(check.index(iresponse.col, "attr(terms, \"Response\")", model.frame, is.col.index=TRUE, allow.negatives=FALSE)) } if(is.try.err(iresponse.col)) { trace1(trace, "%s calculated index was invalid\n", assuming) iresponse.col <- 1 } iresponse.col } isa.formula <- function(x) { (typeof(x) == "language" && as.list(x)[[1]] == "~") || (is.character(x) && length(x) == 1 && grepany("~", x)) } get.index.of.formula.arg.in.call <- function(call, trace) { iform <- match(c("formula"), names(call), 0) if(iform) return(iform) # no arg named "formula" in call, so look for a formula elsewhere in call # TODO for which model was this code added? I think it's needed if formula arg is unnamed? call <- as.list(call) # start at 2 to skip call[1] which is the function name for(iform in 2:length(call)) { if(isa.formula(call[[iform]])) { # warning0("the formula in the model call is not named 'formula'") trace2(trace, "argument %d in getCall(object) is a formula\n", iform) return(iform) # note return } } 0 # no formula } # return a Formula or formula with an environment, or an error string get.model.formula <- function(object, trace, naked) { ret <- function(...) # ... is an err msg in printf form { errmsg <- sprint(...) trace2(trace, "%s\n", errmsg) list(formula=errmsg, form.as.char="formula") } #--- get.model.formula starts here # try getting the formula from the terms field (object used formula) terms <- try(terms(object), silent=TRUE) if(is.null(terms)) trace2(trace, "terms(object) is NULL, will look for the formula elsewhere\n") else if(is.try.err(terms)) trace2(trace, "terms(object) did not return the terms, will look for the formula elsewhere\n") else { # object has a valid terms field # TODO Sep 2020 ask Formula package people to extend # (currently only earth supports attr(terms, "Formula") and "Response" form <- attr(terms, "Formula") isFormula <- !is.null(form) # "Formula" vs "formula" if(isFormula) { trace1(trace, "object created with Formula (not formula): using attr(terms, \"Formula\")\n") form <- formula_as_char_with_check(form, "attr(terms, \"Formula\")", trace) } else { form <- try(formula(terms), silent=TRUE) form <- formula_as_char_with_check(form, "formula(object)", trace) } if(!is.null(form$form.as.char)) return(process.formula(object, form$form.as.char, isFormula, trace, naked)) # if there was a $ in the form.as.char there is no point in looking at the call # formula, so to avoid issuing the same warning twice, we return # immediately here if(grepl("\"$\"", form$errmsg, fixed=TRUE)) return(ret(form$errmsg)) } # try getting the formula from getCall(object) call <- object[["call"]] if(is.null(call)) return(ret("getCall(object) is NULL so cannot get the formula from the call")) if(!is.call(call)) return(ret("getCall(object) is not actually a call so cannot get the formula from the call")) iform <- get.index.of.formula.arg.in.call(call, trace) if(iform == 0) # no formula? return(ret("no formula in getCall(object)")) # nasty name change, else model.frame.default: invalid type (language) # TODO clean this up, this won't work because it doesn't change the calling obj # names.call <- names(call) # names.call[iform] <- "formula" # names(call) <- names.call # note <<- not <- form.name <- sprint("model call argument %d", iform-1) form <- eval(call[[iform]], model.env(object)) form <- formula_as_char_with_check(form, form.name, trace) if(is.null(form$form.as.char)) return(ret(form$errmsg)) # TODO More classes could be added to the following assignment to isFormula # (and remember we can only get here if object doesn't have a terms field, # and I believe the objects below do in fact have a terms field) isFormula <- inherits(object, c("pre")) process.formula(object, form$form.as.char, isFormula=isFormula, trace, naked) } # convert the formula to character, and also check it formula_as_char_with_check <- function(form, form.name, trace) { ret.null <- function(...) # ... is an err msg in printf form { errmsg <- sprint(...) trace2(trace, "%s\n", errmsg) list(form.as.char=NULL, errmsg=errmsg) } if(is.try.err(form)) return(ret.null("%s did not return a formula", form.name)) if(is.null(form)) return(ret.null("%s is NULL", form.name)) if(class(form)[1] != "formula" && !class(form)[1] == "Formula" && !(is.character(form) && length(form) == 1)) return(ret.null("%s is not a formula or Formula (its class is \"%s\")", form.name, class(form)[1])) form.as.char <- paste.collapse(format(form)) trace2(trace, "%s is %s\n", form.name, paste.trunc(form.as.char)) if(!grepl("[^ \t]+.*~", form.as.char)) return(ret.null("%s has no response", form.name)) # Check if any vars have $ in their name, this confuses predict() later. # TODO Following comments are no longer accurate? # We do this check in get.x.or.y.from.model.frame but pre-emptively also here # (where we have the formula) for a slightly more informative error message. # (The other message kicks in if we get the model.frame from object$model.) rhs <- gsub(".*~ *", "", form.as.char) if(grepany("[._[:alnum:]]\\$", rhs)) { # check for "ident$" warnf("\"$\" in the formula is not supported by plotmo, %s\n formula: %s", "will try to get the data elsewhere", rhs) return(ret.null("%s: \"$\" in formula is not allowed", form.name)) } list(form.as.char=form.as.char, errmsg=NULL) } # Return a formula with an environment. Also process naked. # TODO this includes Height in Volume~Girth-Height, it shouldn't process.formula <- function(object, form.as.char, isFormula, trace, naked) { stopifnot(is.character(form.as.char)) stopifnot(length(form.as.char) == 1) if(naked) form.as.char <- naken.formula.string(form.as.char, trace) form <- try(formula(form.as.char, env=model.env(object)), silent=TRUE) if(isFormula && !is.try.err(form)) form <- try(Formula::Formula(form)) if(is.try.err(form)) { # prepend "formula(%s) failed" for a clearer msg in format_err_field later form <- sprint("%s(%s) failed%s", if(isFormula) "Formula" else "formula", quotify(form.as.char), # only append err msg if tracing because err msgs can be obscure if(trace >= 1) sprint("(%s)", cleantry(form)) else "") trace2(trace, "%s\n", form) form <- sprint("Error : %s", form) } list(formula=form, form.as.char=form.as.char) } # Given a formula (as string), return a string with the "naked" predictors. # This is used for getting the data to pass to predict. # # Example: log(y) ~ x9+ns(x2,4) + s(x3,x4,df=4) + x5:sqrt(x6) # becomes: log(y) ~ x9 + x2 + x3 + x4 + x5 + x6 # which will later result in a model.matrix with columns x9 x2 x3 x4 x5 x6. # # Note that we don't naken the response (so for # example in the above log(y) remains unchanged). # # This routine is not infallible but works for the commonly used formulas. # It's a hack that relies on regular expressions. naken.formula.string <- function(form.as.char, trace) { stopifnot(is.character(form.as.char)) form.as.char <- paste.collapse(form.as.char) old.form.as.char <- form.as.char naked <- gsub(".*~", "", form.as.char) # extract everything after ~ naked <- naken.collapse(naked, warn.if.minus=TRUE) if(grepl("~", form.as.char)) { response <- gsub("~.*", "", form.as.char) # extract up to the ~ response <- gsub("^ +| +$", "", response) # trim leading and trailing spaces if(nchar(response)) response <- paste0(response, " ~") naked <- paste.collapse(response, naked) } trace2(trace, if(strip.space(naked) == strip.space(old.form.as.char)) "naked formula is the same%.0s\n" # e.g. O3~vh+wind else "naked formula is %s\n", naked) naked } is.naked <- function(colnames) # returns a logical vector { naked <- logical(length(colnames)) for(i in seq_len(length(colnames))) { colname <- strip.space(colnames[i]) naked[i] <- colname == naken.collapse(colname) } naked } # Return an err msg if colnames(x) is not "naked". # Return NULL if everything is ok. # # Example: in lm(Volume~poly(Height, degree=3), data=trees, x=T), # object$x, object$data, and object$model have # colnames like "poly(Height, degree = 3)1" # where plotmo (actually model.frame.default) gives "Error: object 'x1' not found" # unless we preempt that obscure error message here. check.naked <- function(x, xname, trace) { errmsg <- NULL colnames <- colnames(x) # column name "(Intercept)" must be considered naked colnames <- sub("(Intercept)", "Intercept", colnames, fixed=TRUE) is.naked <- is.naked(colnames) if(any(!is.naked)) { # e.g. lm(formula=log(doy)~vh, ...) errmsg <- sprint( "%s cannot be used because it has%s non-naked column name%s %s", xname, if(sum(!is.naked) > 1) "" else " a", if(sum(!is.naked) > 1) "s" else "", quotify.trunc(colnames[!is.naked])) trace2(trace, "%s\n", errmsg) } errmsg } # Returns x or an error message (currrently an error message # is returned only if naked=TRUE but colnames are not naked). cleanup.x.or.y <- function(object, x, field, trace, check.naked) { x <- handle.nonvector.vars(object, x, field, trace) # remove column "(Intercept)" e.g. object$x for lm(y~x1+x2, x=TRUE) if(!is.na(i <- match("(Intercept)", colnames(x)))) { trace2(trace, "dropped \"(Intercept)\" column from %s\n", field) x <- x[,-i, drop=FALSE] } if(check.naked) { errmsg <- check.naked(x, field, trace) if(!is.null(errmsg)) return(errmsg) } x } # This tries to clean up columns of x that are themselves matrices or data.frames. # # Example (where the actual values in the x and y are not important): # x <- matrix(c(1,3,2,4,5,6,7,8,9,10, # 2,3,4,5,6,7,8,9,8,9), ncol=2) # colnames(x) <- c("c1", "c2") # y <- 3:12 # a <- lm(y~x) # seems natural, but lm doesn't handle it as we might expect # Cannot get predict to work with newdata on above lm model # Causes for example 'newdata' had 8 rows but variables found have 10 rows # # Another example: # library(ElemStatLearn); x <- mixture.example$x; # g <- mixture.example$y; a <- lm(g ~ x) # # This routine also prevents a misleading error msg later in plot_degree1 # (illegal index, missing column in x) caused by the following code: # data(gasoline, package='pls') # plotmo(earth(octane ~ NIR, data=gasoline)) # where NIR has class "AsIs" and is a matrix. # There appears to be no easy fix for this (July 2011). handle.nonvector.vars <- function(object, x, field, trace) { if(!is.data.frame(x)) return(x) ndims.of.each.var <- sapply(x, function(x) NCOL(x)) if(all(ndims.of.each.var == 1)) { # we are ok: NCOL is 1 for all variables (even though some # may not be vectors i.e. they could be single column mats) return(x) } format <- paste0("%s variable on the %s side of the formula is a matrix or data.frame\n", " plotmo often cannot process such variables") msg <- sprint(format, if(ncol(x) == 1) "the" else "a", if(field == "x") "right" else "left") if(field == "x") { # We issue the warning only if this is the rhs, because we seem to be able # to recover when the lhs is a non vector. Thus we correctly don't issue # warnings for valid models like earth(cbind(O3,doy)~., data=ozone1) and # glm(cbind(damage, 6-damage)~temp, family=binomial, data=orings). warning0(msg) } else if(trace >= 2) { printf("%s\n", msg) printf("the number of dimensions of each variable in %s is %s and ", field, paste.trunc(ndims.of.each.var)) # details is 1 not 2 below else huge output print_summary(x, sprint("%s is ", field), trace, details=-1) } # Attempt to fix the problem by replacing x with x[[1]]. However # for the rhs this only sometimes works --- there may be downstream # problems, typically in predict (because the column names are wrong?). if(ndims.of.each.var[1] > 1) { # first variable is not a vector trace2(trace, "replacing %s with %s[[1]]%s\n", field, field, if(length(ndims.of.each.var) == 1) "" else ", ignoring remaining columns") org.colnames <- colnames(x) x <- x[[1]] # add column names (helps keep track later) if(is.null(colnames(x))) { safe.org.colnames <- if(is.null(org.colnames)) # can never happen, but best to be sure field else org.colnames if(NCOL(x) > 1) colnames(x) <- paste0(safe.org.colnames[1], "[,", 1:NCOL(x), "]") else # e.g. glm(formula=response~temp, family="binomial", data=...) colnames(x) <- safe.org.colnames[1] trace2(trace, "%s colnames were %s and now %s\n", field, if(is.null(org.colnames)) "NULL" else quotify.trunc(org.colnames), quotify.trunc(colnames(x))) } } x } # Detect if the model is a glm model, and if so possibly convert the # response. We do this in the same way as glm() does internally: # # o A factor response get converted to indicator column of # ones and zeros (first level vs the rest). # # o Two column binomial responses get converted to a single # column of fractions. # # Note that responses for earth models are handled independently # in plotmo.y.earth (two level factor to single numeric column, # three of more level factors to three or more indicator columns). convert.glm.response <- function(object, y, trace) { # check if y is is factor, or first column of y is a factor is.factor <- is.factor(y) || (length(dim(y) == 2) && ncol(y) == 1 && is.factor(y[,1])) if(is.factor) y <- convert.glm.response.factor(object, y, trace) else if(NCOL(y) == 2) # possibly a two column binomial model y <- possibly.convert.glm.two.column.response(object, y, trace) y } is.nomial <- function(object) { is.nomial.string <- function(family) { family[1] == "binomial" || family[1] == "quasibinomial" || family[1] == "multinomial" } if(!is.list(object)) return(FALSE) family <- object$family if(is.character(family)) # glmnet models return(is.nomial.string(family)) fam <- try(family(object), silent=TRUE) if(inherits(fam, "family")) { # lm, glm, etc models family <- fam$family if(is.character(family)) return(is.nomial.string(family)) } FALSE } convert.glm.response.factor <- function(object, y, trace) { if(!is.nomial(object)) { # e.g. rpart(formula=Kyphosis~., data=kyphosis) trace2(trace, "the response is a factor but could not get the family of the %s model\n", class.as.char(object)) } else { # e.g. glm(formula=sex~., family=binomial, data=etitanic) if(!is.null(dim(y))) { # data.frame or matrix levels <- levels(y[,1]) y[,1] <- y[,1] != levels[1] } else { # vector levels <- levels(y) y <- y != levels[1] y <- data.frame(y) } # column naming helps us keep track that we did this manipulation of x colnames(y) <- if(length(levels) > 1) paste0("is", levels[2]) else paste0("not", levels[1]) trace2(trace, "generated indicator column \"%s\" from levels %s\n", colnames(y)[1], paste.trunc(levels)) } y } possibly.convert.glm.two.column.response <- function(object, y, trace) { if(is.nomial(object)) { # following are sanity checks # note also that here we treat a two column multinom model as a binom model stopifnot(NCOL(y) == 2) if(!is.numeric(y[,1]) || !is.numeric(y[,2])) warning0("non-numeric two column response for a binomial model") else if(any(y[,1] < 0) || any(y[,2] < 0)) warning0("negative values in the two column response ", "for a binomial model") # example 1 glm(formula=response~temp, family="binomial", data=orings) # example 2 glm(formula=cbind(damage,6-damage)~temp, family="bi...) org.colnames <- colnames(y) y <- bpairs.yfrac(y[,1:2], trace=(trace!=0)) y <- data.frame(y) # column naming helps us keep track that we did this manipulation of x if(!is.null(org.colnames)) { colnames(y) <- # gsub deletes things like "[,2]" paste0(gsub("\\[.*\\]", "", org.colnames[1]), ".yfrac") trace2(trace, "created column \"%s\" from two column binomial response\n", colnames(y)) } } y } get.and.check.subset <- function(x, object, trace) { is.valid <- function(subset) { !is.null(subset) && (is.numeric(subset) || is.logical(subset)) } #--- get.and.check.subset starts here subset <- object$subset if(is.valid(subset)) msg <- "object$subset" else { subset <- try(eval(getCall(object)$subset, model.env(object)), silent=TRUE) if(is.try.err(subset)) subset <- NULL else msg <- "getCall(object)$subset" } if(!is.valid(subset)) subset <- NULL else { # duplicates are allowed in subsets so user can specify a bootstrap sample check.index(subset, "subset", x, allow.dups=TRUE, allow.zeros=TRUE) if(trace >= 2) { cat0("got subset from ", msg, " length " , length(subset)) print_first_few_elements_of_vector(subset, trace) } } subset } plotmo/R/bx.R0000644000176200001440000000361613712116415012530 0ustar liggesusers# bx.R: plotres functions for accessing a model's basis matrix # TODO turn this into a method function plotmo_bx <- function(object, trace, msg, versus) { if(inherits(object, "mars") || inherits(object, "earth")) { if(inherits(object, "mars")) bx <- object[["x"]] else bx <- object[["bx"]] if(is.null(bx) || NCOL(bx) == 0) stopf("versus=\"b:\": no basis matrix for this %s object", class.as.char(object, quotify=TRUE)) else if(NCOL(bx) == 1) { # intercept only? bx <- bx icolumns <- 1 } else { bx <- bx[, -1, drop=FALSE] # drop the intercept if(is.null(colnames(bx))) # mars model? colnames(bx) <- paste0("bx", seq_len(NCOL(bx))) icolumns <- check.index(versus, "versus", seq_len(NCOL(bx)), colnames=colnames(bx)) } } else if(inherits(object, "Gam") || # package gam version 1.15 or higher # the additive.predictors check below is to ensure mda:gam (not mgcv:gam) # (applies only to package gam version less than 1.15) (inherits(object, "gam") && !is.null(object[["additive.predictors"]]))) { bx <- model.matrix(object) if(is.null(bx) || NCOL(bx) == 0) stopf("versus=\"b:\": model.matrix(object) for this %s object returned NULL", class.as.char(object, quotify=TRUE)) else if(NCOL(bx) == 1) { # intercept only? bx <- bx icolumns <- 1 } else { bx <- bx[, -1, drop=FALSE] # drop the intercept icolumns <- check.index(versus, "versus", seq_len(NCOL(bx)), colnames=colnames(bx)) } } else stopf("versus=\"b:\" is not supported for this %s object", class.as.char(object, quotify=TRUE)) list(bx=bx, icolumns=icolumns) } plotmo/R/check.index.R0000644000176200001440000001724213723040630014277 0ustar liggesusers# check.index.R # Check that an index vector specified by the user is ok to index an object. # We want to preclude confusing R messages or behaviour later. # An example is when max(index) > length(object) which quietly # returns NA and can cause confusing downstream behaviour. # This returns a vector suitable for indexing into object (will # be identical to index unless index is a character vector). # # If index is a character vector, then matching (regex if is.col.index != 2) # is used against the names in the object, and an integer vector is returned. check.index <- function(index, index.name, object, colnames = NULL, is.col.index = 0, # 0=row index, 1=col index, 2=exact non-regex col name if char allow.empty = FALSE, # if index is char will warn if necessary regardless of allow.empty allow.zeros = FALSE, allow.negatives = TRUE, allow.dups = FALSE, treat.NA.as.one = FALSE, is.degree.spec = FALSE) # special handling for degree1 and degree2 specs { index.name <- quotify.short(index.name, "index", quote="'") # check that the given index and object can be evaluated try <- try(eval(index)) if(is.try.err(try)) stop0("illegal ", index.name) try <- try(eval(object)) if(is.try.err(try)) stop0("illegal ", quotify.short(object, quote="'")) is.col.index <- check.integer.scalar(is.col.index, min=0, max=2) allow.empty <- check.boolean(allow.empty) allow.zeros <- check.boolean(allow.zeros) allow.negatives <- check.boolean(allow.negatives) allow.dups <- check.boolean(allow.dups) treat.NA.as.one <- check.boolean(treat.NA.as.one) if(is.null(index)) { if(!allow.empty) stop0(index.name, " is NULL and cannot be used as an index") return(NULL) } if(treat.NA.as.one && (length(index) == 1 && is.na(index)[1])) index <- 1 if(anyNA(index)) stop0("NA in ", index.name) if(NROW(index) != 1 && NCOL(index) != 1) stop0(index.name, " must be a vector not a matrix (", index.name, " has dimensions ", NROW(index), " x ", NCOL(index), ")") len <- get.len(object, is.col.index) if(is.character(index)) # currently only works for column names of object check.character.index(index, index.name, object, colnames, len, is.fixed=(is.col.index==2), allow.empty, is.degree.spec) else if(is.logical(index)) check.logical.index(index, index.name, len, allow.empty) else if(is.numeric(index)) check.numeric.index(index, index.name, len, allow.empty, allow.negatives, allow.dups, allow.zeros, treat.NA.as.one) else stop0(index.name, " must be an index vector (numeric, logical, or character)") } get.len <- function(object, is.col.index) { if(is.col.index) len <- NCOL(object) # index is for columns of object else if(is.null(dim(object))) len <- length(object) else len <- NROW(object) # index is for rows of object # NROW also works for lists stopifnot(length(len) == 1) stopifnot(len > 0) len } matchmult <- function(x, tab) # like match but return multiple matches if present { matches <- integer(0) for(i in seq_along(x)) { xi <- x[i] for(itab in 1:length(tab)) if(xi == tab[itab]) matches <- c(matches, itab) } matches } # This does regex matching of index and returns an integer vector # index arg must be character # if names arg is NULL, use colnames(object) check.character.index <- function(index, index.name, object, names, len, is.fixed, allow.empty, is.degree.spec) { stopifnot(is.character(index)) is.fixed <- check.boolean(is.fixed) # certain regular expressions match everything, even if names not avail if(!is.fixed && length(index) == 1 && index %in% c("", ".", ".*")) return(1:len) if(is.null(names)) names <- colnames(object) if(length(names) == 0 || !is.character(names)) stop0(index.name, " specifies names but the names are unavailable") matches <- integer(0) warning.names <- integer(0) # these regexs don't match any column names for(i in seq_along(index)) { name <- index[i] if(!is.fixed) # regex match igrep <- grep(name, names) else { # exact match if(nchar(name) == 0) warning0(unquote(index.name), "[", i, "] is an empty string \"\"") igrep <- which(name == names) } if(length(igrep)) matches <- c(matches, igrep) else warning.names <- c(warning.names, name) } if(is.degree.spec) { if(is.null(dim(object))) # vector, degree1 matches <- matchmult(matches, object) else if(length(dim(object)) == 2) # 2D matrix, degree2 matches <- c(matchmult(matches, object[,1]), matchmult(matches, object[,2])) else stop0("that kind of object is not yet supported for ", index.name) } new.index <- unique(matches[!is.na(matches)]) for(name in warning.names) warning0("\"", name, "\" in ", unquote(index.name), " does not ", if(is.fixed) "" else "regex-", "match any names\n", " Available names are ", paste.trunc(quotify(names))) new.index } check.logical.index <- function(index, index.name, len, allow.empty) { stopifnot(is.logical(index)) if(!allow.empty) { if(length(index) == 0) stop0("length(", unquote(index.name), ") == 0") if(length(index[index == TRUE]) == 0) stop0(index.name, " is all FALSE") } # note that a single FALSE or TRUE is ok regardless of length(object) if(length(index) > len && length(index) != 1) { stop0("logical index ", index.name, " is too long.\n", " Its length is ", length(index), " and the max allowed length is ", len) } index } check.numeric.index <- function(index, index.name, len, allow.empty, allow.negatives, allow.dups, allow.zeros, treat.NA.as.one) { stopifnot(is.numeric(index)) if(!allow.empty) { if(length(index) == 0) stop0(index.name, " is empty, (its length is 0)") else if(all(index == 0)) if(length(index) == 1) stop0(index.name, " is 0") else stop0(index.name, " is all zeros") } if(!is.integral(index)) stop0(index.name, " is not an integer") if(any(index < 0) && any(index > 0)) stop0("mixed negative and positive values in ", index.name) if(!allow.zeros && any(index == 0) && length(index) != 1) warning0("zero in ", index.name) if(!allow.negatives && any(index < 0)) stop0("negative value in ", index.name) if(!allow.dups && any(duplicated(index))) warning0("duplicates in ", index.name) if(any(abs(index) > len)) { if(length(index) == 1) prefix <- paste0(unquote(index.name), "=", index, " but ") else prefix <- paste0(index.name, " is out of range, ") if(len != 1) stop0(prefix, "allowed values are 1 to ", len) else if(treat.NA.as.one) stop0(prefix, "the only allowed value is 1 (or NA)") else stop0(prefix, "the only allowed value is 1") } index } plotmo/R/meta.R0000644000176200001440000004533714566065154013066 0ustar liggesusers# meta.R: plotmo function to get the "metadata" from the model plotmo_type <- function(object, trace, fname="plotmo", type, ...) { if(is.null(type)) # get default type for this object class? type <- plotmo.type(object, ..., TRACE=trace) else { stopifnot.string(type) if(pmatch(type, "terms", nomatch=0)) stop0("type=\"terms\" is not supported by ", fname) } type } plotmo_residtype <- function(object, trace, fname="plotmo", type, ..., TRACE) { if(is.null(type)) # get default type for this object class? type <- plotmo.residtype(object, ..., TRACE=TRACE) else stopifnot.string(type) type } # In plotmo and plotres there is some general data we need about the # model. For example, the response name. This routine provides that # data, which we call "metadata". # # Also, plotmo and plotres should work automatically, as much as possible, # without requiring the user to specify arguments. This routine # facilitates that. # # For example, it converts the default nresponse=NA to a sensible column # number in the response. It will issue an error message if it can't do # that. # # It also converts the default type=NULL into an appropriate # model-specific type for predict(). It can't always do that, and we will # only know for sure later when we call predict with the calculated type. # In this routine we call plotmo_predict with type=NULL to get all the # response columns. The dots are passed on to predict. # # If you don't need the response, set get.y=FALSE to reduce the amount of processing. plotmo_meta <- function(object, type, nresponse, trace, avoid.predict=FALSE, residtype=type, msg.if.predictions.not.numeric=NULL, ...) { type <- plotmo_type(object, trace, "plotmo", type, ...) residtype <- plotmo_residtype(object, trace, "plotmo", residtype, ...) assignInMyNamespace("trace.call.global", trace) # trace call to resids, etc if(avoid.predict) { trace2(trace, "\n----Metadata: plotmo_resids(object, type=\"%s\", nresponse=NULL)\n", type) plotmo_resids <- plotmo_resids(object, type, residtype, nresponse=NULL, trace, ...)$resids if(is.null(plotmo_resids)) { if(trace >= 1) printf("residuals() was unsuccessful, will use predict() instead\n") avoid.predict <- FALSE # fall back to using predict } else { # trace2(trace, # "got residuals using residuals(object, type=\"%s\", ...)\n", type) # use fitted rather than predict (TODO not right but ok for plotres) trace2(trace, "\n----Metadata: plotmo_fitted with nresponse=NULL\n") # nresponse=NULL so this returns multiple columns if a mult respe model plotmo_fitted <- plotmo_fitted(object, trace, nresponse=NULL, type, ...) yhat <- plotmo_fitted$fitted if(!inherits(object, "earth")) colnames(fitted) <- NULL # ensure get.resp.name.from.metadata doesn't use this } } if(!avoid.predict) { trace2(trace, "\n----Metadata: plotmo_predict with nresponse=NULL and newdata=NULL\n") # newdata=3 for efficiency plotmo_predict <- plotmo_predict(object, newdata=3, nresponse=NULL, type, expected.levs=NULL, trace, inverse.func=NULL, ...) yhat <- plotmo_predict$yhat if(!is.null(msg.if.predictions.not.numeric)) { if(!is.null(plotmo_predict$resp.levs)) stopf("%s when the predicted response is a factor", msg.if.predictions.not.numeric) if(plotmo_predict$resp.class[1] == "character") stopf("%s when the predicted values are strings", msg.if.predictions.not.numeric) } trace2(trace, "\n----Metadata: plotmo_fitted with nresponse=NULL\n") # nresponse=NULL so this returns multiple columns if a multiple response model plotmo_fitted <- plotmo_fitted(object, trace, nresponse=NULL, type, ...) } assignInMyNamespace("trace.call.global", 0) yfull <- NULL # plotmo_y with nresponse=NULL trace2(trace, "\n----Metadata: plotmo_y with nresponse=NULL\n") # nresponse=NULL so this returns multiple columns if a multi response model yfull <- plotmo_y(object, nresponse=NULL, trace, expected.len=nrow(plotmo_fitted$fitted))$y nresponse.org <- nresponse nresponse <- plotmo_nresponse(yhat, object, nresponse, trace, sprint("predict.%s", class.as.char(object)), type) stopifnot(!is.na(nresponse)) trace2(trace, "nresponse=%g%s ncol(fitted) %d ncol(predict) %d ncol(y) %s\n", nresponse, if(identical(nresponse, nresponse.org)) "" else sprint(" (was %s)", if(is.character(nresponse.org)) paste0("\"", nresponse.org, "\"") else paste(nresponse.org)), NCOL(plotmo_fitted$fitted), NCOL(predict), sprint("%d", NCOL(yfull))) y.as.numeric.mat <- NULL # y as single column numeric mat, only the nresponse column nresponse.y <- nresponse trace2(trace, "\n----Metadata: plotmo_y with nresponse=%g\n", nresponse) if(ncol(yfull) == 1 && nresponse.y > 1) { # e.g. lda(survived~., data=etitanic) with predict(..., type="post") nresponse.y <- 1 trace1(trace, "nresponse=%d but for plotmo_y using nresponse=1 because ncol(y) == 1\n", nresponse) } assignInMyNamespace("trace.call.global", trace) # trace how we get the response y.as.numeric.mat <- plotmo_y(object, nresponse.y, trace, nrow(plotmo_fitted$fitted))$y assignInMyNamespace("trace.call.global", 0) resp.name <- get.resp.name.from.metadata(nresponse, trace, yhat, plotmo_fitted$fitted, yfull, nresponse.y) resp.levs <- plotmo_resplevs(object, plotmo_fitted, yfull, trace) trace2(trace, "\n----Metadata: done\n\n") fitted <- plotmo_fitted$fitted list( yfull = yfull, # response as a data.frame, all columns y.as.numeric.mat = y.as.numeric.mat, # response as a single col numeric mat # only the nresponse column fitted = fitted, # fitted response as a data.frame (all columns) type = type, # type for predict() # always a string (converted from NULL if necesssary) residtype = residtype, # type for residuals() # always a string (converted from NULL if necesssary) nresponse = nresponse, # col index in the response (converted from NA if necessary) resp.name = resp.name, # our best guess for the response name (may be NULL) resp.levs = resp.levs) # levels of y before conversion to numeric (may be NULL) # necessary to convert predicted strings to factors } get.resp.name.from.metadata <- function(nresponse, trace, yhat, fitted, yfull, nresponse.y) { # the order we look for the response name below seems to work but is not cast in stone if(is.factor(yhat[,1])) { # this prevents us putting a misleading first level name in plot headings resp.name <- NULL trace2(trace, "response name is NULL because is.factor(yhat[,1])\n") } else if(!is.null(colnames(yhat)) && nresponse <= length(colnames(yhat))) { # e.g. earth model resp.name <- colnames(yhat)[nresponse] trace2(trace, "got response name \"%s\" from yhat\n", resp.name) } else if(!is.null(yfull) && !is.null(colnames(yfull))) { # e.g. lm model resp.name <- colnames(yfull)[nresponse.y] trace2(trace, "got response name \"%s\" from yfull\n", resp.name) } else if(nresponse < length(colnames(fitted))) { resp.name <- colnames(fitted)[nresponse] trace2(trace, "got response name \"%s\" from plotmo_fitted\n", resp.name) } else { resp.name <- NULL trace2(trace, "response name is NULL\n") } resp.name } # Init resp.levs (the factor levels of the original response, may be NULL). # The resp.levs is used if predict() returns strings (and therefore # we must convert to them to a factor with the correct levels). plotmo_resplevs <- function(object, plotmo_fitted, yfull, trace) { levels.yfull <- if(is.null(yfull)) NULL else if(length(dim(yfull)) == 2) levels(yfull[,1]) else levels(yfull[1]) if(!is.null(object[["levels"]])) { resp.levs <- object[["levels"]] # levels stored with earth trace2(trace, "got resp.levs from object$levels\n") } else if(!is.null(levels.yfull)) { resp.levs <- levels.yfull trace2(trace, "got resp.levs from yfull\n") } else if(!is.null(plotmo_fitted$resp.levs)) { resp.levs <- plotmo_fitted$resp.levs trace2(trace, "got resp.levs from plotmo_fitted$resp.levs\n") } else { resp.levs <- NULL trace2(trace, "resp.levs is NULL\n") } if(trace >= 2 && !is.null(resp.levs)) printf("response levels: %s\n", paste.trunc(resp.levs)) resp.levs } # This is used for processing "model response" variables such as the # return value of predict(), fitted(), and residuals(). # # # If nresponse=NULL, return a data.frame but with y otherwise unchanged. # # Else return a numeric 1 x n matrix (regardless of the original class of y). # If nresponse is an integer, return only the specified column. # If nresponse=NA, try to convert it to a column index, error if cannot # # If !is.null(nresponse) and y is character vector then convert it to a factor. # expected.levs is used to do this (and not for anything else). # # returns list(y, resp.levs, resp.class) process.y <- function(y, object, type, nresponse, expected.len, expected.levs, trace, fname) { if(is.null(y)) stop0(fname, " NULL") if(length(y) == 0) stop0(fname, " zero length") print_summary(y, sprint("%s returned", fname), trace) if(is.list(y) && !is.data.frame(y)) # data.frames are lists, hence must check both stop0(fname, " list, was expecting a vector, matrix, or data.frame\n", " list(", list.as.char(y), ")") returned.resp.levs <- if(length(dim(y)) == 2) levels(y[,1]) else levels(y[1]) resp.class <- class(y[1]) colnames <- NULL resp.name <- NA dimy <- dim(y) if(length(dimy) == 3 && dimy[3] == 1) # hack for glmnet multnet objects y <- y[,,1] if(is.null(nresponse)) y <- my.data.frame(y, trace, stringsAsFactors=FALSE) else { check.integer.scalar(nresponse, min=1, na.ok=TRUE, logical.ok=FALSE, char.ok=TRUE) nresponse <- plotmo_nresponse(y, object, nresponse, trace, fname, type) stopifnot(!is.na(nresponse), nresponse >= 1) if(nresponse > NCOL(y)) stopf("nresponse is %d but the number of columns is only %d", nresponse, NCOL(y)) resp.name <- colname(y, nresponse, fname) y <- get.specified.col.and.force.numeric(y, nresponse, resp.name, expected.levs, trace, fname) if(!is.na(nresponse) && nresponse > 1) print_summary(y, sprint("%s returned", fname), trace, sprint(" after selecting nresponse=%d", nresponse)) } any.nas <- anyNA(y) any.non.finites <- FALSE # we use apply below because is.finite doesn't work for dataframes any.non.finites <- !any.nas && any(apply(y, 2, function(x) is.numeric(x) && !all(is.finite(x)))) if(any.nas) { trace2(trace, "\n") warning0("NAs returned by ", fname) } if(any.non.finites) { trace2(trace, "\n") warning0("non-finite values returned by ", fname) } # Error message for the aftermath of: # "Warning: 'newdata' had 100 rows but variable(s) found have 30 rows" if(!is.null(expected.len) && expected.len != nrow(y)) stopf("%s returned the wrong length (got %d but expected %d)", fname[1], nrow(y), expected.len[1]) print_summary(y, sprint("%s after processing with nresponse=%s is ", fname, if(is.null(nresponse)) "NULL" else format(nresponse)), trace) list(y = y, # n x 1 numeric, column name is original y column name resp.levs = returned.resp.levs, resp.class = resp.class) } # always returns a one column numeric matrix get.specified.col.and.force.numeric <- function(y, nresponse, resp.name, expected.levs, trace, fname) { # nresponse=NA is not allowed at this point stopifnot(is.numeric(nresponse), length(nresponse) == 1, !is.na(nresponse)) if(length(dim(y)) == 2) y <- y[, nresponse] else stopifnot(nresponse == 1) if(is.factor(y[1])) { trace2(trace, "converted to numeric from factor with levels %s\n", quotify.trunc(levels(y))) # plotmo 3.1.5 (aug 2016): Use as.vector to drop attributes, # else all.equal fails when expected.levs has "ordered" attribute. all.equal <- isTRUE(all.equal(as.vector(expected.levs), levels(y[1]))) # TODO this may be a bogus warning if(!is.null(expected.levs) && !all.equal) warning0(fname, " returned a factor with levels ", quotify.trunc(levels(y[1])), " (expected levels ", quotify.trunc(expected.levs), ")") } else if(is.character(y[1])) { # convert strings to factor old.y <- y y <- if(is.null(expected.levs)) factor(y) else factor(y, levels=expected.levs) trace2(trace, "converted to numeric from strings using factor levels %s\n", quotify.trunc(expected.levs)) which <- (1:length(y))[is.na(y)] if(length(which)) { cat("\n") print_summary(old.y, fname, trace=2) cat("\n") printf("%s[%d] was %s and was converted to \"%s\"\n", fname, which[1], old.y[which[1]], if(is.na(y[which[1]])) "NA" else paste0("\"", y[which[1]], "\"")) cat("\n") stopf("could not convert strings returned by %s to a factor (see above)", fname) } } if(any(!is.double(y))) # convert logical or factor to double y <- as.vector(y, mode="numeric") y <- as.matrix(y) colnames(y) <- resp.name y } plotmo_nresponse <- function(y, object, nresponse, trace, fname, type="response") { check.integer.scalar(nresponse, min=1, na.ok=TRUE, logical.ok=FALSE, char.ok=TRUE) colnames <- safe.colnames(y) nresponse.org <- nresponse if(is.na(nresponse)) { nresponse <- plotmo.convert.na.nresponse(object, nresponse, y, type) if(!is.na(nresponse)) { if(trace > 0 && nresponse != 1) printf("set nresponse=%s\n", paste(nresponse)) } else { # nresponse is NA # fname returned multiple columns (see above) but nresponse is not specified cat("\n") print_summary(y, fname, trace=2) cat("\n") colnames <- NULL if(is.null(colnames) && !is.null(dim(y))) colnames <- colnames(y) icol <- min(2, NCOL(y)) if(is.null(colnames)) msg1 <- sprint("%s\n Example: nresponse=%d", "Use the nresponse argument to specify a column.", icol) else msg1 <- sprint( "%s\n Example: nresponse=%d\n Example: nresponse=%s", "Use the nresponse argument to specify a column.", icol, quotify(if(is.na(colnames(y)[icol])) colname(y, 1) else colname(y, icol))) printf( "%s returned multiple columns (see above) but nresponse is not specified\n %s\n\n", fname, msg1) warning0("Defaulting to nresponse=1, see above messages"); nresponse <- 1 } } else if(is.character(nresponse)) { # convert column name to column index stopifnot.string(nresponse) if(is.vector(y)) stop0("nresponse=\"", nresponse, "\" cannot be used because the predicted response is a vector (it has no columns)") if(is.factor(y)) stop0("nresponse=\"", nresponse, "\" cannot be used because the predicted response is a factor (it has no columns)") if(is.null(colnames)) stop0("nresponse=\"", nresponse, "\" cannot be used because the predicted response has no column names") # TODO investigate [1] e.g. for plotmo(a1h.update2, nresponse="numd") nresponse <- imatch.choices(nresponse, colnames, errmsg.has.index=TRUE)[1] } check.integer.scalar(nresponse, min=1, na.ok=TRUE, logical.ok=FALSE, char.ok=TRUE) # note that msg is inhibited for trace<0, see trace1 in plotmo_rinfo # TODO this causes a spurious trace message with cv.glmnet models with nresponse=2 # message is plotmo_y[500,1] with no column names. So I changed the if statement. # if(nresponse > NCOL(y) && trace >= 0) { if(nresponse > NCOL(y) && trace > 0) { cat("\n") print_summary(y, fname, trace=2) cat("\n") check.index(nresponse, "nresponse", y, is.col.index=1, allow.negatives=FALSE, treat.NA.as.one=TRUE) } if(trace >= 2 && (is.na(nresponse.org) || nresponse.org != nresponse)) cat0("converted nresponse=", if(is.character(nresponse.org)) paste0("\"", nresponse.org, "\"") else nresponse.org, " to nresponse=", nresponse, "\n") nresponse } plotmo.convert.na.nresponse <- function(object, nresponse, yhat, type="response", ...) { UseMethod("plotmo.convert.na.nresponse") } plotmo.convert.na.nresponse.default <- function(object, nresponse, yhat, type, ...) { stopifnot(is.na(nresponse)) if(NCOL(yhat) == 1) 1 else if(NCOL(yhat) == 2 && substr(type, 1, 1) == "p") 2 # probability (also works for posterior as in lda models) else NA } plotmo/R/fitted.R0000644000176200001440000000407613462175663013413 0ustar liggesusers# fitted.R: plotmo functions for getting the fitted data for an arbitrary model # Like fitted() but will get fitted response even if not already with object. # Returns an n x 1 matrix (unless nresponse=NULL then returns an n x q dataframe?). # The returned columns may not be named. # The type and dots args are used if the call to fitted(object) fails. plotmo_fitted <- function(object, trace, nresponse, type, ...) { if(!is.null(nresponse)) check.integer.scalar(nresponse, min=1, na.ok=TRUE, logical.ok=FALSE, char.ok=TRUE) fitted <- try(call.dots(stats::fitted, DROP="*", KEEP="PREFIX", # following prevents reprint of fitted msg if fail TRACE=if(trace <= 0) -1 else (trace >= 2 || trace.call.global), force.object=object, ...), silent=trace <= 1) if(!is.try.err(fitted) && !is.null(fitted)) { # if(trace.call.global >= 1 && trace < 2) # print_summary(fitted, "fitted is ", details=-1) temp <- process.y(fitted, object, type, nresponse, expected.len=NULL, expected.levs=NROW(fitted), trace, "fitted(object)") fitted <- temp$y } else { # fitted(object) failed if(trace >= 1) printf("fitted() was unsuccessful, will use predict() instead\n") type <- plotmo_type(object, trace, "plotmo", type, ...) # we have already printed call to predict so clear trace flag # (this is dependent on the sequence of calls in plotmo_meta) assignInMyNamespace("trace.call.global", 0) temp <- plotmo_predict(object, newdata=NULL, nresponse, type, expected.levs=NULL, trace=trace, inverse.func=NULL, ...) fitted <- temp$yhat trace2(trace, "got fitted values by calling predict (see above)\n") } if(!is.null(colnames(fitted))) colnames(fitted) <- sub(".*\\$", "", colnames(fitted)) # trees$Volume to Volume list(fitted = fitted, # n x 1 numeric unless nresponse=NULL resp.levs = temp$resp.levs) } plotmo/R/plot_glmnet.R0000644000176200001440000002773214563612461014457 0ustar liggesusers# plot_glmnet.R: # # This code is based on code in glmnet version 2.0-5 (march 2016). plot_glmnet <- function(x=stop("no 'x' argument"), xvar=c("rlambda", "lambda", "norm", "dev"), label=10, nresponse=NA, grid.col=NA, s=NA, ...) { check.classname(x, "x", c("glmnet", "multnet")) obj <- x beta <- get.beta(obj$beta, nresponse) ibeta <- nonzeroCoef(beta) # ibeta is a vector of coefficient indices if(length(ibeta) == 0) { plot(0:1, 0:1, col=0) # dummy plot legend("topleft", legend="all glmnet coefficients are zero", bty="n") return(invisible(NULL)) } # following was in original plot.glmnet code but seems unnecessary # if(length(ibeta) == 1) { # warning("1 or less nonzero coefficients; glmnet plot is not meaningful") # plot(0:1, 0:1, col=0) # legend("topleft", legend="only one coefficient is nonzero", bty="n") # return() # } beta <- as.matrix(beta[ibeta, , drop=FALSE]) xlim <- dota("xlim", ...) # get xlim from dots, NA if not in dots xvar <- match.arg1(xvar) switch(xvar, "norm"= { if(inherits(obj, "multnet") || inherits(obj, "mrelnet")) { # we don't (yet) precalc norm or support type.coef, so have to stop here stop0("xvar=\"norm\" is not supported by plot_gbm for ", "multiple responses (use plot.glmnet instead)") } x <- apply(abs(beta), 2, sum) if(!is.specified(xlim)) xlim <- c(min(x), max(x)) xlab <- "L1 Norm" approx.f <- 1 }, "lambda"= { x <- log(obj$lambda) if(!is.specified(xlim)) xlim <- c(min(x), max(x)) xlab <- "Log Lambda" approx.f <- 0 }, "rlambda"= { x <- log(obj$lambda) if(!is.specified(xlim)) xlim <- c(max(x), min(x)) # backwards xlab <- "Log Lambda" approx.f <- 0 }, "dev"= { x <- obj$dev.ratio if(!is.specified(xlim)) xlim <- c(min(x), max(x)) xlab <- "Fraction Deviance Explained" approx.f <- 1 }) xlim <- fix.lim(xlim) if(xvar != "rlambda") stopifnot(xlim[1] < xlim[2]) else if(xlim[2] >= xlim[1]) # backwards stop0("xlim[1] must be bigger than xlim[2] for xvar=\"rlambda\"") iname <- get.iname(beta, ibeta, label) # index of varnames on rhs of plot old.par <- par("mar", "mgp", "cex.axis", "cex.lab") on.exit(par(mar=old.par$mar, mgp=old.par$mgp, cex.axis=old.par$cex.axis, cex.lab=old.par$cex.lab)) mar4 <- old.par$mar[4] # right hand margin if(length(iname)) { cex.names <- min(1, max(.5, 2.5 / sqrt(length(iname)))) # seems ok # ensure right margin is big enough for the varnames # can't use strwidth because no plot yet, so just estimate mar4 <- max(old.par$mar[4] + 1, .75 * cex.names * par("cex") * max(nchar(names(iname)))) } # set mar[3] with space for top axis and maybe main, and mar[4] for rhs labels main <- dota("main", ...) # get main from dots, NA if not in dots nlines.needed.for.main <- if(is.specified(main)) nlines(main) + .5 else 0 par(mar=c(old.par$mar[1], old.par$mar[2], max(old.par$mar[3], nlines.needed.for.main + 2.6), mar4)) par(mgp=c(1.5, .4, 0)) # squash axis annotations par(cex.axis=.8) ylab <- "Coefficients" if(is.list(obj$beta)) # multiple response model? ylab <- paste0(ylab, ": Response ", rownames(obj$dfmat)[nresponse]) coef.col <- get.coef.col(..., beta=beta) # color of coef lines # discard lines with color NA or 0 keep <- which((coef.col != "NA") & (coef.col != "0")) iname <- iname[iname %in% keep] beta[-keep,] <- NA # Call graphics::matplot but drop args in dots that aren't graphics args # or formal args of graphics::matplot. # If argname below is prefixed with force. then ignore any such arg in dots. # Any argname below prefixed with def. can be overridden by a user arg in dots. # force.main="" because we later manually add a top axis and possibly main. call.plot(graphics::matplot, force.x=x, force.y=t(beta), force.main="", force.col=coef.col, def.xlim=xlim, def.xlab=xlab, def.ylab=ylab, def.lty=1, def.lwd=1, def.type="l", ...) abline(h=0, col="gray", lty=3) # zero axis line maybe.grid(x=x, beta=beta, grid.col=grid.col, coef.col=coef.col, ...) if(xvar == "rlambda") { # args are named below to prevent potential clash with argnames in dots annotate.rlambda(lambda=obj$lambda, x=x, beta=beta, s=s, grid.col=grid.col, coef.col=coef.col, ...) toplab <- "Lambda" } else { top.axis(obj, x, nresponse, approx.f) toplab <- "Degrees of Freedom" } mtext(toplab, side=3, line=1.5, cex=par("cex") * par("cex.lab")) if(is.specified(main)) mtext(main, side=3, line=3, , cex=par("cex")) # above top axis if(length(iname)) right.labs(beta, iname, cex.names, coef.col) invisible(NULL) } get.beta <- function(beta, nresponse) { if(is.list(beta)) { # multiple response model? check.integer.scalar(nresponse, min=1, max=length(beta), na.ok=TRUE, logical.ok=FALSE) if(is.na(nresponse)) stop0( "Use the nresponse argument to specify a response for this multiple response model.\n", " Example: nresponse=", length(beta)) check.index(nresponse, "nresponse", beta) beta <- beta[[nresponse]] } beta } get.coef.col <- function(..., beta) { # default colors are distinguishable yet harmonious (at least to my eye) # adjacent colors are as different as easily possible def.col <- c("black", "red", "gray50", "orangered3", "darkorange", "magenta2") col <- dota("col", DEF=def.col, ...) # get col from dots, def.col if not in dots # the colors must stay in the above order as we move down rhs of plot order <- order(beta[, ncol(beta)], decreasing=TRUE) coef.col <- vector(mode="character", nrow(beta)) coef.col[order] <- rep_len(col, nrow(beta)) coef.col } # named index of varnames to be printed on right of plot, NULL if none get.iname <- function(beta, ibeta, label) { iname <- NULL check.integer.scalar(label, min=0, logical.ok=TRUE, na.ok=TRUE) if(!is.na(label) && label) { # allow label=NA, treat as FALSE names <- if(is.null(rownames(beta))) paste(ibeta) else rownames(beta) names[!nzchar(names)] <- paste(ibeta)[!nzchar(names)] iname <- order(abs(beta[, ncol(beta)]), decreasing=TRUE) if(is.logical(label)) # label=TRUE is special meaning all iname <- iname[1:length(iname)] else if(length(iname) > label) iname <- iname[1:label] names(iname) <- abbreviate(names[iname], minlength=8) } iname # named index of varnames to be printed, NULL if none } maybe.grid <- function(x, beta, grid.col, coef.col, ...) { if(is.specified(grid.col[1])) { grid(col=grid.col[1], lty=1) # replot over the grid (using add=TRUE) call.plot(graphics::matplot, force.x=x, force.y=t(beta), force.add=TRUE, force.main="", force.col=coef.col, def.lty=1, def.lwd=1, def.type="l", ...) } } right.labs <- function(beta, iname, cex.names, coef.col) # varnames on right of plot { usr <- par("usr") text(x=usr[2] + .01 * (usr[2] - usr[1]), y=spread.labs(beta[iname, ncol(beta)], mindiff=1.2 * cex.names * strheight("X")), labels=names(iname), cex=cex.names, col=coef.col[iname], adj=0, xpd=NA) } top.axis <- function(obj, x, nresponse, approx.f) { at <- pretty(x) # use is.list(obj$beta) to determine if multiple response model df <- if(is.list(obj$beta)) obj$dfmat[nresponse,] else obj$df # compute df by interpolating to df at next smaller lambda # thanks to Yunyang Qian prettydf <- approx(x=x, y=df, xout=at, rule=2, method="constant", f=approx.f)$y axis(3, at=at, labels=prettydf) } # Draw the top axis of an rlambda plot. # Also draw a labeled vertical line at lambda=s, if s isn't NA. # Dot arguments prefixed with "s". can be used to set the annotation # attributes e.g. s.col=NA or s.col=0 for no vertical line. # This is achieved with call.plot(text.on.white, PREFIX="s.", ...) below. annotate.rlambda <- function(lambda, x, beta, s, grid.col, coef.col, ...) { check.numeric.scalar(s, na.ok=TRUE, null.ok=TRUE, logical.ok=FALSE) s.col <- dota("s.col", DEF=1, ...) # get s.col from dots, 1 if not in dots add.s.line <- !is.null(s) && !is.na(s) && is.specified(s.col) # top axis at <- pretty(x) labs <- signif(exp(at), digits=2) # hack: delete confusing rightmost lab (if any) with a value greater # than s but drawn to the right of the vertical line at s if(add.s.line && s <= labs[1]) labs[1] <- "" axis(3, at=at, labels=labs) if(add.s.line) # add vertical line showing s? add.s.line(lambda=lambda, x=x, beta=beta, s=s, grid.col=grid.col, coef.col=coef.col, s.col=s.col, ...) } add.s.line <- function(lambda, x, beta, s, grid.col, coef.col, s.col, ...) { line.col <- "gray" line.lty <- 1 if(is.specified(grid.col)) { line.col <- 1 line.lty <- 3 } log.s <- log(max(lambda[length(lambda)], s)) abline(v=log.s, col=line.col, lty=line.lty) # vertical line at s # replot over the vertical line (using add=TRUE) call.plot(graphics::matplot, force.x=x, force.y=t(beta), force.add=TRUE, force.main="", force.col=coef.col, def.lty=1, def.lwd=1, def.type="l", ...) # add s label on vertical line # to minimize overplotting, y coord of label is biggest gap between matplot lines usr <- par("usr") # xmin, xmax, ymin, ymax col.index <- which.min(abs(lambda-s)) # lambda column corresponding to s y <- sort(c(usr[3], beta[, col.index], usr[4])) # include plot edges, and sort which <- which.max(diff(y)) # call graphics::matplot() but drop args in dots that aren't graphics args # or argnames prefixed with "s." or formal args of text.on.white call.plot(text.on.white, PREFIX="s.", force.x=log.s, force.y=(y[which]+y[which+1]) / 2, force.label= # gsub below drops leading and trailing zeros for compactness if(s == 0) "s=0" else paste0("s=", gsub("^0|0$|\\.0*$", "", signif(s,2))), force.col=s.col, force.cex=.8, def.srt=90, def.xpd=NA, ...) } # Return NULL or an integer vector # Reproduced here (from glmnet version 2.0-16, nov 2018) # so don't have to import glmnet into plotmo. nonzeroCoef = function (beta, bystep = FALSE) { ### bystep = FALSE means which variables were ever nonzero ### bystep = TRUE means which variables are nonzero for each step nr=nrow(beta) if (nr == 1) {#degenerate case if (bystep) apply(beta, 2, function(x) if (abs(x) > 0) 1 else NULL) else { if (any(abs(beta) > 0)) 1 else NULL } } else { beta=abs(beta)>0 # this is sparse which=seq(nr) ones=rep(1,ncol(beta)) nz=as.vector((beta%*%ones)>0) which=which[nz] if (bystep) { if(length(which)>0){ beta=as.matrix(beta[which,,drop=FALSE]) nzel = function(x, which) if (any(x)) which[x] else NULL which=apply(beta, 2, nzel, which) if(!is.list(which))which=data.frame(which)# apply can return a matrix!! which } else{ dn=dimnames(beta)[[2]] which=vector("list",length(dn)) names(which)=dn which } } else which } } plotmo/R/dot.R0000644000176200001440000001724113440642312012702 0ustar liggesusers# dot.R: functions to access dot arguments # Stephen Milborrow Mar 2015 Durban # # TODO when match.call is fixed (R 3.2.1), remove the dots arg in all # these funcs i.e. use the parent's dots #----------------------------------------------------------------------------- # dota() returns the value of the arg in dots that matches ARGNAME. # Returns DEF if no match (default is NA). # Issues an error message if multiple dot arguments match ARGNAME. # # ARGNAME must specify the full argument name (not abbreviated). # ARGNAME can be a vector of argument names. Example: # dotarg(c("name1", "name2"), ...) # First we look for a dot arg matching the first name in the ARGNAME vector. # If that fails we look for a match against the second name. And so on # for further names in ARGNAME. If nothing matches, DEFAULT is returned. # EXACT can also be a vector, with elements corresponding to the elements # of ARGNAME. Example: # dotarg(c("name1", "name2"), ..., EXACT=c(FALSE, TRUE)) # # Common mistake: Using dotarg(xlab, ...) instead of dotarg("xlab", ...). # The former usually causes the error message: object 'xlab' not found. # # If EX is TRUE then the name in dots must match ARGNAME exactly. # If EX is FALSE match partial names in dots against ARGNAME following the # standard R argname matching rules ("Argument Matching" in the R Language # Definition). But here were are matching against only a single "formal" # argument name, instead of all formal argnames simultaneously. # # NEW is currently unused (but will be for processing deprecated args). # "NEW" is used instead of say "DEP" (for deprecated) so it is easily # distinguishable from "DEF". # # Note that this function invokes eval to force the argument promise. # The uppercase formal argnames prevent aliasing with names in dots. # # TODO I wanted to call this function dot but in base R there is # already a function dot (plotmath). dota <- function(ARGNAME, ..., DEF=NA, EX=TRUE, NEW=NA) { dots <- drop.unnamed.dots(match.call(expand.dots=FALSE)$...) argname <- process.argname(ARGNAME) exact <- process.exact(argname, EX) new <- process.new(NEW, argname, deparse(substitute(DEF))) for(i in seq_along(argname)) { idot <- dotindex.aux(argname[i], dots, exact[i]) if(!anyNA(idot)) { argval <- try(eval(dots[[idot]], parent.frame(1))) if(is.try.err(argval)) stop0("cannot evaluate '", argname[i], "'") dotname <- names(dots)[idot] # TODO following commented out until we want to start # issuing deprecated messages for earth and plotmo # maybe.deprecate.arg(dotname, new, argname[i]) return(argval) } } DEF } # Like dota() but default is existing value of ARGNAME. # For example, dotd("xlab", ...) is equivalent to dota("xlab", DEF=xlab, ...). # TODO add to test suite dotd <- function(ARGNAME, ..., EX=TRUE) { if(is.dot("DEF", ...)) stop0("'DEF' cannot be used with dotd") if(is.dot(ARGNAME, ..., EX=EX)) dota(ARGNAME, ..., EX=EX) else # use the current value of ARGNAME as the default eval(as.name(ARGNAME), parent.frame(1)) } # Does a dot argument match ARGNAME? Return TRUE or FALSE, never NA. # Issue an error message if there are multiple matches. is.dot <- function(ARGNAME, ..., EX=TRUE) { dots <- drop.unnamed.dots(match.call(expand.dots=FALSE)$...) argname <- process.argname(ARGNAME) exact <- process.exact(argname, EX) for(i in seq_along(argname)) if(!anyNA(dotindex.aux(argname[i], dots, exact[i]))) return(TRUE) FALSE } # Return the index of the dot argname that matches ARGNAME. # Return NA if no dot argument matches ARGNAME. # Issue an error message if there are multiple matches. dotindex <- function(ARGNAME, ..., EX=TRUE) { dots <- drop.unnamed.dots(match.call(expand.dots=FALSE)$...) argname <- process.argname(ARGNAME) exact <- process.exact(argname, EX) for(i in seq_along(argname)) { idot <- dotindex.aux(argname[i], dots, exact[i]) if(!anyNA(idot)) return(idot) } NA } drop.unnamed.dots <- function(dots) { dots[which(names(dots) == "")] <- NULL dots } # allow comma or space separated argnames # e.g. convert c("a", "b,c d") to c("a", "b", "c", "d") process.argname <- function(argname) { stopifnot(is.character(argname)) argname <- gsub(" +|,+", ",", argname) # convert space or multi commas to comma argname <- gsub("^,+|,+$", "", argname) # drop leading and trailing commas if(any(!nzchar(argname))) stop0("empty string in ARGNAME") unlist(strsplit(argname, split=",")) # convert to a vector } process.exact <- function(argname, exact) { stopifnot(is.numeric(exact) || is.logical(exact), all((exact == 0) | (exact == 1))) if(length(exact) > length(argname)) stop0("length(EX)=", length(exact), " is greater than length(ARGNAME)=", length(argname)) recycle(exact, argname) } process.new <- function(new, argname, defname) # returns NA or a string { if(anyNA(new)) return(NA) if(is.numeric(new)) { if(length(new) != 1) stop0("length(NEW) != 1") if(new < 0 || floor(new) != new) stop0("NEW=", new, " is not allowed") if(new == 0) { if(!grepl("^[[:alnum:]._]+$", defname)) stop0("NEW=0 cannot be used when DEF=", defname, " (not an identifier)") # following helps prevent mistakes when e.g. defname=NA or NULL if(grepl("^[A-Z]+$", defname)) # all upper case stop0("NEW=0 cannot be used when DEF=", defname) return(defname) } if(new > length(argname)) stop0("NEW=", new, " but length(ARGNAME) is only ", length(argname)) return(argname[new]) } # new is a string stopifnot.identifier(new, "NEW") new } dotindex.aux <- function(argname, dots, exact=FALSE) # workhorse { stopifnot.identifier(argname, "ARGNAME") if(length(dots) == 0) return(NA) # first look for an exact match caller <- callers.name(n=2) index <- which(argname == names(dots)) if(length(index) > 1) # multiple exact matches? stop0("argument '", argname, "' for ", caller, "() is duplicated") if(length(index) == 0) # no exact match index <- NA if(!anyNA(index) || exact) return(index) # look for a partial match index <- which(!is.na(charmatch(names(dots), argname))) if(length(index) == 0) # no match return(NA) if(length(index) == 1) # single match return(index) # length(index) > 1 multiple matches stopifnot(all(index >= 0)) name1 <- names(dots)[index[1]] name2 <- names(dots)[index[2]] if(name1 == name2) # e.g. foo("abc", a=1, a=2) stop0("argument '", name1, "' for ", caller, "() is duplicated") # e.g. arguments 'a' and 'ab' both match 'abc' in foo() stop0("arguments '", name1, "' and '", name2, "' both match '", argname, "' in ", caller) } maybe.deprecate.arg <- function(dotname, new, argname) { if(is.specified(new) && argname != new) { # require.period prevents a warning if user uses say a # dot arg of plain 'col' when ARGNAME="pt.col col.pt col" require.period <- grepl("\\.", argname) if(!require.period || grepl("\\.", dotname)) warning0("'", dotname, "' is deprecated, please use '", new, "' instead") } } plotmo/R/singles.R0000644000176200001440000002043714567065255013601 0ustar liggesusers# singles.R: plotmo.singles and plotmo.pairs #------------------------------------------------------------------------------ # Return a vector of indices of predictors for degree1 plots, e.g, c(1,3,4). # The indices are col numbers in the x matrix. The caller will sort the # returned vector and remove duplicates. The default method simply # returns the indices of all predictors. The object specific methods # typically return only the predictors actually used in the model. # # Note on the x argument: # If the formula is resp ~ num + sqrt(num) + bool + ord:num + fac # then colnames(x) is num bool ord fac plotmo.singles <- function(object, x, nresponse, trace, all1, ...) { UseMethod("plotmo.singles") } plotmo.singles.default <- function(object, x, nresponse, trace, all1, ...) { seq_len(NCOL(x)) } #------------------------------------------------------------------------------ # Get the pairs of predictors to be displayed in degree2 plots. # Each row of the returned pairs matrix is the indices of two predictors # for a degree2 plot. Example (this was returned from plotmo.pairs.rpart): # # 1 2 # 1 2 # 2 1 # # The indices are col numbers in the x matrix. The caller will remove # duplicated pairs and re-order the pairs on the order of the predictors # in the original call to the model function. The above example will # become simply # # 1 2 # # It is ok to return NULL or a matrix with zero rows. plotmo.pairs <- function(object, x, nresponse=1, trace=0, all2=FALSE, ...) { UseMethod("plotmo.pairs") } # Predictors x1 and x2 are considered paired if they appear in # the formula in forms such as x1:x2 or I(x1*x2) or s(x1,x2) # # We use both formula(object) and attr(terms(object), "term.labels"). # formula(object) is necessary for gam formula like "s(x,v1)" because it # appears in attr(terms,"term.labels") as "x" "v1" (i.e. as unpaired). # But our rudimentary parsing of the formula is not reliable, so we also # use the term.labels. An lm formula like Volume~(Girth*Height2)-Height # has term.labels "Girth" "Height2" "Girth:Height2" plotmo.pairs.default <- function(object, x, nresponse, trace, all2, ...) { formula.vars <- NULL formula <- try(formula(object), silent=trace < 2) if(is.try.err(formula) || is.null(formula)) trace2(trace, "formula(object) failed for %s object in plotmo.pairs.default\n", class.as.char(object)) else { trace2(trace, "formula(object) returned %s\n", paste.trunc(format(formula), maxlen=100)) # Note that formula() returns a formula with "." expanded. # After as.character: [1] is "~", [2] is lhs, and [3] is rhs rhs <- as.character(formula(object))[3] # rhs of formula # Sep 2020: removed code below because a `var` may have a "-" in its name # if(grepl("\\-", rhs)) { # "-" in formula? # # formula() gives "(Girth + Height)-Height" for Volume~.-Height # rhs <- sub("\\-.*", "", rhs) # delete "-" and all after # rhs <- gsub("\\(|\\)", "", rhs) # delete ( and ) # } formula.vars <- unlist(strsplit(rhs, "+", fixed=TRUE)) formula.vars <- gsub("^ +| +$", "", formula.vars) # trim leading and trailing spaces trace2(trace, "formula.vars %s\n", quotify.trunc(formula.vars)) } term.labels <- NULL terms <- try(terms(object), silent=trace < 2) if(is.try.err(terms) || is.null(terms)) trace2(trace, "terms(object) failed for %s object in plotmo.pairs.default\n", class.as.char(object)) else { term.labels <- attr(terms, "term.labels") if(is.null(term.labels)) trace2(trace, "attr(terms,\"term.labels\") is NULL in plotmo.pairs.default\n") else trace2(trace, "term.labels %s\n", quotify.trunc(term.labels, maxlen=100)) } if(is.null(formula.vars) && is.null(term.labels)) return(NULL) plotmo_pairs_from_term_labels(c(formula.vars, term.labels), colnames(x), trace) } get.all.pairs.from.singles <- function(object, x, trace, all2) { singles <- plotmo.singles(object, x, nresponse=1, trace, all1=TRUE) if(length(singles) == 0) return(NULL) # no pairs (must be an intercept only model) if(any(is.na(singles))) { # We already issued warning0("NA in singles, will plot all variables") singles <- seq_len(NCOL(x)) # plot all pairs } singles <- unique(singles) if(all2 >= 2) { max <- 20 # note that 20 * 19 / 2 is 120 plots if(length(singles) > max) { warning0("too many predictors to plot all pairs,\n ", "so plotting degree2 plots for just the first ", max, " predictors.") singles <- singles[1:max] } } else { max <- 7 # note that 7 * 6 / 2 is 21 plots if(all2 && length(singles) > max) { warning0("too many predictors to plot all pairs,\n ", "so plotting degree2 plots for just the first ", max, " predictors.\n ", "Call plotmo with all2=2 to plot degree2 plots for up to 20 predictors.") singles <- singles[1:max] } } form.pairs(singles) } form.pairs <- function(varnames) # return a two column matrix, each row is a pair { col1 <- rep(varnames, times=length(varnames)) col2 <- rep(varnames, each=length(varnames)) pairs <- cbind(col1, col2) pairs[col1 != col2, , drop=FALSE] } # Given the term.labels, return a npairs x 2 matrix specifying which predictors # are paired. The elements in the returned matrix are column indices of x. # # This routine is not infallible but works for the commonly used formulas. # It works by extracting substrings in each term.label that looks like a # predictor pair. The following combos of x1 and x2 for example are # considered pairs: x1*x2, x1:x2, s(x1,x2), and similar. plotmo_pairs_from_term_labels <- function(term.labels, pred.names, trace, ...) { trace2(trace, "plotmo_pairs_from_term_labels\n") trace2(trace, "term.labels: %s\n", quotify.trunc(term.labels, maxlen=100)) trace2(trace, "pred.names: %s\n", quotify.trunc(pred.names, maxlen=100)) pairs <- matrix(0, nrow=0, ncol=2) # no pairs initially for(i in 1:length(term.labels)) { untouchable <- get.untouchable.for.naken(term.labels[i]) if(NROW(untouchable$replacements)) { # weird variable name (backquoted in formula handling) e.g. `sexmale*h(16-age)` # the gregexpr below won't work because of spaces etc. in the variable name warnf("Cannot determine which variables to plot in degree2 plots (use all2=TRUE?)\n Confused by variable name %s", quotify.trunc(term.labels[i])[1]) return(pairs) } s <- strip.space(term.labels[i]) s <- gsub("[+*/,]", ":", s) # replace + * / , with : s <- gsub("=[^,)]+", "", s) # delete "=any" # get the indices of expressions of the form "ident1:ident2" igrep <- gregexpr("[._$[:alnum:]]+:[._$[:alnum:]]+", s)[[1]] trace2(trace, "considering %s", s) if(igrep[1] > 0) for(i in seq_along(igrep)) { # extract the i'th "ident1:ident2" into pair start <- igrep[i] stop <- start + attr(igrep, "match.length")[i] - 1 pair <- substr(s, start=start, stop=stop) pair <- strsplit(pair, ":")[[1]] # pair is now c("ident1","ident2") # are the variables in the candidate pair in pred.names? ipred1 <- which(pred.names == pair[1]) ipred2 <- which(pred.names == pair[2]) trace2(trace, " ->%s%s", if(length(ipred1)) sprint(" %g=%s", ipred1, pred.names[ipred1]) else "", if(length(ipred2)) sprint(" %g=%s", ipred2, pred.names[ipred2]) else "") if(length(ipred1) == 1 && length(ipred2) == 1 && pair[1] != pair[2]) pairs <- c(pairs, ipred1, ipred2) } trace2(trace, "\n") } matrix(pairs, ncol=2, byrow=TRUE) } plotmo/R/elegend.R0000644000176200001440000002700113440642336013520 0ustar liggesusers# elegend.R: same as graphics::legend (R 3.1.2) but # i) has a vert argument to specify which lines are vertical # ii) allows col to be a character vector with "1" meaning 1 elegend <- function(x, y = NULL, legend, fill=NULL, col = par("col"), border="black", lty, lwd, pch, angle = 45, density = NULL, bty = "o", bg = par("bg"), box.lwd = par("lwd"), box.lty = par("lty"), box.col = par("fg"), pt.bg = NA, cex = 1, pt.cex = cex, pt.lwd = lwd, xjust = 0, yjust = 1, x.intersp = 1, y.intersp = 1, adj = c(0, 0.5), text.width = NULL, text.col = par("col"), text.font = NULL, merge = do.lines && has.pch, trace = FALSE, plot = TRUE, ncol = 1, horiz = FALSE, title = NULL, inset = 0, xpd, title.col = text.col, title.adj = 0.5, seg.len = 2, vert = FALSE) # logical, which lines are vertical, will be recycled { trace <- check.boolean(trace) plot <- check.boolean(plot) ## the 2nd arg may really be `legend' if(missing(legend) && !missing(y) && (is.character(y) || is.expression(y))) { legend <- y y <- NULL } mfill <- !missing(fill) || !missing(density) if(!missing(xpd)) { op <- par("xpd") on.exit(par(xpd=op)) par(xpd=xpd) } title <- as.graphicsAnnot(title) if(length(title) > 1) stop("invalid 'title'") legend <- as.graphicsAnnot(legend) n.leg <- if(is.call(legend)) 1 else length(legend) if(n.leg == 0) stop("'legend' is of length 0") auto <- if (is.character(x)) match.arg(x, c("bottomright", "bottom", "bottomleft", "left", "topleft", "top", "topright", "right", "center")) else NA if(anyNA(auto)) { xy <- xy.coords(x, y); x <- xy$x; y <- xy$y nx <- length(x) if (nx < 1 || nx > 2) stop("invalid coordinate lengths") } else nx <- 0 xlog <- par("xlog") ylog <- par("ylog") rect2 <- function(left, top, dx, dy, density = NULL, angle, ...) { r <- left + dx; if(xlog) { left <- 10^left; r <- 10^r } b <- top - dy; if(ylog) { top <- 10^top; b <- 10^b } rect(left, top, r, b, angle = angle, density = density, ...) } segments2 <- function(x1, y1, dx, dy, lty, lwd, col) { x2 <- x1 + dx; if(xlog) { x1 <- 10^x1; x2 <- 10^x2 } y2 <- y1 + dy; if(ylog) { y1 <- 10^y1; y2 <- 10^y2 } # explicit loop allows use of char lty's with "1" meaning 1 and "NA" meaning NA for(i in seq_along(x1)) { lt <- lty[i] if(lt == "1") lt <- 1 else if(is.na(lt) || lt == "NA") lt <- 0 segments(x1[i], y1[i], x2[i], y2[i], lty=lt, lwd=lwd[i], col=col[i]) } } points2 <- function(x, y, ...) { if(xlog) x <- 10^x if(ylog) y <- 10^y points(x, y, ...) } text2 <- function(x, y, ...) { ##--- need to adjust adj == c(xadj, yadj) ?? -- if(xlog) x <- 10^x if(ylog) y <- 10^y text(x, y, ...) } if(trace > 0) catn <- function(...) do.call("cat", c(lapply(list(...),formatC), list("\n"))) cin <- par("cin") Cex <- cex * par("cex") # = the `effective' cex for text ## at this point we want positive width even for reversed x axis. if(is.null(text.width)) text.width <- max(abs(strwidth(legend, units="user", cex=cex, font = text.font))) else if(!is.numeric(text.width) || text.width < 0) stop("'text.width' must be numeric, >= 0") xc <- Cex * xinch(cin[1L], warn.log=FALSE) # [uses par("usr") and "pin"] yc <- Cex * yinch(cin[2L], warn.log=FALSE) if(xc < 0) text.width <- -text.width xchar <- xc xextra <- 0 yextra <- yc * (y.intersp - 1) ## watch out for reversed axis here: heights can be negative ymax <- yc * max(1, strheight(legend, units="user", cex=cex)/yc) ychar <- yextra + ymax if(trace > 0) catn(" xchar=", xchar, "; (yextra,ychar)=", c(yextra,ychar)) if(mfill) { ##= sizes of filled boxes. xbox <- xc * 0.8 ybox <- yc * 0.5 dx.fill <- xbox ## + x.intersp*xchar } do.lines <- (!missing(lty) && (is.character(lty) || any(lty > 0)) ) || !missing(lwd) ## legends per column: n.legpercol <- if(horiz) { if(ncol != 1) warning(gettextf("horizontal specification overrides: Number of columns := %d", n.leg), domain = NA) ncol <- n.leg 1 } else ceiling(n.leg / ncol) has.pch <- !missing(pch) && length(pch) > 0 # -> default 'merge' is available merge <- check.boolean(merge) if(do.lines) { x.off <- if(merge) -0.7 else 0 } else if(merge) warning("'merge = TRUE' has no effect when no line segments are drawn") if(has.pch) { if(is.character(pch) && !is.na(pch[1L]) && nchar(pch[1L], type="c") > 1) { if(length(pch) > 1) warning("not using pch[2..] since pch[1L] has multiple chars") np <- nchar(pch[1L], type="c") pch <- substr(rep.int(pch[1L], np), 1L:np, 1L:np) } ## this coercion was documented but not done in R < 3.0.0 if(!is.character(pch)) pch <- as.integer(pch) } if (anyNA(auto)) { ##- Adjust (x,y) : if (xlog) x <- log10(x) if (ylog) y <- log10(y) } if(nx == 2) { ## (x,y) are specifiying OPPOSITE corners of the box x <- sort(x) y <- sort(y) left <- x[1L] top <- y[2L] w <- diff(x)# width h <- diff(y)# height w0 <- w/ncol # column width x <- mean(x) y <- mean(y) if(missing(xjust)) xjust <- 0.5 if(missing(yjust)) yjust <- 0.5 } else {## nx == 1 or auto ## -- (w,h) := (width,height) of the box to draw -- computed in steps h <- (n.legpercol + !is.null(title)) * ychar + yc w0 <- text.width + (x.intersp + 1) * xchar if(mfill) w0 <- w0 + dx.fill if(do.lines) w0 <- w0 + (seg.len + x.off)*xchar w <- ncol*w0 + .5* xchar if (!is.null(title) && (abs(tw <- strwidth(title, units="user", cex=cex) + 0.5*xchar)) > abs(w)) { xextra <- (tw - w)/2 w <- tw } ##-- (w,h) are now the final box width/height. if (anyNA(auto)) { left <- x - xjust * w top <- y + (1 - yjust) * h } else { usr <- par("usr") inset <- rep_len(inset, 2) insetx <- inset[1L]*(usr[2L] - usr[1L]) left <- switch(auto, "bottomright"=, "topright"=, "right" = usr[2L] - w - insetx, "bottomleft"=, "left"=, "topleft"= usr[1L] + insetx, "bottom"=, "top"=, "center"= (usr[1L] + usr[2L] - w)/2) insety <- inset[2L]*(usr[4L] - usr[3L]) top <- switch(auto, "bottomright"=, "bottom"=, "bottomleft"= usr[3L] + h + insety, "topleft"=, "top"=, "topright" = usr[4L] - insety, "left"=, "right"=, "center" = (usr[3L] + usr[4L] + h)/2) } } if (plot && bty != "n") { ## The legend box : if(trace > 0) catn(" rect2(",left,",",top,", w=",w,", h=",h,", ...)",sep="") rect2(left, top, dx = w, dy = h, col = bg, density = NULL, lwd = box.lwd, lty = box.lty, border = box.col) } ## (xt[],yt[]) := `current' vectors of (x/y) legend text xt <- left + xchar + xextra + (w0 * rep.int(0:(ncol-1), rep.int(n.legpercol,ncol)))[1L:n.leg] yt <- top - 0.5 * yextra - ymax - (rep.int(1L:n.legpercol,ncol)[1L:n.leg] - 1 + !is.null(title)) * ychar if (mfill) { #- draw filled boxes ------------- if(plot) { if(!is.null(fill)) fill <- rep_len(fill, n.leg) rect2(left = xt, top=yt+ybox/2, dx = xbox, dy = ybox, col = fill, density = density, angle = angle, border = border) } xt <- xt + dx.fill } if(plot && (has.pch || do.lines)) col <- rep_len(col, n.leg) ## NULL is not documented but people use it. if(missing(lwd) || is.null(lwd)) lwd <- par("lwd") # = default for pt.lwd if (do.lines) { #- draw lines --------------------- ## NULL is not documented if(missing(lty) || is.null(lty)) lty <- 1 lty <- rep_len(lty, n.leg) lwd <- rep_len(lwd, n.leg) ok.l <- !is.na(lty) & (is.character(lty) | lty > 0) & !is.na(lwd) if(trace > 0) catn(" segments2(",xt[ok.l] + x.off*xchar, ",", yt[ok.l], ", dx=", seg.len*xchar, ", dy=0, ...)") if(plot) { # TODO vert handling could be simplified xs <- xt[ok.l] + x.off * xchar vert <- as.logical(recycle(vert, xt)) dx <- as.numeric(!vert) * seg.len * xchar strheight <- strheight("A", cex=cex) ys <- yt[ok.l] - as.numeric(vert) * .9 * strheight dy <- as.numeric(vert) * 1.6 * strheight # stagger consecutive vertical lines shifted <- FALSE for(i in seq_along(vert)) { if(vert[i]) { if(shifted) { shifted <- FALSE xs[i] <- xs[i] + .75 * seg.len * xchar } else { shifted <- TRUE xs[i] <- xs[i] + .5 * seg.len * xchar } } else shifted <- FALSE } segments2(xs, ys, dx = dx, dy = dy, lty = lty[ok.l], lwd = lwd[ok.l], col = col[ok.l]) } # if (!merge) xt <- xt + (seg.len+x.off) * xchar } if (has.pch) { #- draw points ------------------- pch <- rep_len(pch, n.leg) pt.bg <- rep_len(pt.bg, n.leg) pt.cex<- rep_len(pt.cex, n.leg) pt.lwd<- rep_len(pt.lwd, n.leg) ok <- !is.na(pch) if (!is.character(pch)) { ## R 2.x.y omitted pch < 0 ok <- ok & (pch >= 0 | pch <= -32) } else { ## like points ok <- ok & nzchar(pch) } x1 <- (if(merge && do.lines) xt-(seg.len/2)*xchar else xt)[ok] y1 <- yt[ok] if(trace > 0) catn(" points2(", x1,",", y1,", pch=", pch[ok],", ...)") if(plot) points2(x1, y1, pch = pch[ok], col = col[ok], cex = pt.cex[ok], bg = pt.bg[ok], lwd = pt.lwd[ok]) ##D if (!merge) xt <- xt + dx.pch } xt <- xt + x.intersp * xchar if(plot) { if (!is.null(title)) text2(left + w*title.adj, top - ymax, labels = title, adj = c(title.adj, 0), cex = cex, col = title.col) text2(xt, yt, labels = legend, adj = adj, cex = cex, col = text.col, font = text.font) } invisible(list(rect = list(w = w, h = h, left = left, top = top), text = list(x = xt, y = yt))) } plotmo/R/glmnet.R0000644000176200001440000001651113717372753013421 0ustar liggesusers# glmnet.R: plotmo functions for glmnet and glmnetUtils objects plotmo.prolog.glmnet <- function(object, object.name, trace, ...) # invoked when plotmo starts { # save (possibly user specified) s for use by plot_glmnet and predict.glmnet s <- dota("predict.s", ...) # get predict.s from dots, NA if not in dots if(is.na(s)) s <- dota("s", ...) # get s from dots, NA if not in dots if(is.na(s)) s <- 0 # unspecified, default to match plotmo.predict.glmnet check.numeric.scalar(s) attr(object, "plotmo.s") <- s object } plotmo.predict.glmnet <- function(object, newdata, type, ..., TRACE) { s <- attr(object, "plotmo.s") # get the predict.glmnet s stopifnot(!is.null(s)) # uninitialized? # newx for predict.glmnet must be a matrix not a dataframe, # so here we use plotmo.predict.defaultm (not plotmo.predict.default) yhat <- plotmo.predict.defaultm(object, newdata, type=type, force.s=s, ..., TRACE=TRACE) if(length(dim(yhat) == 2) && NCOL(yhat) == 1) colnames(yhat) <- paste0("s=", signif(s,2)) # so s=.12 appears in plot title yhat } plotmo.predict.glmnet.formula <- function(object, newdata, type, ..., TRACE) # glmnetUtils package { # same as plotmo.predict.glmnet but doesn't convert newx to a matrix s <- attr(object, "plotmo.s") # get the predict.glmnet s stopifnot(!is.null(s)) # uninitialized? yhat <- plotmo.predict.default(object, newdata, type=type, force.s=s, ..., TRACE=TRACE) if(length(dim(yhat) == 2) && NCOL(yhat) == 1) colnames(yhat) <- paste0("s=", signif(s,2)) # so s=.12 appears in plot title yhat } plotmo.singles.glmnet <- function(object, x, nresponse, trace, all1, ...) { # return the indices of the 25 biggest coefs, but exclude zero coefs s <- attr(object, "plotmo.s") # get the predict.glmnet s stopifnot(!is.null(s)) # uninitialized? lambda.index <- which.min(abs(object$lambda - s)) # index into object$lambda trace2(trace, "plotmo.singles.glmnet: s %g lambda.index %g\n", s, lambda.index) beta <- object$beta if(is.list(beta)) { # multiple response model? check.integer.scalar(nresponse, min=1, max=length(beta)) beta <- beta[[nresponse]] } beta <- as.vector(beta[, lambda.index]) # as.vector converts from dgCMatrix order <- order(abs(beta), decreasing=TRUE) max.nsingles <- if(all1) Inf else 25 # extract the biggest coefs beta <- beta[order][1:min(max.nsingles, length(beta))] nsingles <- sum(abs(beta) > 1e-8) # drop zero coefs order[seq_len(nsingles)] } plotmo.prolog.cv.glmnet <- function(object, object.name, trace, ...) # invoked when plotmo starts { # cv.glmnet objects don't have their call field in the usual place, # so fix that (tested on glmnet version 2.0-2). # Note that getCall() doesn't work on cv.glmnet objects. if(is.null(object[["call"]])) { object$call <- object$glmnet.fit$call stopifnot(!is.null(object$call), is.call(object$call)) } # save (possibly user specified) s for use by plot_glmnet and predict.glmnet s <- dota("predict.s", ...) # get predict.s from dots, NA if not in dots if(is.na(s)) s <- dota("s", ...) # get s from dots, NA if not in dots if(is.na(s)) s <- "lambda.1se" # unspecified, default to match predict.cv.glmnet s <- match.choices(s, c("lambda.1se", "lambda.min"), "s") attr(object, "plotmo.s") <- s object } plotmo.predict.cv.glmnet <- function(object, newdata, type, ..., TRACE) { s <- attr(object, "plotmo.s") # get the predict.glmnet s stopifnot(!is.null(s)) # uninitialized? if(inherits(object, "cv.glmnet.formula")) { # glmnetUtils package yhat <- plotmo.predict.default(object, newdata, type=type, force.s=s, ..., TRACE=TRACE) } else { # glmnet package # newx for predict.glmnet must be a matrix not a dataframe, # so here we use plotmo.predict.defaultm (not plotmo.predict.default) yhat <- plotmo.predict.defaultm(object, newdata, type=type, force.s=s, ..., TRACE=TRACE) } if(length(dim(yhat) == 2) && NCOL(yhat) == 1) colnames(yhat) <- paste0("s=\"", s, "\"") # so s="lambda.1se" appears in plot title yhat } plotmo.singles.cv.glmnet <- function(object, x, nresponse, trace, all1, ...) { # return the indices of the 25 biggest coefs, but exclude zero coefs s <- attr(object, "plotmo.s") # get the predict.glmnet s beta <- coef(object, s=s) if(is.list(beta)) { # multiple response model? check.integer.scalar(nresponse, min=1, max=length(beta)) beta <- beta[[nresponse]] } beta <- as.vector(beta) # as.vector converts from dgCMatrix beta <- beta[-1] # drop intercept order <- order(abs(beta), decreasing=TRUE) max.nsingles <- if(all1) Inf else 25 # extract the biggest coefs beta <- beta[order][1:min(max.nsingles, length(beta))] nsingles <- sum(abs(beta) > 1e-8) # drop zero coefs order[seq_len(nsingles)] } # glmnet family="binomial", y is a vector of 1s and 2s. # convert 1s and 2s to 0s and 1s to match predicted values plotmo.y.lognet <- function(object, trace, naked, expected.len, nresponse, ...) { # plotmo.y.default returns list(field=y, do.subset=do.subset) list <- plotmo.y.default(object, trace, naked, expected.len) # following is needed for glmnetUtils:glmnet.formula models (but not for glmnet xy models) if(is.data.frame(list$field)) list$field <- list$field[[1]] stopifnot(!is.null(list$field)) # paranoia list$do.subset <- FALSE # glmnet doesn't support subset so don't even try # TODO following only works correctly if default ordering of factor was used? list$field <- as.numeric(list$field) # as.numeric needed if y is a factor list$field - min(list$field) # convert 1s and 2s to 0s and 1s } # glmnet family="multinomial" plotmo.y.multnet <- function(object, trace, naked, expected.len, nresponse, ...) { # plotmo.y.default returns list(field=y, do.subset=do.subset) list <- plotmo.y.default(object, trace, naked, expected.len) list$do.subset <- FALSE # glmnet doesn't support subset so don't even try if(is.null(nresponse)) # plotmo uses nresponse=NULL in initial checking nresponse <- 1 if(NCOL(list$field) > 1) # if y is multiple columns assume it's an indicator matrix y <- list$field else { # else convert it to an indicator matrix # TODO following only works correctly if default ordering of factor was used? y1 <- as.numeric(list$field) # as.numeric needed if y is a factor stopifnot(min(y1) == 1 && max(y1) > 1) # sanity check # convert y1 to an indicator matrix of 0s and 1s (NA_real_ to avoid type convert) y <- matrix(NA_real_, nrow=length(y1), ncol=max(y1)) for(i in 1:max(y1)) y[,i] <- as.numeric(y1 == nresponse) } y } # glmnet family="mgaussian" plotmo.y.mrelnet <- function(object, trace, naked, expected.len, nresponse, ...) { plotmo.y.multnet(object, trace, naked, expected.len, nresponse, ...) } plotmo/R/grid.R0000644000176200001440000002417514566065135013061 0ustar liggesusers# grid.R: functions for creating the grid of values to be plotted in plotmo graphs # Get the x matrix (actually a data.frame) with median values (or first level # for factors), ngrid1 rows, all rows identical, nrow(xgrid) is ngrid1. get.degree1.xgrid <- function(x, grid.func, grid.levels, pred.names, ngrid1) { stopifnot(!is.null(pred.names)) check.grid.levels.arg(x, grid.levels, pred.names) xgrid <- data.frame(matrix(0, ngrid1, ncol(x), byrow=TRUE)) for(ipred in seq_len(ncol(x))) xgrid[[ipred]] <- get.fixed.gridval(x[[ipred]], pred.names[ipred], grid.func, grid.levels) warn.if.not.all.finite(xgrid, "'xgrid' for degree1 plots") colnames(xgrid) <- pred.names xgrid } # Update xgrid for the predictor currently being plotted. # That is, replace this predictor's column with a range of values. # For factors or discrete variables, we shorten the frame to match the nbr of levels. get.degree1.xframe <- function(xgrid, x, ipred, ngrid1, ndiscrete, ux.list, extend, mean) { x1 <- x[[ipred]] # uxlist is a list, each elem is the unique levels for corresponding column of x u1 <- ux.list[[ipred]] if(is.factor(x1) && length(u1) > ngrid1) stop0("ngrid1=", ngrid1, " is less than the number ", "of levels ", length(u1), " in '", colnames(x)[ipred], "'\n Workaround: call plotmo with ngrid1=", length(u1)) if(is.factor(x1) || is.logical(x1) || length(u1) <= ndiscrete) { levels <- get.all.levs(x1, u1) xframe <- xgrid[1:length(levels), , drop=FALSE] # shorten xframe xframe[[ipred]] <- levels } else { xframe <- xgrid xrange <- range1(x1) if(extend != 0) { # extend the range of x (TODO consider allowing extend with discrete vars) stopifnot(xrange[2] >= xrange[1]) ext <- extend * (xrange[2] - xrange[1]) xrange[1] <- xrange[1] - ext xrange[2] <- xrange[2] + ext } xval <- seq(from=xrange[1], to=xrange[2], length.out=ngrid1) # # following commented out because it causes cliffs to slope more than necessary # # e.g. test.fac.R plotmo(rpart(survived ~ pclass.num+parch.int, data=et)) # if(is.integer(x1)) { # xval <- unique(as.integer(xval)) # if(length(xval) < ngrid1) # xframe <- xframe[1:length(xval), , drop=FALSE] # shorten xframe # } xframe[[ipred]] <- xval } xframe } # We want to display discrete variables in degree1 plots as quantized. # (Factors get handled elsewhere.) So if a variable is discrete, then # modify the xframe and yhat to do so. For example, an xframe that was # # pclass yhat # 1 1.1 # 2 2.2 # 3 3.3 # # becomes # # pclass yhat # 1.0 1.1 # 1.5 1.1 # 1.5 2.2 # 2.5 2.2 # 2.5 3.3 # 3.0 3.3 blockify.degree1.frame <- function(xframe, yhat, intervals, ipred, ux.list, ndiscrete) { u1 <- ux.list[[ipred]] # TODO the integral check is necessary for compatibility with blockify.degree2.frame # (the code here can handle non integers but the code in blockify.degree2.frame can't) if(length(u1) <= ndiscrete && !is.factor(xframe[[ipred]]) && !inherits(u1, "Date") && is.integral(u1)) { # discrete, so duplicate each elem in yhat yhat <- rep(yhat, each=2) if(!is.null(intervals)) { new.intervals <- data.frame( lwr = rep(intervals$lwr, each=2), upr = rep(intervals$upr, each=2)) if(!is.null(intervals$fit)) new.intervals$fit <- rep(intervals$fit, each=2) if(!is.null(intervals$cint.lwr)) { new.intervals$cint.lwr <- rep(intervals$cint.lwr, each=2) new.intervals$cint.upr <- rep(intervals$cint.upr, each=2) } intervals <- new.intervals } # duplicate each row of xframe, except the first and last row xframe <- xframe[rep(seq_len(nrow(xframe)), each=2), , drop=FALSE] if(nrow(xframe) >= 4) { x1 <- xframe[[ipred]] for(i in seq(2, length(x1)-1, by=2)) x1[i] <- x1[i+1] <- (x1[i] + x1[i+1]) / 2 xframe[[ipred]] <- x1 } } list(xframe=xframe, yhat=yhat, intervals=intervals) } # Get the x matrix (actually a data.frame) to plot in degree2 plots. # Each row of xgrid is identical (the medians). get.degree2.xgrid <- function(x, grid.func, grid.levels, pred.names, ngrid2) { check.grid.levels.arg(x, grid.levels, pred.names) xgrid <- list(ncol(x)) for(ipred in seq_len(ncol(x))) xgrid[[ipred]] <- get.fixed.gridval(x[[ipred]], pred.names[ipred], grid.func, grid.levels) warn.if.not.all.finite(xgrid, "'xgrid' for degree2 plots") xgrid <- as.data.frame(xgrid) colnames(xgrid) <- pred.names xgrid[seq_len(ngrid2^2), ] <- xgrid xgrid } # Update xgrid for the predictor pair currently being plotted (ipred1 # and ipred2 are column numbers in x). That is, replace two columns # with a range of values. # # This will also shorten xgrid if possible (i.e. if predictor is discrete # with number of discrete values less than ngrid2, typically because # predictor is a factor.) This shortening is for efficiency later, # because it means we avoid duplicate cases in xgrid. get.degree2.xframe <- function(xgrid, x, ipred1, ipred2, ngrid2, xranges, ux.list, ndiscrete) { ret1 <- get.degree2.xframe.aux(xgrid, x, ipred1, ngrid2, xranges, ux.list, ndiscrete) ret2 <- get.degree2.xframe.aux(xgrid, x, ipred2, ngrid2, xranges, ux.list, ndiscrete) # pack x1grid and x2grid into xgrid if(ret1$n != ngrid2 || ret2$n != ngrid2) xgrid <- xgrid[1:(ret1$n * ret2$n), , drop=FALSE] # shorten xgrid xgrid[[ipred1]] <- ret1$xgrid # will recycle xgrid[[ipred2]] <- rep(ret2$xgrid, each=ret1$n) list(xframe=xgrid, x1grid=ret1$xgrid, x2grid=ret2$xgrid) } get.degree2.xframe.aux <- function(xgrid, x, ipred1, ngrid2, xranges, ux.list, ndiscrete) { n1 <- ngrid2 # will change if ipred1 is discrete u1 <- ux.list[[ipred1]] nlevs1 <- length(u1) if(is.factor(x[[ipred1]]) && nlevs1 > ngrid2) stop0("ngrid2=", ngrid2, " is less than the number", " of levels ", nlevs1, " in '", colnames(x)[ipred1], "'\n Workaround: call plotmo with ngrid2=", length(u1)) x1 <- x[[ipred1]] x1grid <- if(is.factor(x1) || is.logical(x1) || nlevs1 <= ndiscrete) { # discrete? n1 <- nlevs1 x1grid <- get.all.levs(x1, u1) } else seq(from=xranges[1,ipred1], to=xranges[2,ipred1], length.out=ngrid2) if(is.integer(x1)) { x1grid <- unique(as.integer(x1grid)) n1 <- length(x1grid) } list(xgrid=x1grid, n=n1) } # we want to draw discrete variables in persp and contour plots using "blocks" blockify.degree2.frame <- function(x, yhat, x1grid, x2grid, ipred1, ipred2, ux.list, ndiscrete) { is.discrete2 <- function(ipred, x1grid) { if(is.factor(x[[ipred]])) return(TRUE) u1 <- ux.list[[ipred]] # the integral check is necessary with the current # implementation which adds/subtracts a hardcoded .499 # TODO make this like blockify.degree1.frame (which can handle non integers) length(u1) <= ndiscrete && is.integral(x1grid) } if(is.discrete2(ipred1, x1grid)) { yhat <- rep(yhat, each=2) # duplicate each elem in yhat x1grid <- rep(x1grid, each=2) # duplicate each elem in x1grid is.even <- (1:length(x1grid)) %% 2 == 0 x1grid[!is.even] <- x1grid[!is.even] - .499 # sub .5 from odd elems x1grid[is.even] <- x1grid[is.even] + .499 # add .5 to even elems } if(is.discrete2(ipred2, x2grid)) { # duplicate each block in yhat (each block has n1 elements) y.old <- yhat yhat <- double(2 * length(yhat)) n1 <- length(x1grid) for(i in 1:length(x2grid)) { start <- n1 * (i-1) end <- n1 * i yhat[(2 * start + 1): (2 * end)] <- y.old[(start + 1): end] } x2grid <- rep(x2grid, each=2) # duplicate each elem in x2grid is.even <- (1:length(x2grid)) %% 2 == 0 x2grid[!is.even] <- x2grid[!is.even] - .499 # sub .5 from odd elems x2grid[is.even] <- x2grid[is.even] + .499 # add .5 to even elems } list(yhat=yhat, x1grid=x1grid, x2grid=x2grid) } # if x is a factor # return a factor vector with nlevs elements, e.g. pclass1, pclass2, pclass3. # else # return a vector with all unique values in x, e.g. 1,2,3 or FALSE, TRUE get.all.levs <- function(x, levels) { if(!is.factor(x)) return(levels) # TODO Sanity check, quite expensive, make sure no gaps in factor coding # Could remove this if convert levels to factors in a better way below? range <- range(as.numeric(x), na.rm=TRUE) if(range[1] < 1 || range[2] > length(levels)) stop0("internal error: illegal factor range ", range[1], " ", range[2], " for levels ", quotify(levels)) if(is.ordered(x)) ordered(1:length(levels), labels=levels) else factor(1:length(levels), labels=levels) } # Print the grid values, must do some finagling for a nice display print_grid_values <- function(xgrid, trace) { trace1(trace, "\n") # extra space when tracing row <- xgrid[1, , drop=FALSE] names(row) <- c(paste("plotmo grid: ", names(row)[1]), names(row)[-1]) rownames(row) <- "" print(row) trace1(trace, "\n") } plotmo/R/plotqq.R0000644000176200001440000001317413304041703013431 0ustar liggesusers# plotqq.R plotmo_qq <- function(rinfo, info, nfigs, grid.col, smooth.col, id.n, iresids, npoints, force.auto.resids.ylim, ...) { old.pty <- par("pty") par(pty="s") # square on.exit(par(pty=old.pty)) # we figure out the shape of the qq line with all resids but # plot only npoints points (selecting them with iresids) resids <- rinfo$scale * rinfo$resids # qqnorm sets NAs in trans.resids (leverage==1) to NA in # qq$x and qq$y, and thus NAs don't get plotted (R PR#3750) main <- dota("main", DEF=sprint("%s QQ", rinfo$name), ...) qq <- qqnorm(resids, main=main, plot.it=FALSE) id.indices <- get.id.indices(resids, id.n) xlim <- NULL ylim <- NULL if(nfigs == 1) # user can set xlim only if this is the only figure xlim <- dota("xlim", DEF=xlim, ...) if(!force.auto.resids.ylim) ylim <- dota("ylim", DEF=ylim, ...) xlim <- dota("qq.xlim", DEF=xlim, ...) ylim <- dota("qq.ylim", DEF=ylim, ...) if(!is.specified(xlim) && !is.null(id.indices)) { # extra space for point labs? min <- min(qq$x, na.rm=TRUE) max <- max(qq$x, na.rm=TRUE) xlim <- c(min - .1 * (max - min), max + .1 * (max - min)) } if(!is.specified(ylim)) { min <- min(qq$y, na.rm=TRUE) max <- max(qq$y, na.rm=TRUE) ylim <- c(min, max) if(!is.null(id.indices)) # extra space for point labs? ylim <- c(min - .05 * (max - min), max + .05 * (max - min)) if(info) # extra space for density plot? ylim[1] <- ylim[1] - .1 * (max - min) } xlim <- fix.lim(xlim) ylim <- fix.lim(ylim) # allow col.response as an argname for compat with old plotmo pt.col <- dota("col.response col.resp", DEF=1, ...) pt.col <- dota("pt.col col.points col.point col.residuals col.resid col", EX=c(0,1,1,1,1,1), DEF=pt.col, NEW=1, ...) pt.col <- dota("qq.col col.residuals col.resid col", EX=c(0,1,1,1), DEF=pt.col, NEW=1, ...) # recycle pt.col <- repl(pt.col, length(resids)) pt.cex <- dota("response.cex cex.response", DEF=1, ...) pt.cex <- dota("pt.cex cex.points cex.point cex", EX=c(0,1,1,1), DEF=pt.cex, NEW=1, ...) pt.cex <- dota("qq.cex cex.qq cex.residuals", EX=c(0,1,1), DEF=pt.cex, NEW=1, ...) pt.cex <- pt.cex * pt.cex(length(resids), npoints) pt.cex <- repl(pt.cex, length(resids)) pt.pch <- dota("response.pch pch.response", DEF=20, ...) pt.pch <- dota( "qq.pch pt.pch pch.points pch.point pch.residuals pch", EX=c(1,0,0,1,1,1), DEF=pt.pch, NEW=1, ...) pt.pch <- repl(pt.pch, length(resids)) ylab <- rinfo$name ylab <- sprint("%s Quantiles", ylab) drop.line.col <- function(..., qqline.col=NA, qqline.lwd=NA, qqline.lty=NA) { call.plot(graphics::plot, PREFIX="qq.", force.x = qq$x[iresids], force.y = qq$y[iresids], force.col = pt.col[iresids], force.cex = pt.cex[iresids], force.pch = pt.pch[iresids], force.main = main, force.xlab = "Normal Quantiles", force.ylab = ylab, force.xlim = xlim, force.ylim = ylim, ...) } drop.line.col(...) if(is.specified(grid.col)) grid(col=grid.col, lty=1) qqline.col <- dota("qqline.col", DEF=1, ...) qqline.lwd <- dota("qqline.lwd", DEF=1, ...) qqline.lty <- dota("qqline.lty", DEF=3, ...) if(is.specified(qqline.col) && is.specified(qqline.lwd) && is.specified(qqline.lty)) call.plot(qqline, force.y=resids, force.col=qqline.col, force.lwd=qqline.lwd, force.lty=qqline.lty, ...) if(info) { # draw actual and theoretical density along the bottom usr <- par("usr") # xmin, xmax, ymin, ymax scale <- .1 * (usr[4] - usr[3]) / (max(qq$y) - min(qq$y)) draw.density.along.the.bottom(qq$x, den.col=smooth.col, scale=scale, ...) draw.density.along.the.bottom( resids / sd(resids, na.rm=TRUE), # TODO correct? scale=scale, ...) legend("bottomright", inset=c(0,.06), legend=c("actual", "normal"), cex=.8, lty=1, col=c("gray57", smooth.col), box.col="white", bg="white", x.intersp=.2, seg.len=1.5) } if(is.specified(grid.col) || is.specified(qqline.col) || info) { # replot box and points because they may have been obscured box() drop.line.col <- function(..., qqline.col=NA, qqline.lwd=NA, qqline.lty=NA) { call.plot(graphics::points, PREFIX="qq.", force.x = qq$x[iresids], force.y = qq$y[iresids], force.col = pt.col[iresids], force.cex = pt.cex[iresids], force.pch = pt.pch[iresids], ...) } drop.line.col() } if(!is.null(id.indices)) plotrix::thigmophobe.labels( x = qq$x[id.indices], y=qq$y[id.indices], labels = rinfo$labs[id.indices], offset = .33, xpd=NA, font = dota("label.font", DEF=1, ...)[1], cex = .8 * dota("label.cex", DEF=1, ...)[1], col = dota("label.col", DEF=if(is.specified(smooth.col)) smooth.col else 2, ...)[1]) } plotmo/R/call.dots.R0000644000176200001440000006706613645434036014022 0ustar liggesusers# call.dots.R: functions to handle prefixed dot arguments # # This file provides support for "prefixed" dot arguments. For example in # plotmo(), the user can specify predict.foo=3 as a dots argument. From # the prefix, plotmo recognizes that the argument is for predict, and # passes the argument to predict as foo=3. #----------------------------------------------------------------------------- # call.dots calls function FUNC with special processing of the dot arguments. # # It drops all args in dots matching DROP except those matching # PREFIX and FORMALS, then passes the remaining dot args to function FUNC. # By default FORMALS is the formal arguments of FUNC. # # If argname is prefixed with "force." then ignore any such arg in dots. # Any argname prefixed with "def." can be overridden by a user arg in dots. call.dots <- function( FUNC = NULL, # the function to call ..., PREFIX = NULL, # default NULL means no prefix DROP = "*", # default drops everything except args matching PREFIX KEEP = "PREFIX", TRACE = 0, # for debugging FNAME = if(is.character(FUNC)) FUNC else trunc.deparse(substitute(FUNC)), FORMALS = NULL, # formal args of FUNC (NULL means get automatically, but # can't always do that because because CRAN doesn't allow :::) SCALAR = FALSE, # see argument "scalar" in eval.dotlist CALLARGS = NULL, CALLER = NULL) { stopifnot(is.logical(TRACE) || is.numeric(TRACE), length(TRACE) == 1) TRACE <- as.numeric(TRACE) if(TRACE >= 2) { if(is.null(CALLER)) CALLER <- callers.name() printf("%s invoked call.dots\n", CALLER) } if(is.null(CALLARGS)) CALLARGS <- callargs(call.dots) args <- deprefix(FUNC=FUNC, PREFIX=PREFIX, ..., DROP=DROP, KEEP=KEEP, TRACE=TRACE, FNAME=FNAME, FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=CALLARGS) do.call.trace(FUNC, args, FNAME, trace=TRACE) } # A version of call.dots specialized for calling plotting functions. # This drops all args in dots except those matching PREFIX and PLOT.ARGS. call.plot <- function( FUNC = NULL, # same as call.dots ..., PREFIX = NULL, # if not specified, match only PLOT.ARGS TRACE = 0, # same as call.dots FORMALS = NULL, # same as call.dots SCALAR = FALSE) # same as call.dots { fname <- trunc.deparse(substitute(FUNC)) callargs <- callargs(call.plot) caller <- callers.name() # function that invoked call.plot call.dots(FUNC=FUNC, PREFIX=PREFIX, ..., DROP="*", # drop everything KEEP="PREFIX,PLOT.ARGS", # except args matching PREFIX and PLOT.ARGS TRACE=TRACE, FNAME=fname, FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=callargs, CALLER=caller) } deprefix <- function( FUNC = NULL, ..., PREFIX = NULL, DROP = NULL, KEEP = NULL, TRACE = 0, FNAME = if(is.character(FUNC)) FUNC else trunc.deparse(substitute(FUNC)), FORMALS = NULL, SCALAR = FALSE, CALLARGS = NULL) { stopifnot(is.logical(TRACE) || is.numeric(TRACE), length(TRACE) == 1) TRACE <- as.numeric(TRACE) if(!is.null(FUNC)) match.fun(FUNC) # check that FUNC is available and is a function FNAME <- init.fname(FNAME, FUNC, TRACE) higher.caller <- higher.caller.to.deprefix(..., FNAME=FNAME) PREFIX <- init.prefix(PREFIX, FUNC, FNAME) if(is.null(CALLARGS)) CALLARGS <- callargs(deprefix) DROP <- expand.drop(DROP, PREFIX, FUNC, FORMALS) KEEP <- expand.drop(KEEP, PREFIX, FUNC, FORMALS, namedrop="KEEP", callargs=CALLARGS, include.standard.prefixes=TRUE) dots <- match.call(expand.dots=FALSE)$... trace.prolog(TRACE, PREFIX, DROP, KEEP, dots, higher.caller) stopif.unnamed.dot(dots, higher.caller, ...) org.dots <- dots if(!is.null(DROP)) dots[grep(DROP, names(dots))] <- NULL stopifnot(!is.null(KEEP)) for(name in names(org.dots)) if(grepl(KEEP, name)) dots[[name]] <- org.dots[[name]] trace.after.dropkeep(TRACE, dots) args <- deprefix.aux(FUNC, dots, PREFIX, FNAME, FORMALS, TRACE) # workhorse eval.dotlist(args, n=2, scalar=SCALAR) # n=2 for caller of deprefix e.g. call.dots } deprefix.aux <- function(func, dots, prefix, fname, formals, trace) # workhorse { force <- "^force\\." # "force." as a regex def <- "^def\\." # "def." as a regex # change prefix to a regex, "plot." becomes "^plot\." prefix <- paste0("^", gsub(".", "\\.", prefix, fixed=TRUE)) groups <- list() # list with three elements: force, prefix, def args for(pref in c(force, prefix, def)) { # put args matching pref into group, with the prefix pre removed which <- grep(pref, names(dots)) # select only args matching pref group <- dots[which] # put them into the group group <- expand.dotnames(group, pref, func, fname, formals) names(group) <- sub(pref, "", names(group)) # remove prefix groups[[pref]] <- group dots[which] <- NULL # remove args in this group from dots } # dots is now just those arguments which did not have a special prefix dots <- expand.dotnames(dots, prefix="", func, fname) # "" matches anything args <- groups[[def]] # "def." args lowest precedence args <- merge.list(args, dots) # next come remaining dots args <- merge.list(args, groups[[prefix]]) args <- merge.list(args, groups[[force]]) # "force." args overrule all others args <- drop.args.prefixed.with.drop(args) order.args(args, trace) } # Argument names for plot functions. We exclude "overall" par() args like # mfrow that shouldn't be included when calling functions like plot(), # lines(), or text(). # # If specified in a DROP or KEEP string, the actual argument must exactly # match the PLOT.ARGS argument to be dropped or kept --- abreviated actual # args won't be matched (otherwise we would match too much, e.g. an actual # arg "s" would match "srt"). PLOT.ARGS <- c("add", "adj", "bty", "cex", "cex.axis", "cex.lab", "cex.main", "cex.sub", "col", "col.axis", "col.lab", "col.main", "col.sub", "crt", "family", "font", "font", "font.axis", "font.lab", "font.main", "font.sub", "lend", "ljoin", "lmitre", "lty", "lwd", "main", "pch", "srt", "xaxp", "xaxs", "xaxt", "xlab", "xlim", "xlog", "xpd", "yaxp", "yaxs", "yaxt", "ylab", "ylim", "ylog") # Arguments for par(). This list includes all par arguments except # readonly arguments (e.g. cin) and unimplemented arguments (e.g. err). # The actual argname must be an exact match to be recognized (no abbreviations). # Following omitted because they change too much: col, lwd PAR.ARGS <- c("adj", "ann", "ask", "bg", "bty", "cex", "cex.axis", "cex.lab", "cex.main", "cex.sub", "col.axis", "col.lab", "col.main", "col.sub", "crt", "err", "family", "fg", "fig", "fin", "font", "font.axis", "font.lab", "font.main", "font.sub", "lab", "las", "lend", "lheight", "ljoin", "lmitre", "lty", "mai", "mar", "mex", "mfcol", "mfg", "mfrow", "mgp", "mkh", "new", "oma", "omd", "omi", "pch", "pin", "plt", "ps", "pty", "srt", "tck", "tcl", "usr", "xaxp", "xaxs", "xaxt", "xlog", "xpd", "yaxp", "yaxs", "yaxt", "ylbias", "ylog") # Arguments for par() which take a vector value (i.e. length of value is not one). PAR.VEC <- c("fig", "fin", "lab", "mai", "mar", "mfcol", "mfg", "mfrow", "mgp", "oma", "omd", "omi", "pin", "plt", "usr", "xaxp", "yaxp") # Arguments that are used for subplots in plotmo and similar programs. # # Useful for dropping all args that could conceivably be plotting # arguments and will never(?) be a predict() or residuals() argument. # # When "PLOTMO.ARGS" is used in a DROP string, any actual arg _prefixed_ # with any of these is dropped (as opposed to PLOT.ARGS and PAR.ARGS we drop # actual argnames that _exactly_ match argnames in PLOT.ARGS and PAR.ARGS). # # "nresiduals", is for back compat with old versions of plot.earth PLOTMO.ARGS <- c( "caption.", "cex.", "col.", "contour.", "cum.", "degree1.", "degree2.", "density.", "filled.contour.", "font.", "func.", "grid.", "heatmap.", "image.", "jitter.", "legend.", "label.", "level.", "line.", "lines.", "lty.", "lty.", "lwd.", "main.", "mtext.", "nresiduals", "par.", "pch.", "persp.", "plot.", "plotmath.", "prednames.", "qq.", "qqline.", "pt.", "response.", "rug.", "smooth.", "text.", "title.", "vfont.") # from now on in this module function defs are in alphabetic order add.formals.to.drop <- function(drop, func, formals, namedrop) { stopifnot(grepl("FORMALS", drop)) if(is.null(func)) stop0("\"FORMALS\" specified in ", namedrop, ", but FUNC is NULL") formals <- merge.formals(func, formals, must.exist=TRUE) formals <- paste0(formals, collapse=",") # vector to string drop <- sub("FORMALS[,]", "", drop) # remove "FORMALS," from drop paste.drop(">FORMALS", formals, drop) # add the formal args } # Return the names of the actual args passed to the caller of this function, # ignoring args matching formals of the caller and ignoring dots. # # For example, for call.dots(foo, PREFIX="anything", x=1, y=1, ...), this # function returns c("x", "y"), because x and y are in the argument list # in the call to call.dots but don't match any of the formals of call.dots # (as PREFIX does). The "..." is ignored. # TODO if these were forced we wouldn't need the force.argument callargs <- function(func) { # names of arguments passed to the func that invoked callargs # args passed in dots will not appear in names names <- names(sys.call(-1)) names <- names[names != ""] # drop unnamed args # drop formal arguments (typically PREFIX, KEEP, etc.) names[!(names %in% names(formals(func)))] } # return string "a,b,c,d,e" if given c("a", "b,c", "d e") # i.e. white space converted to comma, c() collapsed to single string canonical.drop <- function(drop, namedrop) { drop <- gsub(" +|,+", ",", drop) # convert space or multi commas to comma drop <- gsub("^,+|,+$", "", drop) # drop leading and trailing commas drop <- unlist(strsplit(drop, split=",")) # convert to a vector drop <- paste0(drop, collapse=",") # collapse stopifnot.identifier(drop, namedrop, allow.specials=TRUE) drop } # TODO add this check elsewhere in earth and plotmo too check.regex <- function(s) # check for some common regex errors { if(grepl("||", s, fixed=TRUE)) stop0("\"||\" in following regex matches everything:\n", "\"", s, "\"") if(grepl("^\\|", s)) stop0("\"|\" at the start of the following regex matches everything:\n", "\"", s, "\"") if(grepl("\\|$", s)) stop0("\"|\" at the end of the following regex matches everything:\n", "\"", s, "\"") } # convert drop to a regex, "x,y*,prefix." becomes "^x|^y.*|^prefix\." convert.drop.to.regex <- function(drop) { drop <- gsub(",", "|", drop) # change comma to | drop <- gsub(".", "\\.", drop, fixed=TRUE) # escape period, "plot." becomes "plot\." drop <- gsub("*", ".*", drop, fixed=TRUE) # change * to .* # clean up, for example we now may have "||" in drop which must be changed to "|" for(iter in 1:2) { # two iterations seems sufficient in practice drop <- gsub(" +", "", drop) # delete spaces drop <- sub("^\\|", "", drop) # delete | at at start drop <- sub("^\\|", "", drop) # delete | at at end drop <- gsub("^^", "^", drop, fixed=TRUE) # change ^^ to single ^ drop <- gsub("||", "|", drop, fixed=TRUE) # change || to | } # prepend ^ to match prefixes only, "x|y" becomes "^x|^y" drop <- unlist(strsplit(drop, split="|", fixed=TRUE)) drop <- ifelse(substr(drop, 1, 1) == ">", drop, paste0("^", drop)) drop <- paste0(drop, collapse="|") check.regex(drop) # sanity check for some common regex errors drop } # TODO add to test suite (although this is tested implicitly in the plotmo tests) # what happens if the argname is abbreviated and no formals to match against? drop.args.prefixed.with.drop <- function(args) { for(name in names(args)) if(grepl("^drop\\.", name)) { check.integer.scalar(args[[name]], logical.ok=FALSE, object.name=name) if(args[[name]] != 1) stop0(name, "=1 is not TRUE") args[[name]] <- NULL # drop the drop.xxx argument itself name <- sub("drop.", "", name, fixed=TRUE) # delete "drop." from name # TODO allow dropping if just the prefix of name matches name <- paste0("^", name, "$") # turn it into a regex for exact matching args[grep(name, names(args))] <- NULL # drop args that exactly match name } args } # Only dot names that have the given prefix are considered. Expand the # suffix of each of those dot names to its full formal name using the # standard R argument matching rules. # # Example: with prefix = "persp." and func = persp.default, # "persp.sh" in dots gets expanded to "persp.shade", because # "shade" is the full name of an argument of persp.default. # # Among other things, This makes it possible for deprefix to properly # process two actual argument names that are different but both match # the same formal argument name. # # It also helps prevent downstream name aliasing issues, because here we # can pre-emptively check for argname matching problems, and issue clearer # error messages than the standard R arg matching error messages. expand.dotnames <- function( dots, prefix, # a regex, not a plain string func = NULL, # if NULL then we just check for duplicate args and go home fname, # used only in error messages formals = NULL) # manual additions to the formal arg list of func { stopifnot(is.list(dots)) dot.names <- names(dots) matches <- grep(prefix, dot.names) # indices of arg which match prefix if(length(matches) == 0) return(list()) if(is.null(func)) { duplicated <- which(duplicated(dot.names)) if(length(duplicated)) stop0("argument '", dot.names[duplicated[1]], "' for ", fname, "() is duplicated") return(dots[matches]) } # match against the formal arguments of func stopifnot(!is.null(dot.names)) unexpanded.names <- dot.names formals <- merge.formals(func, formals) for(idot in matches) { # for all arguments which match prefix dot.name <- dot.names[idot] stopifnot(nzchar(dot.name)) raw.prefix <- "" raw.dotname <- dot.name if(nzchar(prefix)) { # strip off the prefix substring in dot.name (we will put it back later) start <- regexpr(prefix, dot.name) stopifnot(start == 1) # prefix matches only prefixes stop <- start + attr(start, "match.length") stopifnot(stop > start) raw.prefix <- substr(dot.name, start=start, stop=stop-1) # as string not regex raw.dotname <- substring(dot.name, first=stop) # dotname with prefix removed } match <- charmatch(raw.dotname, formals) if(anyNA(match)) { # No match, not necessarily a problem assuming FUNC has a dots formal arg. # We will allow FUNC to check for itself later (if someone calls it). NULL } else if(match == 0) { # multiple matches matches <- grep(paste0("^", raw.dotname), formals) stopifnot(length(matches) >= 2) stop0("'", raw.dotname, "' matches both the '", formals[matches[1]], "' and '", formals[matches[2]], "' arguments of ", fname, "()") } else # single match, this is the ideal situation dot.names[idot] <- paste0(raw.prefix, formals[match]) # prepend prefix } stopifnot.expanded.dotnames.unique(dot.names, unexpanded.names, fname, formals, prefix) names(dots) <- dot.names dots } # returned the expanded the drop argument as a regex expand.drop <- function(drop, prefix, func, formals=NULL, # manual additions to the formal arg list of func namedrop="DROP", callargs=NULL, include.standard.prefixes=FALSE) { if(is.null(drop)) { if(include.standard.prefixes) return(paste0("^force.|^def.|^", prefix)) else return(NULL) } drop <- canonical.drop(drop, namedrop) if(drop == "*") return(".*") # regex to match everything # TODO following is helpful in the trace print only if # you put special identifiers AFTER the other identifiers drop <- paste.drop(">EXPLICIT", drop, "") if(length(callargs) > 0) drop <- paste.drop(">CALLARGS,", paste0(callargs, "$", collapse=","), drop) if(include.standard.prefixes) { drop <- sub("PREFIX", "", drop) # delete "PREFIX" from drop, if present drop <- paste.drop(">PREFIX,", prefix, drop) drop <- paste.drop(">STANDARDPREFIXES,", "force.,def.,drop.", drop) } else drop <- paste.drop(">PREFIX,", sub("PREFIX", prefix, drop), "") if(grepl("FORMALS", drop)) drop <- add.formals.to.drop(drop, func, formals, namedrop) temp <- paste.drop(">PLOT_ARGS,", paste0(PLOT.ARGS, "$", collapse=","), "") drop <- sub("PLOT.ARGS", temp, drop) temp <- paste.drop(">PAR_ARGS,", paste0(PAR.ARGS, "$", collapse=","), "") drop <- sub("PAR.ARGS", temp, drop) temp <- paste.drop(">PLOTMO_ARGS,", paste0(PLOTMO.ARGS, collapse=","), "") drop <- sub("PLOTMO.ARGS", temp, drop) convert.drop.to.regex(drop) # convert drop to a regex } higher.call.args <- function(..., CALLX, FNAME) { stopifnot(is.list(CALLX)) CALLX[1] <- NULL # remove fname from CALLX if(CALLX[length(CALLX)] == "...") # remove dots from CALLX CALLX[length(CALLX)] <- NULL args <- eval.dotlist(as.list(CALLX)) # add dots to args, if they are not already in args dots <- as.list(match.call(expand.dots=FALSE)$...) arg.names <- names(args) dot.names <- names(dots) for(i in seq_along(dots)) { if(!(dot.names[i] %in% arg.names)) { list <- list(eval(dots[[i]])) names(list) <- dot.names[i] args <- append(args, list) } } args[[1]] <- as.name(FNAME) list.as.char(args) } # used only for tracing and error messages # TODO simplify this and friends when match.call is working (R 3.2.0) higher.caller.to.deprefix <- function(..., FNAME=FNAME) { # search the stack looking for org caller of prefix e.g. call.plot sys.calls <- sys.calls() ncalls <- length(sys.calls) stopifnot(ncalls > 2) higher.fname <- "FUNC" try.was.used <- FALSE for(i in max(ncalls-10, 1) : ncalls) { fname <- paste(sys.calls[[i]][1]) # TODO is [1] in the correct position? if(grepl("^call\\.|^deprefix", fname)) break if(grepl("^doTry|^try", fname)) try.was.used <- TRUE else higher.fname <- fname } call <- as.list(sys.calls[[i]]) fname <- paste(call[[1]]) if(try.was.used) higher.fname <- paste0(higher.fname, " via try ") # use try here for paranoia args <- try(higher.call.args(..., CALLX=call, FNAME=FNAME), silent=TRUE) if(is.try.err(args)) args <- sprint("%s, ...", FNAME) sprint("%s called %s(%s)", higher.fname, fname, args) } init.fname <- function(FNAME, FUNC, TRACE) { # check deparse(substitute(FUNC)) issued a good function name # e.g. FNAME will be "NULL" if FUNC is NULL if(is.null(FNAME) || length(FNAME) != 1 || FNAME == "NULL") FNAME <- "FUNC" stopifnot.string(FNAME) FNAME <- sub(".*:+", "", FNAME) # graphics::lines becomes lines stopifnot.identifier(FNAME, "FNAME") FNAME } init.prefix <- function(PREFIX, FUNC, FNAME) { if(is.null(PREFIX)) { # automatic prefix, so check that we can generate it safely if(is.null(FUNC)) stop0("PREFIX must be specified when FUNC is NULL") PREFIX <- sub("\\..*$", "", FNAME) # lines.default becomes lines # Was deprefix invoked using FUNC=FUNC or in a try block? # This won't catch all cases of FUNC=unusable.name but it helps # The stopifnot.identifier() below also helps. if(PREFIX %in% c("FUNC", "doTryCatch")) stop0("PREFIX must be specified in this context ", "(because FNAME is \", fname, \")") PREFIX <- paste0(PREFIX, ".") # add a period stopifnot.identifier(PREFIX, "the automatically generated PREFIX") } stopifnot.identifier(PREFIX, "PREFIX", allow.empty=TRUE) if(PREFIX == "") PREFIX <- ">NOPREFIX" # no argname can match this PREFIX } # return a char vector: formal() of func plus names in manform # manform is manually specified formals merge.formals <- function(func, manform, must.exist=FALSE) { formals <- names(formals(func)) if(!is.null(manform)) formals <- c(formals, strsplit(canonical.drop(manform, "manform"), ",")[[1]]) if(must.exist) { if(length(formals) == 0) stop0("\"FORMALS\" specified but formals(FUNC) ", "returned no formal arguments") if(length(formals[formals != "..."]) == 0) stop0("\"FORMALS\" specified but formals(FUNC) returned only \"...\"") } formals <- formals[formals != "..."] # drop arg named "..." in formals, if any sapply(formals, stopifnot.identifier) # check that all names are valid unique(formals) } # Put the "anon" args first in the argument list. # Then put args named "object", "x", etc. at the front of the list # (after the anon args if any). This is necessary because all the # manipulation we have done has sadly done some reordering of the args # (meaning that the order of the args supplied to call.dots is only # partially retained). The names object, x, etc. are usually what we want # at the start for the predict and plot functions used with call.dots. order.args <- function(args, trace) { trace2(trace, "return dotnames ") if(length(args)) { # order anonymous args on their names, then delete their names which <- which(grepl("^anon", names(args))) anon <- args[which] # select args with "anon." prefix args[which] <- NULL # remove them from the arg list anon <- anon[order(names(anon))] # order them on their names trace2(trace, "%s", paste0(names(anon), collapse=" ")) names(anon) <- NULL # delete their names args1 <- anon # anon args go first in the arg list # Put arguments named "object", "x", etc. first (after anon args if any). # We want mfrow and mfcol early so subsequent args like cex have the last say. for(argname in c("object", "x", "y", "type", "main", "xlab", "ylab", "mfrow", "mfcol")) { args1[[argname]] <- args[[argname]] args[[argname]] <- NULL # remove from args } args <- append(args1, args) # append remaining args to the list if(trace >= 2) cat0(paste.collapse(names(args)), "\n") } trace2(trace, "\n") args } # paste.drop("prefix", "", drop) returns "prefix,DROP" # paste.drop("prefix", "x", drop) returns "prefix,x,DROP," # paste.drop("prefix", "x,y", drop) returns "prefix,x,y,DROP," # paste.drop("prefix", c("x","y"), drop) returns "prefix,x,y,DROP," paste.drop <- function(prefix, s, drop) { s <- paste(s, collapse=",") if(nzchar(s)) paste0(prefix, ",", s, ",", drop) else paste0(prefix, ",", drop) } stopif.unnamed.dot <- function(dots, higher.caller, ...) # called from deprefix() { which <- which(names(dots) == "") if(length(which)) { call <- sprint("\n %s\n", paste0(strwrap(higher.caller, width=getOption("width"), exdent=10), collapse="\n")) dot <- dots[[ which[1] ]] env <- parent.frame(2) arg <- try(eval(dot, envir=env, enclos=env), silent=TRUE) if(is.try.err(arg)) # fallback to weaker error message "(argument ..1 is unnamed)" stop0("Unnamed arguments are not allowed here", " (argument ", as.char(dot), " is unnamed)", call) else stop0("Unnamed arguments are not allowed here", "\n The argument's value is ", as.char(arg), call) } } stopifnot.expanded.dotnames.unique <- function(expanded.names, unexpanded.names, fname, formals, prefix) { duplicated <- which(duplicated(expanded.names)) if(length(duplicated) == 0) return() # no duplicates if(is.null(formals)) stop0("argument '", unexpanded.names[duplicated[1]], "' for ", fname, "() is duplicated") else { # a little processing is needed because we want to report the # error using the unexpanded.names, not the expanded names # get the index of the duplicated argument's twin duplicated <- duplicated[1] for(twin in 1:duplicated) if(expanded.names[twin] == expanded.names[duplicated]) break stopifnot(twin < duplicated) # get the formal argument matched by the duplicated arguments match <- charmatch(sub(prefix, "", expanded.names[duplicated]), formals) if(anyNA(match)) # Dot args are duplicated, but don't match any formal arg. Probably # because e.g. force.xlab is specified but force.xlab is also passed # in dots to call.dots (an error in the way call.dots is invoked). stop0("argument '", unexpanded.names[duplicated[1]], "' for ", fname, "() is duplicated") else if(unexpanded.names[twin] == unexpanded.names[duplicated]) # dot args are identical and they both match the formal stop0("argument '", unexpanded.names[duplicated[1]], "' for ", fname, "() is duplicated") else # dot args are not identical but both match the formal stop0("'", unexpanded.names[twin], "' and '", unexpanded.names[duplicated], "' both match the '", formals[match[1]], "' argument of ", fname, "()") } } trace.after.dropkeep <- function(trace, dots) { if(trace >= 2) printf("after DROP and KEEP %s\n", paste.collapse(names(dots))) } trace.prolog <- function(trace, prefix, drop, keep, dots, higher.caller) { if(trace >= 2) { printf.wrap("TRACE %s", higher.caller) printf("\nPREFIX %s\n", prefix) printf("DROP %s\n", if(is.null(drop)) "NULL" else gsub("\\|>", "\n >", drop)) printf("KEEP %s\n", if(is.null(keep)) "NULL" else gsub("\\|>", "\n >", keep)) names <- names(dots) names[which(names=="")] <- "UNNAMED" printf("input dotnames %s\n", paste.collapse(names)) } } plotmo/R/mlr.R0000644000176200001440000001417113720064615012712 0ustar liggesusers# mlr.R # # TODO WrappedModels need to save the call (and ideally the calling environment too). # Then we can work directly with the WrappedModel, # not with the learner.model. Then predictions etc. are handled with # the mlr predict interface (more consistent for mlr users) # # TODO In documentation mention that NAs in model-building data will # often be a problem for plotmo # # TODO In documentation mention that plotres with prob models usually isn't helpful. # # TODO WrappedModels need a residuals() method? (using probabilities if available) plotmo.prolog.WrappedModel <- function(object, object.name, trace, ...) { object.name <- gsub("'", "", object.name) # remove begin and end quotes callers.name <- callers.name(n=3) # TODO this is fragile call <- getCall(object) if(is.null(call)) stopf( "getCall(%s) failed.\n Possible workaround: call %s like this: %s(%s$learner.model, ...)", object.name, callers.name, callers.name, object.name) # make x and y available for get.plotmo.x.default and get.plotmo.y.default # TODO This eval gets the object called "task" in the parent.frame. # If that environment doesn't match the environment when the model # was built, then we may get the wrong task object. task <- eval(call[["task"]]) if(is.null(task)) stop0("object call does not have a \"task\" field") stopifnot(inherits(task, "Task")) stopifnot.string(task$task.desc$id) trace2(trace, "task$task.desc$id for '%s' is \"%s\"\n", object.name, task$task.desc$id) data <- mlr::getTaskData(task) if(!inherits(data, "data.frame")) # sanity checks stop0("getTaskData(task) did not return a data.frame") stopifnot(!is.null(object[["subset"]])) subset <- object[["subset"]] stopifnot(NROW(subset) == object$task.desc$size) stopifnot(is.null(object[["x"]])) # check no pre-existing field x stopifnot(is.null(object[["y"]])) object$x <- get.xy.WrappedModel(data, object$features, subset, object.name, task$task.desc$id, trace) object$y <- get.xy.WrappedModel(data, task$task.desc$target, subset, object.name, task$task.desc$id, trace) # recursive call to plotmo.prolog to possibly update learner.model # (because for some models, plotmo.prolog adds var imp etc. fields to model) object <- plotmo.prolog_learner.model(object, object.name, trace, ...) object } get.xy.WrappedModel <- function(data, names, subset, object.name, task.desc.id, trace) { # sanity checks check.index(names, index.name=deparse(substitute(names)), object=data, is.col.index=2) # exact match on column name check.index(index=subset, index.name="object$subset", object=data) x <- try(data[subset, names, drop=FALSE], silent=trace < 2) if(is.try.err(x)) stopf("Could not get the original data from %s with %s", object.name, task.desc.id) x } get.learner.field <- function(object) # returns a string { if(identical(class(object), c("ClassificationViaRegressionModel", "BaseWrapperModel", "WrappedModel")) || identical(class(object), c("FilterModel", "ChainModel", "WrappedModel")) || identical(class(object), c("FilterModel", "BaseWrapperModel", "WrappedModel"))) "$learner.model$next.model$learner.model" else "$learner.model" } plotmo.prolog_learner.model <- function(object, object.name, trace, ...) { learner.field <- get.learner.field(object) learner.model <- eval(parse(text=sprint("object%s", learner.field))) if(is.null(learner.model[["call"]])) # preempt error in try() trace2(trace, "%s object %s%s does not have a \"call\" field\n", class(learner.model)[1], object.name, learner.field) else { learner.model <- try(plotmo.prolog(learner.model, sprint("object%s", learner.field), trace, ...), silent=trace < 0) if(!is.try.err(learner.model)) { # update the learner model # TODO these assignments are clumsy if(learner.field == "$learner.model") object$learner.model <- learner.model else if(learner.field == "$learner.model$next.model$learner.model") object$learner.model$next.model$learner.model <- learner.model } else trace0(trace, "plotmo.prolog(object%s) failed, continuing anyway\n", learner.field) trace2(trace, "Done recursive call in plotmo.prolog for learner.model\n") } object } plotmo.predict.WrappedModel <- function(object, newdata, type, ..., TRACE) { predict <- predict(object, newdata=newdata)$data stopifnot(is.data.frame(predict)) predict } plotmo.singles.WrappedModel <- function(object, x, nresponse, trace, all1, ...) { learner.field <- get.learner.field(object) learner.model <- eval(parse(text=sprint("object%s", learner.field))) singles <- try(plotmo.singles(learner.model, x, nresponse, trace, all1, ...), silent=trace < 2) is.err <- is.try.err(singles) trace2(trace, "plotmo.singles(object%s) %s\n", learner.field, if(is.err) "failed" else "succeeded") if(is.err) plotmo.singles.default(object, x, nresponse, trace, all1, ...) else singles } plotmo.pairs.WrappedModel <- function(object, x, nresponse, trace, all2, ...) { learner.field <- get.learner.field(object) learner.model <- eval(parse(text=sprint("object%s", learner.field))) pairs <- try(plotmo.pairs(learner.model, x, nresponse, trace, all2, ...), silent=trace < 2) is.err <- is.try.err(pairs) trace2(trace, "plotmo.pairs(object%s) %s\n", learner.field, if(is.err) "failed" else "succeeded") if(is.err) plotmo.pairs.default(object, x, nresponse, trace, all2, ...) else pairs } plotmo/NEWS.md0000644000176200001440000004145314566603067012706 0ustar liggesusersChanges to the plotmo package ----------------------------- ## 3.6.3 Feb 16, 2024 Updates for R version 4.3.2. For example, had to change "sort.unique" to "sort_unique". Removed dependency on possibly orphaned package TeachingDemos. ## 3.6.2 May 21, 2022 Minor updates for R version 4.2.0. ## 3.6.1 Jun 2, 2021 Minor updates for R version 4.1.0. These updates quieten some warnings from sprintf when plotmo's trace flag is set. Also updated some of the test scripts. ## 3.6.0 Sep 12, 2020 We now have better support for models with unusual variable names. For example, variable names with spaces in them, and formula terms like "as.numeric(x1)". This required a fairly large change to the handling of formulas. We now support models like "earth(formula, data=func(data))", where the data argument is a function call. Minor code change because base::range no longer seems to work with Date objects. Better support for residuals plots for earth-glm models. Support for the "ordinal" package ("clm" models). Basic support for "parsnip" models. Minor documentation updates. Updated the libraries shared with the earth and plotmo packages. Extended the test scripts and updated them for R version 4.0.2. ## 3.5.7 Apr 15, 2020 Added new dot arguments "prednames.abbreviate" and "prednames.minlength". o Use prednames.abbreviate=FALSE for full predictor names in graph axes. (The default is prednames.abbreviate=TRUE.) o The "prednames.minlength" argument is passed on internally to base::abbreviate(). Reinstated the tests for the emma package (were removed before because emma gave the message "package 'clusterSim' could not be loaded"). ## 3.5.6 Oct 26, 2019 The family of a model can now be a string (as well as a "family" object). This allows better support of glmnet objects. ## 3.5.5 June 27, 2019 S4 models wrapped in caret models are now supported e.g. train method="svmRadial" (which creates a kernlab ksvm model). Modifications for glmnet models: The glmnet residuals plot now includes the predict arg "s" in the plot title. The default ylim for glmnet probability models is now c(0,1). For glmnet cv models: we now pass the predict.s argument to plotmo and plotres, and plotmo now by default plots a maximum of 25 coefs (the largest coefs). Updated test scripts for the new random number generator that came with R version 3.6.0. ## 3.5.4 Apr 6, 2019 Added a reminder to use keepxy=2 for earth if you want to use plot.earth or plotmo on an earth cross-validation submodel. Plotmo now requires R version at least 3.4.0. Minor updates to libraries shared with earth and rpart.plot. ## 3.5.3 March 16, 2019 Extended plotmo to support earth version 5.0.0, which allows multiple responses using the Formula package. Plotmo now also has partial support for other models also created using Formula (as well as those that use formula). Added "Depends: Formula" to the DESCRIPTION. Binomial pair responses are now more uniformly converted to a "fraction true" before plotting. If nresponse is not specified for multiple response models, plotmo now defaults to nresponse=1 with a warning (whereas previous versions of plotmo issued an error message). Updates to the libraries shared with earth. ## 3.5.2 Jan 2, 2019 Improved support for models specified with a formula containing an offset term. The grid.levels argument can now be used with pmethod="partdep". ## 3.5.1 Nov 23, 2018 Can now plot multinomial models from the "pre" package. Tweaked linmod.R to better handle models with all-zero residuals, and updated the documentation. Minor changes to internal function calls to prevent warnings when options(warnPartialMatchArgs=TRUE). Added "LazyData: yes" to the DESCRIPTION file. ## 3.5.0 Aug 19, 2018 The default pegged value of background variables has changed in this version, but only for logical and factor variables. For these variables the value occurring most often in the training data is used as the background value. (In previous plotmo versions, the first level of factors was used. But the majority level seems more consistent with the median used for numerics. Also, in previous versions logicals and integers were sometimes incorrectly converted to numeric.) Note this change doesn't affect pmethod="partdep" and "apartdep", which continue to behave as in previous versions. We now support base::Date variables. Plotmo now has better support for caret rpart models with factor predictors. ## 3.4.2 July 3, 2018 Added support for the partykit and evtree packages. Thanks to Achim Zeilis for his help. Plotmo is now more intelligent about maximizing the number of degree2 plots in the 4x4 grid. Minor updates to linmod.R and linmod.methods.R. ## 3.4.1 June 8, 2018 If plotting a probability and pt.col is specified, we now scale the response range to 0...1 so the points are displayed on the probability scale. Expanded is.predict.prob() function for more models. Fixed a minor bug in pmethod="partdep" which sometimes incorrectly caused an error message under certain conditions when there is only one predictor (added a missing drop=FALSE). Enhanced support for the mlr package (but we can't support mlr objects properly until the call is saved with WrappedModels). Enhanced support for the caret package (we now use get.singles and get.pairs on the submodel). ## 3.4.0 May 31, 2018 If predict.rpart is predicting a probability, plotmo now recognizes that and sets ylim=c(0,1) appropriately. Plotting of intercept-only models was slightly inconsistent. Fixed that. We now attempt to better set the default nticks in persp plots. We now position the labels in persp plots slightly better along the axes (they were sometimes too far away from the front corner). When degree2 is exactly two strings, we now assign the x1 and x2 axes in the order specified in degree2 (although persp plots still get rotated for optimum visibility of the surface, and this rotation can reverse the order of the axes). Added basic support for the mlr package (see test.mlr.R). Documentation updates, especially to modguide.pdf and linmod.R. ## 3.3.7 May 15, 2018 Added a README file. If degree2 is exactly two strings, plotmo now prints just that degree2 plot e.g. degree2=c("wind", "humidity"). We plot the variable pair even that pair isn't used in the model (because we implicitly set all2=TRUE if degree2 is two strings). If degree1 is of type character, we now plot the variable even if it isn't used in the model (because we implicitly set all1=TRUE if degree1 is is of type character). For the qq plot in plotres, changed the diagonal qq line to dotted black. This gives more compatibility with plot.lm, and also means that the legend for the density subplot along the bottom of the qq plot (with info=TRUE) isn't mistakenly assumed to apply to the main plot. For the old behavior use qqline.col="gray", qqline.lty=1. Added basic support for the "pre" package (using the importance function in that package). Fixed minor bug: the plotmo grid wasn't printed if ylim was specified by the user. The vignettes are now compressed with gs and qpdf as in tools::compactPDF, (but that happens outside the standard CRAN build system). It does mean that the tar.gz file for plotmo is a little smaller (now 1155 kByte). ## 3.3.6 Mar 20, 2018 Minor documentation updates. ## 3.3.5 Feb 26, 2018 Added support for package gam version 1.15 and higher (the S3 class of gam objects changed from "gam" to "Gam" to prevent clashes with the mgcv package). Plotmo now works with both the old and new versions of gam. ## 3.3.4 July 26, 2017 Added support for glmnetUtils objects. ## 3.3.3 May 4, 2017 Error "glmnet.formula must be called with use.model.frame=TRUE" is now issued when necessary. Tweaked test scripts because cosso models fail with R version 3.4.0. ## 3.3.2 Dec 2, 2016 Support for the C50 package. Better handling of NA and 0 colors in plot_glmnet. Better messages to the user for models with too many variables to fit on a page. With all2=2, plotmo will now plot up to a maximum of all pairs of 20 variables (and as always, with all2=TRUE plotmo will plot a maximum of all pairs of 7 variables). ## 3.3.1 Nov 24, 2016 When choosing which variables to plot for randomForest models, variable importance is now calculated using a more correct measure, viz. one of IncMSE or IncNodePurity (regression models), or MeanDecreaseAccuracy or MeanDecreaseGini (classifications models). The second option is used if importance=TRUE was used when building the model. Use trace=1 when calling plotmo to see which measure of importance is used. The plot_gbm function now displays the gray vertical line at the correct position when n.trees is specified. Documentation touchups. ## 3.3.0 Nov 11, 2016 Added support for partial dependence plots (the pmethod argument). Extended the vignette with new chapters on partial dependence plots and classification models. Plotmo's nrug argument now supports quantiles. The title on persp plots is now better aligned to the degree plot titles. The margins for persp plots are now more optimal (they now give bigger plots when do.par=FALSE and there are also degree1 plots). Added support for e1071::predict.svm decision.values and probability arguments. Fixed error message when plot_gbm was used on multinomial models. Fixed warnings in plot_gbm when gbm.ntrees is very small (less than 10). ## 3.2.1 Oct 27, 2016 Added support for gbm package version 2.2. See gbm.backcompat.R. Extended linmod.R: support for no-intercept models, support for 'keep' argument, better handling of newdata in predict.linmod. Also extended the tests for linmod.R in inst/slowtests. ## 3.2.0 Sep 7, 2016 The functions plot_gbm and plot_glmnet are now exported and available for the user. These functions have been enhanced for this version. Improved support for gbm and glmnet and related models. The plotres function now works better with caret "train" models (but caret support is still a bit minimal). We now print "plotmo grid:" instead of just "grid:" for context when it's printed from within a body of code. Removed deprecated interface functions like get.plotmo.pairs. Updated dot library functions for eventual move to a dots package. Revamped the vignettes. ## 3.1.5 Aug 26, 2016 The pt.cex argument now works correctly in plotres QQ plots. Changed default colors in plot.glmnetx. The colors stay in the order they are passed to plot.glmnetx as we move down the rhs of the plot. Extended test suite to include adabag package. Fixed code in meta.R which assumed all.equal() always returned TRUE or FALSE. Merged the library source file lib.R with the earth and rpart.plot packages's lib.R. Updated and extended vignettes. ## 3.1.4 Jul 29, 2015 Added support for the adabag package. Added imports for standard grDevices, stats, and utils functions, as now required by CRAN check. Documentation updates. Thanks to Achim Zeileis for his feedback. ## 3.1.3 Jun 24, 2015 Added plotmo.prolog.cv.glmnet (to handle missing "call" in cv.glmnet objects). More work on the issue where vars on the rhs of formula are multidimensional. Documentation updates. ## 3.1.2 Jun 15, 2015 Added the new vignette "Guidelines for S3 Regression Models". Documentation touchups. ## 3.1.1 May 27, 2015 Removed references needed for old versions of earth. Fixed a gbm column naming issue. Other minor code and document updates. ## 3.1.0 May 6, 2015 Removed references to functions in old versions of earth. Simplified the way xlim and ylim are calculated internally. Simplified the way jitter is handled. If type="probability" or similar, and the response has two columns, nresponse now automatically defaults to column 2. Added support for biglm objects. The predict.biglm method (unnecessarily) requires that newdata has a response column, so plotmo adds a dummy response column before calling predict.biglm. We now find the data argument for formula models even if the argument is unnamed. ## 3.0.0 Apr 29, 2015 Added the plotres function. Reworked the internal functions that get the data from the model. Reparameterized the argument list of plotmo, but maintained backwards compatibility using the "dots" routines. ## 2.2.1 Jan 7, 2015 If pch.response has type character, we now plot the response points as text. Earth models with no degree1 terms but with degree2 terms were incorrectly labelled as intercept-only models. Fixed that. Changes to match changes to earth's predict.varmod interval argument. ## 2.2.0 Dec 10, 2014 Fixed incorrect printing of some messages when trace=-1. Expansions to check.index for earth. Documentation touchups. ## 2.1.0 Nov 30, 2014 Added a vignette "Notes on the plotmo package". Some more functions are now exported to allow earth::plotmor to easily get the model data Some documentation touchups as usual. ## 2.0.0 Nov 19, 2014 Plotting of prediction or confidence levels is now more comprehensive. We now allow both prediction and confidence intervals to be plotted for those predict methods that support it on new data (currently only lm). The "se" argument is now deprecated and superseded by the "limit" argument (you will get a warning). Plotmo will now plot the model even if it is an intercept-only model. Use int.only.ok=FALSE for the old behaviour (i.e., issue an error for intercept-only models). The "grid:" message in now printed for only multiple predictor models. Remember that you can always suppress this message in any case with trace=-1. The xlim argument is now supported. Typically only useful if only one degree1 plot. Plotmo now supports quantreg and quantregForest objects. Basic support for the AMORE package has been provided. Thanks to Bernard Nolan and David Lorenz for this. But this has been commented out in the source code to avoid having "suggests(AMORE)" in the plotmo DESCRIPTION file. To use functions, search for AMORE in the plotmo source code, and cut and paste the commented-out code into your environmemt. The default pch.response is now 20 (was 1). The default cex.response is now NULL (meaning automatic, was 1). Minor other changes to fix formatting of captions etc. ## 1.3-3 Feb 4, 2014 Clerical changes to satisfy recent CRAN check requirements. ## 1.3-2 Dec 1, 2011 You can now use trace=-1 to inhibit the "grid: " message. Removed a call to .Internal(persp) ## 1.3-1 Sep 16, 2011 Fixed an minor incorrect message introduced in the previous release. ## 1.3-0 Sep 15, 2011 You can now specify variables by name in degree1 and degree2. Suppressed annoying "Warning: surface extends beyond the box". We no longer issue an incorrect err msg if data frame has an "AsIs" field. ## 1.2-6 Removed an incorrect stopifnot.integer(y.column) in plotmo_y.wrapper ## 1.2-5 Jun 11, 2011 Fixed an incorrect stop when trace>0 and x had no column names. We no longer print the plot index in the plot title when all1 or all2 specified but also degree1 and degree2. Added get.plotmo.default.type.fda Touchups to the documentation. ## 1.2-4 Apr 27, 2011 Removed hooks for the earth package (which are no longer necessary with earth 2.6-2). The file plotmo.methods.R was deleted. Added the grid argument. ## 1.2-3 Apr 17, 2011 This package no longer needs the earth package. However the current earth (2.6-1) needs some hooks in this package to build. After earth 2.6-2 is on CRAN that will no longer be necessary, and the hooks will be removed from this package. We now have better error reporting for bad y's. We now have better jittering of response points with a binary response. ## 1.2-0 Apr 12, 2011 Added ndiscrete arg (variables with a small number of levels are now plotted as "blocks", like factors). Added smooth.col and related args (plotmo can add a loess line). Made tweaks necessary because earth now imports this package. Added dvalue and npoints args. Added center arg (preliminary implementation). Added basic support for lars, nnet, and knn3 models. Jittering now works better. We now jitter response points for factors and discrete variables by default. plotmo is now faster: We cache the plot data to avoid calling predict twice for each plot For discrete vars and factors we only call predict for their original values ngrid1 is much smaller (ok to do that because of ndiscrete arg) Better error reporting for illegal args. Reduced the number of default colors (just grays and lightblue now). Out-of-range values in image plots are now plotted in blue. Fixed an issue where the wrong environment could be used. Better error reporting for unsupported models. Fixed handling of factors with non contiguous levels Modified test scripts to conform to R 2.13.0's way of printing numbers Numerous other document and code touch ups. ## 1.0-1 Apr 01, 2011 plotmo was printing degree1 graphs for all used earth predictors, not just those appearing in degree1 terms. Fixed that. plotmo was not handling all1=TRUE correctly for earth models with factor predictors. Fixed that. ## 1.0-0 Mar 31, 2011 Initial release. Moved plotmo from earth 2.5-1 to here. plotmo/MD50000644000176200001440000002144314567113416012110 0ustar liggesusers00edab2265fa1f8e899c6b0ac11ac00c *DESCRIPTION 66578e5f21418e045c00eba90d47469e *NAMESPACE 5cf3309652e67b89eb488ce08866491c *NEWS.md 1467cd99f814516a11538ec00e136c45 *R/as.char.R d6a7da076d299dcaa2edbe35fb81a026 *R/bx.R 9589326d4f3a274b329d915352034a1b *R/c50.R 4dcc6a18a5be035a1e4497dae7b7cedd *R/call.dots.R f0439166fbc6b21e9d4e640e1a75989e *R/caret.R 8313e46b929e7315b0f6ab1b29aa3675 *R/check.index.R a121377a2962c8a2b3b5ea2f9952a34c *R/do.par.R 3c28173aa59055555bf5ed7079e0f51b *R/dot.R 5a08d54148030b9ae3a10edad3ec4691 *R/dotlib.R 861fba8a34b68a1dd39a3e0f62ab7f14 *R/elegend.R fc659fa5f851f0df094c0bb5534ac32d *R/fitted.R 06ab0398be0df66e73c1cbe77c462122 *R/gbm.R 272513f4ff639e72b385cad93ab315f6 *R/gbm.backcompat.R 5172a61a9d181a16591b6a93942b1aca *R/glmnet.R 50d71591ca9a7c399438fb94642b32b1 *R/grid.R 0c68215c3f8b5dc1372e1c3b42972d32 *R/grid.func.R eb6a759ff9a07765a6e53b54809f702e *R/lib.R 48179c86ac55d52efdb85ae534844741 *R/meta.R 18b191e6548aab28f7a4075d407862f1 *R/methods.R 004839b1e52cb50638840b2635bba62b *R/mlr.R d69ebbe9df32a922e8886d735e779092 *R/naken.R eabfd1a547ed2884045cec7779e2dc7c *R/partdep.R 964b5ce6e0729493ed20c043970ab59d *R/partykit.R 439430215813d81e87b00a974a19a0df *R/pint.R 0d312be618b142b4dc3708d9318e4881 *R/plot_gbm.R f2774ccdbdbb11d4b57d22f795826900 *R/plot_glmnet.R 9d562e0797425ec09fe2bdda6600cba2 *R/plotcum.R fdae81bfd8a98ed9298551fe3c56571e *R/plotmo.R df1786a88b8cd00b6b956c8258ca906c *R/plotqq.R 86f491633c494f22d6c65cd00d0bb170 *R/plotres.R 7fa451303357b01ce9207cd3df49e867 *R/plotresids.R 08885181eaa44b48330f54c2e77b898e *R/pre.R fe85abd429fee44f6d609c9309ed0aff *R/predict.R bdf8896a82a46f9c2097e337c0f4a217 *R/predict.nn.R a7cfa01bdb6be6069eeed7f427df35ee *R/printcall.R e19ea08aed52cfd4a2caf0bb11c749c9 *R/prolog.R 54dfa8ee78967bfd14bfe08adcef43cb *R/quantreg.R 11c642968a5174f4a2978df23753ec74 *R/residuals.R 3ce40ca65e3f40673602c7d4fac0fcb7 *R/response.R 9dd8f0a7e56fda7f21bb776f7486bb07 *R/rpart.R 4eb1463adfa036aa03bc9a20e69710b6 *R/singles.R 52a0a2ea4b38645148ca48de84a0567b *R/spread.labs.R 10b221ee9b9f19e92623e133b629efe1 *R/stop.if.dots.R d185816800d45ffd92def6c50d05ec43 *R/type.R ab47d88809f7314f4f82e2e6aef5f448 *R/w1.R 56f3cb29e97b0e21d67feaea1bdfb896 *R/xgboost.R 8239ac7e684324b49c66f3cb1d13ba2f *R/xy.R c10762bf6beb8ae594fe98e62f03566a *README.md 28ee4ac45e2d25b80da2885692fc764c *inst/README-figures/plotmo-randomForest.png bc9547d06efe15fe844a910dc1726dc9 *inst/README-figures/plotres-glmnet-gbm.png 48c0bceb3c05b9c442a6767c92d87dcb *inst/README-figures/plotres-randomForest.png 8ab9f7e2da731b548e17ec146cba9ba0 *inst/doc/index.html a6d4d40c97bc35928f22802635359a44 *inst/doc/modguide.pdf 2668c8a6288114b76f8810561222ffe8 *inst/doc/plotmo-notes.pdf 09d2482a916f131aee0fea0de1e84ae4 *inst/doc/plotres-notes.pdf 9e35189fa10d4674f2284552fcbbfe64 *inst/slowtests/README.txt e64833b093ebe9ceed33758e0944d362 *inst/slowtests/linmod.R 42c25d22bd1996d34193935c602afef7 *inst/slowtests/linmod.methods.R 72d2ea19f32d670c448703471b187346 *inst/slowtests/make.README.R 41c7067ecffc2a80b1c4c3114ec071c0 *inst/slowtests/make.README.bat 07d625248e3a7c2bcd017771e0b84eb4 *inst/slowtests/make.README.figs.R af4e7fcf61ad20030a33ba2a3a26ccc4 *inst/slowtests/make.bat 153b4a6a14d4b0dd4424e722577babd6 *inst/slowtests/makeclean.bat c5bf9446a0eeb97275ad7a7e61ed86b4 *inst/slowtests/modguide.model1.R 08fe3d6be516a61bf72da88502c184c2 *inst/slowtests/modguide.model2.R c2ddbbb20a0c65ef2ccd60de7523d92d *inst/slowtests/test.c50.R 69af490113c14840727e4f59bcb5ff30 *inst/slowtests/test.c50.Rout.save d198a89f986512f0024778b1fb50b2b9 *inst/slowtests/test.c50.bat 9deb8fde036cc52a51d15bedbc26fbb9 *inst/slowtests/test.caret.R ef3779e3c312cddc44174887bfa29a91 *inst/slowtests/test.caret.Rout.save 755db1d284ac5088942f95df916b179e *inst/slowtests/test.caret.bat 08890c43763882c3f9c60f1e4db81d23 *inst/slowtests/test.center.R 3e699701331939677dffc36627b59a74 *inst/slowtests/test.center.Rout.save 3d2c0641ff35e30b35a2e81a494bc8b3 *inst/slowtests/test.center.bat edd4aa48ab07211045b03469d1feda3c *inst/slowtests/test.degree.R df0bc255b5f61d1a3ec4c6ce0367c38b *inst/slowtests/test.degree.Rout.save 8ffc39f66aa409907d67cc026f41a883 *inst/slowtests/test.degree.bat 9bb9c0c749fa373398fde8d760651904 *inst/slowtests/test.dots.R cc1b24d974a892398459c4a74e924f74 *inst/slowtests/test.dots.Rout.save c719b2b7e9d6100a0f21396159bcdee7 *inst/slowtests/test.dots.bat 7306baea0c61d656121cd743183c8172 *inst/slowtests/test.epilog.R d8dd1aa1fdfd8a908d1d568d5646da4f *inst/slowtests/test.fac.R 4dbadc709933462c35a8d58497a74f08 *inst/slowtests/test.fac.Rout.save 9a5b901506ab16174c3f6c112949a67b *inst/slowtests/test.fac.bat f51c70ed12dc117a65a37b1133e9fe39 *inst/slowtests/test.gbm.R 518621d1eaa7dd621f5450db694fc55d *inst/slowtests/test.gbm.Rout.save 11b1efe593c1ba9faa36955d219bef56 *inst/slowtests/test.gbm.bat 51b3736ee000e97783d80713a0a29b67 *inst/slowtests/test.glmnet.R a39757832723fa956e2f8ec021e4c1ab *inst/slowtests/test.glmnet.Rout.save 9f723202a20e80e711e1a029ff9957fa *inst/slowtests/test.glmnet.bat 8496d462371e78d7e4d2f7999ab645d7 *inst/slowtests/test.glmnetUtils.R 2ae3176073faaf1856ee95027104e7b5 *inst/slowtests/test.glmnetUtils.Rout.save f73369b27ed2680465c680c0f805ec68 *inst/slowtests/test.glmnetUtils.bat 07a08d4c8cf37da28c0764ce116642ad *inst/slowtests/test.linmod.R d969b43841305639600194d577003e85 *inst/slowtests/test.linmod.Rout.save fe81b05e0f03ea9d4c376bc303919656 *inst/slowtests/test.linmod.bat c69bc15b4c2e8e30e3b01f7f0d78d850 *inst/slowtests/test.mlr.R c7ff12057c64b8957f9d199cc497891d *inst/slowtests/test.mlr.Rout.save 254ac4e1cdce3ba28d405b5272a8774d *inst/slowtests/test.mlr.bat da121b113f85eabc4b1b044d15c1f5e9 *inst/slowtests/test.modguide.R f8a90b64cca57032357382747319d752 *inst/slowtests/test.modguide.Rout.save e77d1d4d28f67a2c0fc982da203a867b *inst/slowtests/test.modguide.bat d665c3792390c0a1a96cbc8c2949111c *inst/slowtests/test.non.earth.R b6c27c3eb0a3b346de4f6b570a9a25dc *inst/slowtests/test.non.earth.Rout.save 6c786e18a87f0ee1b529e18eba3cd1e5 *inst/slowtests/test.non.earth.bat 664cae41f5a42939cd7c51c32b576ca4 *inst/slowtests/test.parsnip.R 8ddd5a57ce85ce5f451977e1f6a6fc8f *inst/slowtests/test.parsnip.Rout.save e60fd2a10eeee87a3d3bc9f5b161a38b *inst/slowtests/test.parsnip.bat 3ed305939562bc912607befe3a8dc983 *inst/slowtests/test.partdep.R fecbaa79f6f710b45f5a1086d658bbb5 *inst/slowtests/test.partdep.Rout.save abf4ac5fdd800826584cfd2a26501df7 *inst/slowtests/test.partdep.bat e7b4ddac909472912a9e8328be7f94b4 *inst/slowtests/test.partykit.R 8d8a1aeac4f0d598a68896f932bdcb50 *inst/slowtests/test.partykit.Rout.save 600251355af83c4f224d6d5333170701 *inst/slowtests/test.partykit.bat cb7d93b2b463bc75a6329ab2eed2ca7a *inst/slowtests/test.plotmo.R dbbdd3d6828a9e1399484a9f534fa5f7 *inst/slowtests/test.plotmo.Rout.save 666466cb642df4dede54601e130d3830 *inst/slowtests/test.plotmo.args.R 16280d6d059b012633a5e186ca94a1dd *inst/slowtests/test.plotmo.args.Rout.save 4adb516445bed5260708448addbdee83 *inst/slowtests/test.plotmo.args.bat 9a7b78b13dfb8624ce8eabf6bfb1b671 *inst/slowtests/test.plotmo.bat 20d163931383b7ef67b6dffa9b4ff142 *inst/slowtests/test.plotmo.dots.R 9813c5977ad4893417e6521342f8ebb6 *inst/slowtests/test.plotmo.dots.Rout.save 622b35dd987325c65d7621c35eccced9 *inst/slowtests/test.plotmo.dots.bat a2a01720e39bc85f95048c6a7190b8c1 *inst/slowtests/test.plotmo.x.R 2aa66c56e6ac567739e3f0a383c500de *inst/slowtests/test.plotmo.x.Rout.save 752eab98effaaa744d49f3eae11d0bbc *inst/slowtests/test.plotmo.x.bat d5396dcceb11821662abcd9b270d804e *inst/slowtests/test.plotmo3.R 10fcadc19b3a813c5ad72791900773c3 *inst/slowtests/test.plotmo3.Rout.save c41e8d83dcbb954ad8fa0168466e2e22 *inst/slowtests/test.plotmo3.bat 28c18027816c319271d47340b26fe665 *inst/slowtests/test.plotres.R 856b9b12fe5d81dd98790c9c028f8895 *inst/slowtests/test.plotres.Rout.save c87d35bc529448e4fe737044c1ab77c7 *inst/slowtests/test.plotres.bat c1db5aad2002cf85a950ffc2fb5d68f1 *inst/slowtests/test.pre.R eb9f2cdf9b513ccc675f0d4546263c70 *inst/slowtests/test.pre.Rout.save b30e097126b9946c79c2b2ee1b5c8e5a *inst/slowtests/test.pre.bat 6e1bdddcf2d7ae571462722b81db918e *inst/slowtests/test.printcall.R 26d77e59a4b728dc3620a37bd3e53377 *inst/slowtests/test.printcall.Rout.save 46dc538706397a69075e4795c612476e *inst/slowtests/test.printcall.bat e152b8519f616894608c34ee2b5c27a9 *inst/slowtests/test.prolog.R f9acb0955d92b42144d713bd758f1b76 *inst/slowtests/test.unusual.vars.R a5401a929d1526a0f0a82217773fdc2b *inst/slowtests/test.unusual.vars.Rout.save 987615400c3e94094fd955c8c6e4e55e *inst/slowtests/test.unusual.vars.bat cdfded6616efb930da0659a3d8cbbf14 *inst/slowtests/x1 97f4b1936b2d0a85e0d0e4c6e8717dfa *man/plot_gbm.Rd a6f6ed5990f2f359b77bed2e67b99b24 *man/plot_glmnet.Rd c89eb75643f8e92dbdb2bb25325db678 *man/plotmo.Rd 751ab8af1d939886b1a97fb7381b6991 *man/plotmo.misc.Rd 7015c263000f0c68c97afca760fced54 *man/plotres.Rd 3ac7804a66f1f72eabc7d38afc3d4565 *tests/test.plotmo.R 04765eb169cdade58d3e4fb3a67893da *tests/test.plotmo.Rout.save plotmo/inst/0000755000176200001440000000000014334575431012552 5ustar liggesusersplotmo/inst/README-figures/0000755000176200001440000000000014334575431015151 5ustar liggesusersplotmo/inst/README-figures/plotres-randomForest.png0000644000176200001440000002376213304026714022011 0ustar liggesusersPNG  IHDRvvPLTE:f:::f:fff::::f::::f:::ff:f:f:::ff:fff:f::f:ff:ff:fffffffff::::ff:fې۶ېff:ff:ff۶ېې:ېfې۶fې۶:f::f:ff:fff:fېlY] IDATx {u+u͌\$;Mcej7R.nj{<7 s b쎆$xFjR1)fA"`$YfA"`$YfA"))eUUn=z=!ctS [96ш G^fqiO Pmű,^-)!̃"g[Y9` q.XfW`'S_PN~c1;l\1P* PKC<Q 9<*CDX| х+LkE옥,*ɲAeAa)QU -ZMn&G-&M4ZPDݙ|R6汩Xbx괧1=cw_6uwNmSgS.X󏣴Ra=1(s#]LhкV]Ldf!e6Rk+ p227Ul] ΅ X卌 ϠLbFw?.dվؤJ).V%>L uJM=l%n6îbPqFsG&fZ&SL Cr f`hCfgm$VkM6]Ŭ|F4L{i٫39US.$]LhкVZ!a6٦wbF~2DN*#dAVAK7 snnkA12Eedt\D)S߅vB0jV7^:3j"ŽK jÜ]|!жAU?]w!#6ڮ^N d$e"YfAYQṱF1kLī(IX+`0#*A d^yu26y^%51b^q>W#Ÿ"u08χ>&x!Log:!o;c^b¯GxbYH[Ͽګa&?5ŵ<Qa!O%0e”æأ(f?~S n?5,j̠v:]w olYV<}rW5| yjYr>۫5˧#F{a0M6{bSFƢ0'ڢ5l؛f4 &#m0M ~C`?i,3]ezH/&7`f60U `NP.0AQD0|ą<`vYF0'h~f53RcՓLz~؀%$L5K0ciA`V`jD0ci!zXZf 4%.z7<9`ƒ;Om9cad\l Ӓ9y,CUʂ,LXH,CUʂWD3myL`ji0>F8T@i_Z&nI<.&}X0Mc`g8gXI0-z,U͵j g`0"+U^ڟ 0l&>0@lL<6[Al%)!P˄oeL0,Ls.%K4:>_xI0ci3f D0Uok%9Aay fz1=Y}YM0cSc</Њ f 8 tC>&<A0]:E0c)ek^ Ĕfcǰ 8o`ƒ=b3Az1"3 iv3NЅ„ r[f-pì"Qg>mO{0 1)Yk|r#L}lX ^/U`bwb0azaS>5 pxfo˾@^;Li<#Vdњh0YˮYf 5Kj3N>؈U`m(+ tw WWo?V֎/fe6xk947[`u&/kBkRyv0L{s1;^?@$L>PW2U) $=GSÜRg W1l֬19AeKYn# )kRvL2̵ߚ_#LL[fOجBa¯s&/yX@׼5 obC0+nkiښ6o&0( 2[݇f&ʁיE0 )f.~YE0f]}J0W h?t ߉`6AEe`w<۪eӾu'3Yyfְe;L`Onœ7][b&u'7na }غ@Mq l0[7~2*_r`;Lx}&({* _Ł鱱>LH0k*^ 撊3.D00_B0+ L2\NP:hF2O0iA`BaQT  ֨p.;D#c{Ioze0x'̑]$e-YfA")汪bE{ z]tغx~)ܣJ"G"e0nۡF-GqPˍj7S2Ge0|L~oמ>Hw`>-vNG$\ٞ( NV. wJe  ayDAvg0.A'dE+KvgìP <J xqa6~v"/|LQR;r\E:@89hށ{Z/gKr@@<+݁b[֑-`0&{xǣ8p MvwMRx )ŵD0 ,H ̂GK6ډB:1xoQd^Nc>W?-馺cs#FH"!O٭Sn^^A9O'w#e!N3dwSY9*FߴԝcqKø+]dK>[,ĘA%'NԙZOm-2{rY)<'`i\B%)2&3<ЏKnaKʛ>M֒0YQJ&yYi2^GfbhYXO(fϻkyZy\|׾.y@k'lw!Rh@ZDُ[*oWj@ŋuMB֮ p4"`$YfA"`$YfA"`$YfA"`$YfA"`$YfA"`$YfAJ3p8t}7 Ku)W \n @e3$M\.8lۥ2|][/f! Zb][12W7ۥ+eƒwWjv#duf pߠ9T`pq֣wW3t8_},@Cf?o>No(*fV}].T%TОqK46|j]iF7hР ̂fsZJ4@w/.'yƹyx3ִ́Tנ!'s2's(1vՙ3ZO}k<ĽX)}I s^*yjSwHal[̡{,s-_|ſjaRms_iL3DZLDŽ _<_kR,3dZ0˜lUFf~-x\́Yq!L-B'^g6afiqc?-T,X!Ll!/|`YMxb0qYR*2|Sf *ki|iL񼻸9Ѣ4np( nӋE*YYue~ړ9[:XzG`nXލ1o5Q=0.:]z:QԚJ}@z&boAgY5 DiVO@@Άԍ+I,9KAV<,sbr #{Q`XYe0k(RGeXLzK#$ ,[fCXenfY6U:z9va1Dԧ99_z.3:veP̦ٛguc=CPm {,0<`ӜPXS#5fe;zG? Rl(1bx6Ylf=uޣ 4=  ̈spPHM>ǃE#şnm9 5eN ^4" x YX0}ךhFOka TVB *fAh5Ѻ&- iPX-f3t3}ך FbYӛgVC$3b[fZ):JLw[5FrF<եvD ^c(52helwJ3=s_Z:h;}k6݌Q:`"[c8Qg<:[:aA~J5}VYpK]T05(ڮ $ g~lRyj" c["*5@X<}O *ՌyY-RזQ@ΈTS.p}FmyCy2Fsbˉr82gq5= <9XXg6eÜ01K޾hڮڱov uA_Ug,fh,Pf'1A_C\hGwK~65Q󐀰Y[9Q!aȍsԟ Қ!N{!,g^cTL}bBBg+9U06{D!z3 !08 au9Qۛ\ϦZ#L!7 t5:f@#@y0˅.&qVAeju9v]h!u&26-7:ܡ£Xs%6B'&q\k%0 !Sᗗ:`yVoԴh)PaڼR?oãFyÄ2`V7|{FD%q;hXoK6Lk5۠AW<_9f>0g(bT翈?,')Y/"TO%fT3y_^:+43}5fKM3{%3AS`h3d"^Lme3a֍LY ez ,swNWv033s:@דTo-{:ZfwN/=|Ӊ seO'j*D04fB_6K|Dف]I*z:ʞNq\OR[-{:Qj˞N!qƗfzbveOh0sedWYO L@u9a&(.̼Euf*o `xk{9];3ob/9~Ւ!)%R,̳xb(ٗU~0e`aqˎf~0dEtGF r(Yw rS0eτ7U3Y}5KQ65µl !F0#dB3P'B φ:!E ̂D0 T{p^X5/^y} M]q/|5X,²/T{ M{՝evQy/yw8-38-gB/T &/OWW ݛycMíe²/T$ &W0O,Q?a1*g:?Muq-Sd@X1{!Kew¼bCve?4Ot#$/02wy/2%%-So0r' Ţ٧ʡSSd?gusAȀ0[9lK6_>٧I;d pNˀ `b5}x[#z)fu,7~Je hXȀAL4zw g?Z%L^Uc]u5%yi bZÖ ,H ̂D0 ,H ̂D0 ,H ̂D0 ,H ̂D0 ,H ̂D0 ,H ̂D0 ,H ̂D0 ,H ̂D0 ,H ?6-IENDB`plotmo/inst/README-figures/plotres-glmnet-gbm.png0000644000176200001440000002607213276123320021373 0ustar liggesusersPNG  IHDR{CPLTE:f::::fffff:fՐ::::f::::::f:::ff:f::::::f:f:Ր:ff:ffff:f::f:ff:fffffffff:ffffՐfttttttttt֍ttt::::fff:f:۶ېېttttff:f:fېt6f7]̀ӥt6f]f]բ֫ې:ېې:66:6f]:]]:]f鼍:f:::::::f:f::::f:ff:f:f::fff:ӥ֫fې۶fϪT IDATx흋$GY{o9u]`HEț(1Y<Aaa+ XEH B9ACs$ []U=]U]5г;5U=3ꪄ H$}, ʋD ʋD ʋD ʋDKwʌv?jU#Q;JP!ks48.:I~g ـgyE3<[~m?Ap2%ʛr=lEyb "ӏZ.-yTcdwOeܦ?QǞ b}(oJztG3]˂w t Z쁼G"ҟryb*ʣJ.˱,yCy$//Jh Jq, NJ }t @y5yG/==v%?'oM"8h-/<~{AW|$cYpOU&[z`cAO/W, diZpe LB b ZpeKo"B'V*k7cYp^bY[x"Y;DV"т"т"т"т"т"т"т"т"т"т"=Na‘)2"(/-;bι8I6 *-v|'Y>E,̎n 6vo "=18eLA]&2Je iڀàE^O=gO3yۈ=HW␗z"Z޴H{x$y`hEJڐyD"/MX/ S|bH{x$ty|&- rhU&ˈ?–A@yhAyhAyhAyhAylCn&O])0kgǏ|<| -~3_Ÿ~ ! ~005' {ُb#[LWB|6?G<|둾&/|gw_%"뿦3*~yoijɃO8"?, To[ZA7JXM7ڴA;b# _d'ϴB7~ۿV卐ogaWlEW?ۤƒAz=sM yEt6)8fwe{yh Y{}^Ǐj^ >C/$z3B;Uyٔ`%+&eGV^_F4)_oR@ޫ7'Yv%Ҿr%;#6,W^&hvޓveģũVj/lDN 1IhpgȔӍBW/mw_K3mTЂǾFCVԥ!/#5̃o SYݫx:$bcy 5:xFJ[L /9o*yX)B\ h]y2l}kOe:x"/{T-k*o-rߚ{+$H|[ym"2켮R-gͪ3C>E[+$H| 7l2=p׏y*ˈGP"㼬#6A^nm3zנRv-ՔgP^w]o]+ :P^ (JL格P^2Ey,7^Ay7L|*ࡕknAHK?lv%A2m14}Gy Ay2r{Q^tg~6o51+,4`押DoM H#.+%(!Qbw-Ͷg7(UoM@&|6~of~pwS0mоR(\:,MnByxkNTi .f7'֙m%ۣ҆W[EgQz,{0-f^(o"0kړn95A^BY^EE(PͱlJ?m (2u5J6Ə>v0C߳G%Ic> ŻSn1PomZ: ]e"o9/4.N탼Z)xK;Cevd*m~g5s*dS n_@^* /MJ,0 ˛w?ܶ9Kț+"oD^HWX<-\Nmm44dڰsdEy./ /;Njbͦ<׏%O( Q^fswy ϞaPhB^[7]y}\v7late  3mXۃ 5I(/UG4W\Ѵvg zTwHF ۃۗP<^f!owu'[&rAɫ`F\+߆LwGݕa`[%+5YAy۟ilAœ#o+ɟȫ2̃o⚤P\+J')ߞu./[isryuWiW_{@WF^K+윝bU^㏦XWY^e-;c19~Ci+b8r^Ygm6` a+ÒVG^^Mww+ÒVE}maGzn0Yc+"o޾堼[ y aWq /mXf4t#oVi _Y^`~0xYn~؊n+n1r"/d!'Hy=/^.N(SiYnvQ8WO.*u3b6e ̮ׄx>bc#/Kߴ!Ր_P# ɛedڥzcNsڌ N]Ws\`YmPR<yWS7 )_)%||By9o1BQPo,fy%( @Sѥ*f9ڣ{ySYɮ$oX?Ȇ{WSw2(#_M*/aXT7Pw&BERޞKŖY:(\]-xmGl A[hp[gm8s+Jzb=nzOzׁV<ãx;2yY\'s->3ū>ӆr8 ])WW nnYTg?&Bt8we⩉\D^> &}񢄘Bt8by'p{ywZP%Dye9/wʆSߗG+/ q-ڥpZP%ĴA\wgQ::}jqB,8 <j/UʫBHeDZ k2Y)Fwy-V#Ə﮿]TuJ޶(o>mEi_{1o@y8nk?LzQF7\p~^U^UUEE o.qM, Z!^XEy_:F^=f'1 ya$4J Wy7EwQ^%F >XA\*?l%xB|VPyP4%wQ^K`Xt;+yG,1.k`țbD~Li>7 )^ JފÔw|#.m0 >XA^N)G|`:AXV؟ ףfiB0nZ"ypK(/=O[ Ak-`mao8yew ͯx#E)oM4+gm.WJM*6A۲1orVm{wS R޶ Ju6Hʊ Uʫtl靴 bP;?IW4\vw J{Q^ ‡j2%ÔwȋDnçlVMSK櫐6tdtq)jmDyxmh\,eb+j 9:%(Q'X 6 jB^ʈ 7ğ6Lq?i1,L5ѻӆW17rwmd-;m(o\_?鿫LvUHZ5jO!DP^y+t"Aʋi1slwk44f?Aya1m`Rt"Fi0}%҆iQeJXX*ϤwUCc ( ir64UsS8K߽zA(ץF.q 򶊼~+6~Boo-?kFx8,B [BaHd=J4ʫiS?ak{PQ^! ҶZm qUV?4ÛP^1 0Fȫ :j&%y=W!mcz gjV p&\rujkZ^wVB0)ߎ´jV&<_{UgSryxU2^kʍΏCO ܃X8ӆ2{w˻,Jy~OMW6ݧf T[ɥ|]]jyMAM ͯ=me 6.a9wZfmL86k֌Y6VE9o5l"lHd5ӆ) }(o36Pj,K"6EO^ʈ۠DPbk 9Gy=WjƜ[aa`&qӉմc+/Ͻe+l?WI͞jPAZR-D{jVQ^e+/'YϘ jyIyHD{jQ !ۗ@ y5]"oXDD{jZ*GUA`#m0hPB%opJ[hOWM@TT }Oy;?Viw!͞ô!kK2𞮺Pow{ #u/ۋ#m_Kzůx#F+*d5҆q˴.zJp ֺʨ-Ry}ػ ۜyi-a_* NJObڠan.kUK^? q _s{y=G[7/odZ^_B붔'avI6Y y۞o#oi=*/ ųj,ɋi CcK]硎wiRy(o{ou&o/Bkyw."굇- i;S+-Oټ#y/˸{F.tWgcj\uU+oyOO7IAy Q8j1:wuZ\O{o$ӧR!?Ek0zQF/ћou oajK^C'7_^ءũ}O=D^ğ6KkRX7u}-!_'74Ot׵˛ݻfxrZ@eo7 m~7  `|Y;\ZRW,v]ț}3C'1_`3G3gϚG6TO-^@`y5K噽'ӴጱYmcO8%P(˿Ykn/ǟËkÁ*IQ i¦x7{b0il0mO6=KafKU\FF-D_6t{-9ѩ:IfOif@IIގf-ҽU{5s5{8 kH"l9g.f5v&p UUHW>G7~l@ɨY)hй^ʊ5$7!_B /<>EyT=)t7@{hͳt~%"o.zk{1mPMބ2'4{alÿ?H r*[$DboX;|@W,45%{i/ ,;B 'n|K*Jӕ(oWfo@ r2j:jXݮ!L{1mTMnހ6fW*:a\ՂZ *cey 2WzEQ' d̡vN@^!LuM˺m&0b"e- { W}k`s\jô^5ì!k[NrH L<$kj{C7!^qoJopn/ʫٛ&:dop'Ŵj5`o>HT O^R^n5K34g Qd9sӥ鞚Mkw'{w2Vӥ ԾZocu 8mDy#xm'>> T޶#Dx*.y&ްU^"ڎ:IJLj(!Py5{m;Ik[oPV}0vȒ#aD'27? [>ɛϜ dCy˞vi(>yC|C${?Lv7 z56J J"Wbogss'Bw`b_o>ҺwP2FbW̛^T_aBniC}Ma% Q+ 'qoӐ{m{t,.Z*Cg3"n/9ImI0Û?6j3oy`ř[*^r 96w~"vuw8Ih V^u-p&c:;ǡÁ|[hH|^(ꏑ[ڵ +9mci~67OOI]_Ňس"WŤN(RyԀyͨ.ߪٱ˷B)/E‡b[^*ē $b}q̤ˢ^9m */X^֗>{lj Ζ集_+IxbowvQ+k@N;Dsy:l䫾r}= )j}W-7XjZ+6]z"TS@.,{S8S[Y9]bjf(m_R^i<`}˂nbV2 '/ªkoڃ&2evvޓi;;h6N~#r}–зe's6WŻ\޺@+3)mf!eev뙵OZRC'<x)]"tWH^U[u%j}_%5KZ *k.孏 /WKR,nwALm%q,/ц_jP.YM#yIC5Lh A7ŧoXK*+_:mH>Y+XhW@,E;E#]w[n~^"`DZm8yk[1{ \` B"H!-lI( LIDATViC*/qxr뿬D.m`%_-axw GV*5XI[lJzv^}ZVfow2T ,Z^_nN!K%HmKWYpfhi'eM D^b@H8YEo"/WmzYK)\fsUa7m(M X+72(yI!u Q^{ V ,ݯF;[G*]׀*vS|hKY֕kￎjvj05;"ݥ|*f)N?v֛"7j 71 ?)G^m0k)2ۥ’o[=+Zo l K]2s 0k).}7YCRvJo6i%k)jrߛJ’r fW`HFy7 K$$Fy7fyNJ%(=l5"@yQhY[ QN2ٹ[I[hrZ]A qbR_zO(/2/>2?Of7}cc߀X[.rh]X*mc󞤩eqoP^%"rZ 1Hy.ե lЂ/_^Xʖ=ճ5M[mm Ip 0be|]QOScPOi56Gd37yztjn>mO ӯ]a;h  z γ 5QiT(~ͱCF;ZH~ލw~ލw~$8Pް݈q8)f崕D9NN>,~"ʩQ|R|R1O[_:2PbxAyF{R (r)Ya^N[O3ZM7v'5 ʥ䅡QvY sBi YsE-ĉr Ar)ya&AeLcM*,ѮkP)gP_>2P<'Xy{Izƹv11{a0tI11o(;ęQ[50JItP]\trg[eyY;mmг 8*wh(";hq\Cq\J^8M/+Nj;)2,[rXY|1yw?&+iڰ I?/ Xi:OW_ZN2i/oZN_<r"R#(/KfGmyEz{B)m`[I"=ʛg`禬7am$/+E{#{“2gύh:ڝRpV3 U&v&Mq])== e]5Ei+h*lATZFs_dt=X֦6zZzotԜ$~S}ŸDaI]j y6 GǏ؆ 'HӌذReORbgLH; Sώ 6ؕJXD>_"J6vض\+pZT~ w@p/QEPKS3e {ZOO<; DzasQ^\Y /6E-aN$yeyD@*jaoEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE5:IENDB`plotmo/inst/README-figures/plotmo-randomForest.png0000644000176200001440000004724613276542471021651 0ustar liggesusersPNG  IHDR? IDATxkwg>f1k^HxwNt) dqƘ 0AƜ AJ0 N)sj;;ݻWxg!5_-=~\'K*oTJR򭻞RTU%V6B! `#,6B! `#,6B! `#,6B! `#,6B! `#,6B! `#,6B! `#,6B! `#,F1"ƲYҡCz,dr/ˮ},@ec^WZKF*HZ鐢#3MD3֢tH'oN9L:)Hy=>i^imz@6 ٘7 ԼLCDyUUSA"Ęyud<2Q|dh- >jq뙋m~Ưl έŧcxg1CX| ע& Y({ !5/sY },k)? |:f+տeC1M؞??!+ɭH_#}'ǂ<̠ !L Ι~ _g.q>䰜%&nzƋ`kczf+֟Nx"/6|`//LBVnA43xdː~kVCK59)Kk&!k=se0ty%q7y&2/'f]/ :Z|%}3#f6O'kLQ0535wHLVA[F'Vu߹J,ʐᾸM(~Qş+RWx\,\#)L>>t"͘D-KC7o8R272Wgr5[}3S 0$k θ!~DUR>q)Yxq{R8鳶tJЭf?JF">t ,3d0nw$6l2mpEd m6̨Dsը'knX=}K]`8\ɤ)mT6]ӱuzfKN)]`/_<̌΢/>c`V}[Kqc$MgDh&Vk>/>}ɗYQ5ӱ55I%LEDdCQUP ֲ1{`j6ʡ9wH>ĬlZZȨcM daA_Jtȟh԰W`: .*Y!dlBFY!dlBFY!dlBFY!dIϖy[y,Cg&ߚyqFhlyjV]@J91_\՞7ܩJy >X&I ]vA3!BnMeM) Y1^\COGQBlOQŸ{,)aVr)wk&g.>1o~+Wq뤀5f;ex3)94fO E&<ь6]TL~'eI%p{(Ni+ƼE3tj,fq !}OAQsf!m87CK@raYr7YLM c0xb5q+p2oLABV.Yx$TOfz#Ͽ kt(l輩,ؼ11Yl660)j&:JknLl%ɝMݹV"k$_ĎzXHEpL7{-`1l}41;۶Xg>v (D6EqG&JYO ՠf , ӰO*H.fxjLq+iR0b3Kec^wd(*v;5GQU;+J@d5lb7f\F%he 5gJ]@)U66.5&7k^s~#0 k,8uȺ(,+h[ k,8N _٘=՟;_: 45(m@U:a^a*5zublBFY+(BE! `*6BPI[! `Z^#dlҗew O0q8,mDC #dR^[! sgʰt(wt$J(mӂTX(YI [FUɦCMUUUUm,tXc9Jm,XƂRPNDܡ9gg SDC?A'j k,*kThP-% XUkM~BF6l;Vͫ|)k,8ufc oXp>8!@Xp>8!njꋏR[[e(X(V6~Z+<Hů.Wx4@/@Ƃb@Ij:a*.ujW! `#,6BR͞Y!dlBFYCjBFY!dl.G_C! `#,6* 828XIQq.d~XXcaVs[eZ{Xca(]nP`b,DDgI` k,Qs^9[I)ݣP=NXc< ^*Z6VYkVxkŎ.o;Ƽӛօ,(@`8;u CaƂ;W[Ǽu5:dM4P.8! n Āsaǩf\ *5vgZs_M,6B! `#,6B! `#,6B@cs>BFY!dlBF!N?=β 5J6hʨ*gYXKQS M4eI5)8^OߜB!;q5m^&au$|"gg_[hOP0) 4e.ݣ8{6h,NXc 0R? PpB[2(b uO؂oad4ND'skUXϯ$GѬe5xᒾ`) 'w<.sڣ1[__ɚx傯Q?k7~)tU]0|f%'\k᭚be WY9;W@з.R yB0}Gu@KzEJqu+]2= U\*zoT1 |*ye6}6X],j }gkl1ߥN .As*o_;(Kw֣aH̺(ʬcߊhѻT=Ll(`噋k}UQMƼm4:vY0F1gm}-.OTaǰ-Aʾ{%SSϮ5X+T7Wx4n fkV|,OGm,SLTL}BVVyc]rH[[(dO$e|ePֆ![Xj9k7{C4@5b.&@ TRKj Q d;~7(,mDY)~YoYkR(TB-UD1`lWAɬ+t멄pB{p^c-ԐgrAjCM@[r+1sa('nLWXcyPVBv"M)jr 8NXEnEL)5N!e)3vz*]ƚ/$ITU ! UTɎ(8blec@ֹ ! 0mbP0n6B! `#,6B! `#,6B! `#,6Qv$kXc6jqF7D\*.Tmq:|h! `#*Y!dl!yo,KDDuy8aߩP!K_/AUm )PVF9D:(2KeoKWXbJ]kf:~+zjh 7J`PbWȦC2*OFfj¦' $(WşRE""w'ؚ{\yyFyVUUQjwF9/{c*_BjVdӚaEus{&+_B]ZŇNygY"J%䢼V߿T͌]u_$"rkN*d_N6sR59u_K4>*|[BJKXdϚ߹CNP_ ]{K'KED=R%H0VKGToKXz*U*حFFY!dlBFY!dlBFY!dlBFY!dlBFY!dlBFY!dll l̫(J(m4V!LOoƼR`2d!I|qUU㾂C-K;Mzd((i!qYSzC!o~t̫WM1y)%Ƽ%ǒeu<,+=t]܂S@f_y5>Aa"rgdӨ?կj*W6D3JtwSA" xOCS"J%tO(vec^wUUS{: .af_a}z<5~,OEY>"r7y&_JaYr"75hhciʾ=eAzd~X>. .Xnvqf_֓ɼ~LM䢱[Q[ eLvk\ u̔&+NفI4{HO4 ji8ξ !+ן ZH>sw,'&rMq`F\3p@AY>FMUF=wn?ܶ=i~Wx<~;2L_ȒyMQܑ Ot{@){tH')yO4SB$mPN6U),P! `#,6B(U SդS._&.vA9%+*߷~l 0+NKwD 0+]0<-Ѹ5_5b&3MQLgPޒ@}->L+) pϙ)=]SG͞vAuE'l ~@#j5*Ϛb^ (=f)?'?ヷ~?=374e}1M1_{!ɟ,J?蓟QƽEYa7=xHlpZo2~wg\2jH^el*(8l݋S2V~w1s}Dw8},VQN?S吝ao~Wy /j̖vA-WH ʸ-ozRlī7dnb$Իĭ"`}9#C plRvEѧ4p,\A\f۲Ű0>Jqt:ةd+0~2V?]PT!\qwrp>N߽aqwMǠ᠟PFfuClfe,m;6q1w(F!_ mYٺ)QV}9J+g" ]&Wzu8vA}C$). #?;}8RWӣܿ]O}dk?vxsl{?TnC!de+!۾ wI8^X;i ƒ"[?>u> WrDQ?^ۢ tt~i}*b<@-kG}JD wo-hZr9dk(^Avu-lؾgO>S5*{#Ne쎷_W0L-5&mCUԞNX({W߽HS6ؾ.B1~q޲tNX"ڵ5Qn:TʲT Y6l1O7,f5}΋WԽ/9gl]sޗy &;}l+W?@rϞ_Vm_|ƕ"[m\)w _姼O s*Yݭ;ﾸG3u(uzwC ]![oZܐA+>d?9^?zh:4.fifkkDTj[m_ Y>JU7kjY "aH3w%'lCpn q/w8jcշ~9x-c GqUQ Y)Vַ~ҍm/Zj2+@5@R95  ??Oi;pKWҍm7G-&a+;ç A8D~h_[={-2? a픧\ط3_UMV5NCQw7^[#__-N! @.:]/|b/TC1H IDATu 1![Ek7xP 0aǟlvohD U)]Ѹfk}_WͶ}Y+![N_ ~J[K, WPrOgyC(+Yu޼el XJݹU$zl,I?ϢՓ}Ĭ!+k|!<̞%iSX{߉ÛWS^(s]͖=A5j*y#h}1`}Wű8m*fKk=dm^J}' e}CEXZ(ci1Cf4dFdO}IMC[ej;r=? ZsoO TIfc|e(y4lXV< Uk^<#$4BH l|9{#D2mlDek eE`͚#rɍ=Ņ2`֫ d}q5!IOEDT˧!c`;EGBC_ѯ/}ќ{|7,{c2АU'9o繈S/ Jfevoy:Z?b{뿿Fsyw%]|_?|Ԛ=XYҐMeU/I\+z2Zq/ޒ'eܖe|DZ,8bXLsGZUygY"J%apUNbY Yf+ط Vhƶ۸e,z5^ZDt7}|8| cQk֍51rG +hN3hƇW?*.dK:! H1`eGT0wHS͜e-t[V=}9>x 5X%{ԑ많'ŬU$(f/t eіO ͿG,y{Ś??q^j4$eg<]Փsְ=xm|vy{rw.cree٪$lcACC֐Wַa/һv_5uϚ49 kX$',q./1JNEӷa [b 6{۶G8|J-^VlI{}=ñ\-N?1gxj1*tHkUgjϞej5?ͨaW:Zt1+7 !>Ҟnbʚٵ]}Dtg]`֓5d1Zr˗^k'/ۏR~[cկ1,@1hdc/[U5䯿Z\Dk;_i~ ˗G:]Lq@"aKw[^$HX޹V.c{SڼnKccW%;B4qz)UշUUW .P-'{V[,D9[q ؾ㷿Q#V؃,ch,e&TU-KSS̎uֶ؍''S>9y(tYӏ4-˅I8^W5w)V>v{@"d]'ϲDKx%ޝu\kZD9)c7w0{[[y\~q%:W3gvn?8Y+3+f iACH5'닧!D3qܥlx-DQ?-ۻn XNXͫ:/^% v9p?|ND=kĶךa[2c4ӹ]cZg/d]s )8^˟mY/ED"a {֙[EmEwe l8s+*{mךȰ%"MgvKO<ƀ;.;#h)^f+6쟿|[pӥ.ܖ;7 x9gY#k-> }rmP8BVUU}g@N"O/8a8a3;Fе2[k墮"C#[fzmQjv8B֐mXk$~]Lm_"^{ Szs؂{zց>cqz,s\Zw`8g/c =9%"r1{a v󘈾{xt JP8OC𘇲G.px5X|?5ږel 厁HX}{Ad~w>RpſLK&'ovsG2zfW[yŬ&a-h'gWo^9+N^?ulۗ |?qyHXF ;wJQִeͶ}1bVY$Ƣgg@D$ZS9A.]IJXaWoY"bb"{݋gv&M}:8RCVooߏ)4=GTB㵘9/e76wLה(aٛ-. %W3޲zKw?;!ٶGD@&Җ7,ǫsV_@}9WUU/˗]۷fgX?e,]~˝SϢ2v7c576tE@&"aq1g9j}jg7IDɑ DdV"|K_2XUZrPKfXʸAX;7åojݫlwhՎܡ^Vo.(bjO/=7{✕>5|PXZ߃ӡ-ݱ@Yh(Sb[UU-eX">XMš;|!qtKB@D[GϝWGϝ_h/Oe rS./mu:OClݱG-vsP%[\̚4kwG4Ŭl|ױ>Nks[=' 4 +<,w.ˇ<Ɨo3\ZNX"(^DKpNeTPa6?nZ(;)6"g?RE zx5fwcE%c+r秏yؖ+6֬=0;K[9^y!wijأmɛ#'y~X5pwSkWttdÑzqv-|MԹ=]K%M 9wtAb[g>{һ~&g5ՙ޵c~n R%xԙ;7sNo 9D߀ցhP۵~9[%"Y"V{ooܢE͡( Yp'bY%>˺!c+M%=h9y%"a %"9d `99r3|RcǶ/t\m\yhJց/{|N_QEQuޭ&"rk'ϲDKn!+ hrVNkXYluա)_$ݏ|s㕧͙k\̊x=?24a$}ܬ09(\--w̓o de\.g}V<^'Me"gEˎH>]?s6ֳ'ֳ;vrQ%"Y9j9aEt9QGȹ`Xw!̜UIDAT |M&/ ŬHU2Vto X;a_\q[D +om'7d>rF XE&G. +^a7-e%yf2Ϫdضwo]e2-iiEw0aI:wYP$,@[y@Ȼ~jٛx/U};pqU\e,-_qAy"g5 [vw9,IGh߅+;wVIML',ld>•(P7qѹ_s|7 }•}Ѿ Wh8aHWdf k9U' $Nӌik*g*2:G'ebְQ`X&^͊YWA.fEu)ʗg2 4eTse˸t3k/&7Vq_9InjZb/ӊ+ k(q?qb猀ŬaS%-ջ>K&_D5dӡ>J/S&=F]EU!hyh(c}5|a#Ü=u-_Xa7_x>gE18KD;<} Y_Ϛ;{~͹a4fԫ 6i?h9ƕi@ JRs]x٘3;NJ8ŬE®  kֵ|,|Rop~.`Ej\usWfǝ"*VC+UBl6Kg4V,&0:xS1rOsjJ{<=NXya+a#yʚ^Q2g>*i{&qQ+'nl,9A [۳/mIq$I%h뉚<ٗAS!ZOO {Ufeط_HXCr1{7r7o9g9^\YÄ-/ƼhC411WG%d}CCDb$LM$ LYýWfQF{D{ ?' XN[9a)fM1˗x9;|3s9#\o "Wx<P/&qGRkSl덍귁Ԥ;WCH"8/nz&LNYJk~12=af⽧%]e(8h9yϚ%"aSev'pyY+Q6m#?s[*9C2Q g^zO$Nh[1 9 kx/iպWuX(OZ49 KD9gg֏iWx<zc_Ot-]|6г,!ed>[2֚?L6՟TFTHOcANسGV.C"a m>tk7_صb#78y~f}e+<H&)8룻( W?J9zvڌeVt DvHD#}2/;ç5LX۲gH{]Գ'yݠ1o#Q[pAFDP(M|.8g+'#',6 ȼ_~Iڻ8ya JhTEg~|yP:I㜕ô^{pIr;'-.nŲ4zZEo%2]DٗI#S _.>s5m5K {|9g58s5 [NN6mKUGr>]xC@}+YTl*os5gIJX fel犅<]$,_m&֐(f;;r XeW6KsJ|0-_<+<>:/h.jBSV.f'5vwhR$,_svqQ&\̊ztOj'}@b֢Adrq1[ g NӁ~1KXGD6w4X"ʏ!z`@U̕׌q1*Nӭ/N9a bVE 혝wBӻp̚2W6|iFE{p29 b.y>a#(l5PqEL8J!mD%u gstT̚հ4 e(OZf{|T fNaك\=,e J0=Ӡ}ޝ (6[CH9^BimW4NDe {勋;tpYXfc^mbc4(`/vع+%hBb`EAÑp$35+vcE [ \0ۡgO0YÄ[Jf[H(`x'[ _2JXG*Y-,E܁-]W(Bր@ X4c(`*%6.!dlBFY!dlBFY!dlBFY!dlBFY!dlr6~҃IENDB`plotmo/inst/slowtests/0000755000176200001440000000000014567071235014622 5ustar liggesusersplotmo/inst/slowtests/test.glmnet.R0000644000176200001440000004463113727235376017226 0ustar liggesusers# test.glmnet.R: glmnet tests for plotmo and plotres source("test.prolog.R") library(earth) library(glmnet) data(ozone1) data(etitanic) get.tit <- function() # abbreviated titanic data { tit <- etitanic pclass <- as.character(tit$pclass) # change the order of the factors so not alphabetical pclass[pclass == "1st"] <- "first" pclass[pclass == "2nd"] <- "class2" pclass[pclass == "3rd"] <- "classthird" tit$pclass <- factor(pclass, levels=c("class2", "classthird", "first")) # log age is so we have a continuous predictor even when model is age~. set.seed(2015) tit$logage <- log(tit$age) + rnorm(nrow(tit)) tit$parch <- NULL # by=12 gives us a small fast model with an additive and a interaction term tit <- tit[seq(1, nrow(etitanic), by=12), ] } plotmo1 <- function(object, ..., trace=0, SHOWCALL=TRUE, caption=NULL) { if(is.null(caption)) caption <- paste(deparse(substitute(object)), collapse=" ") call <- match.call(expand.dots=TRUE) call <- strip.space(paste(deparse(substitute(call)), collapse=" ")) printf("%s\n", call) plotmo(object, trace=trace, SHOWCALL=SHOWCALL, caption=caption, ...) } plotres1 <- function(object, ..., trace=0, SHOWCALL=TRUE, caption=NULL) { if(is.null(caption)) caption <- paste(deparse(substitute(object)), collapse=" ") call <- match.call(expand.dots=TRUE) call <- strip.space(paste(deparse(substitute(call)), collapse=" ")) printf("%s\n", call) plotres(object, trace=trace, SHOWCALL=SHOWCALL, caption=caption, ...) } tit <- get.tit() set.seed(2015) xmat <- as.matrix(tit[,c(2,5,6)]) set.seed(2015) mod.glmnet.xmat <- glmnet(xmat, tit[,4]) # plotmo on glmnet mods is boring but we test it anyway plotmo1(mod.glmnet.xmat) plotres1(mod.glmnet.xmat) # compare to plot.glmnet par(mfrow=c(4,2), mar=c(3,6,3.5,6)) # extra side margins for more square plots plot_glmnet(mod.glmnet.xmat, main="mod.glmnet.xmat\ncompare to plot.glmnet") plot(0,0) plot_glmnet(mod.glmnet.xmat, xvar="norm", col=c(3,2,1)) plot(mod.glmnet.xmat, xvar="norm") plot_glmnet(mod.glmnet.xmat, xvar="lambda") plot(mod.glmnet.xmat, xvar="lambda") plot_glmnet(mod.glmnet.xmat, xvar="dev") plot(mod.glmnet.xmat, xvar="dev") par(org.par) set.seed(2015) mod.cv.glmnet.xmat <- cv.glmnet(xmat, tit[,4], nfolds=3) # following was needed before plotmo 3.1.3 (before adding plotmo.prolog.cv.glmnet) # mod.cv.glmnet.xmat$x <- as.data.frame(xmat) # mod.cv.glmnet.xmat$y <- tit[,4] cat("==Test plotmo trace=1 and lambda.min\n") plotmo1(mod.cv.glmnet.xmat, predict.s="lambda.min", trace=1) cat("==Test plotmo trace=2 and lambda.min\n") plotmo1(mod.cv.glmnet.xmat, predict.s="lambda.min", trace=2) cat("==Test plotres trace=1 and lambda.1se\n") plotres1(mod.cv.glmnet.xmat, predict.s="lambda.1se", trace=1) cat("==Test plotres trace=2 and lambda.1se\n") plotres1(mod.cv.glmnet.xmat, predict.s="lambda.1se", trace=2) set.seed(2015) x <- matrix(rnorm(100*20),100,20) # 20 variables y <- rnorm(100) mod <- glmnet(x,y) plotmo1(mod) # test w1.label par(mfrow=c(2,3)) par(cex=1) par(mar=c(3,3,3,1)) plotres(mod, which=1, w1.main="default w1.label") plotres(mod, which=1, w1.label=5, w1.main="w1.label=5") plotres(mod, which=1, w1.label=0, w1.main="w1.label=0") plotres(mod, which=1, w1.label=TRUE, w1.main="w1.label=TRUE") plotres(mod, which=1, w1.label=100, w1.main="w1.label=100") par(org.par) # test w1 and non w1 args passed par(mfrow=c(2,2), mar=c(4,4,4,4), cex=1) plot_glmnet(mod, w1.col=3:4, w1.xvar="norm", main="plot_glmnet\nw1.col=3:4 w1.xvar=\"norm\"") plot_glmnet(mod, col=3:4, xvar="norm", main="plot_glmnet\ncol=3:4 xvar=\"norm\"") plot_glmnet(mod, col=3:4, w1.col=1:2, w1.xvar="norm", xvar="lambda", main="plot_glmnet\ncol=3:4 w1.col=1:2\nw1.xvar=\"norm\", xvar=\"lambda\"") par(org.par) par(mfrow=c(3,2), mar=c(3,4,4,4), cex=1) plotres(mod, which=c(1,3), do.par=FALSE, w1.col=3:4, w1.xvar="norm", w1.main="plotres\nw1.col=3:4 w1.xvar=\"norm\"") plotres(mod, which=c(1,3), do.par=FALSE, col=3:4, xvar="norm", w1.main="plotres\nplotres\ncol=3:4 xvar=\"norm\"") plotres(mod, which=c(1,3), do.par=FALSE, col=3:4, w1.col=1:2, w1.main="plotres\ncol=3:4 w1.col=1:2") par(org.par) # glmnet with sparse matrices set.seed(2015) n <- 100 p <- 20 nzc <- trunc(p/10) x <- matrix(rnorm(n*p),n,p) iz <- sample(1:(n*p),size=n*p*.85,replace=FALSE) x[iz] <- 0 sx <- Matrix(x,sparse=TRUE) # colnames(sx) <- paste("x", 1:ncol(sx), sep="") # need column names for plotmo inherits(sx,"sparseMatrix") # confirm that it is sparse beta <- rnorm(nzc) fx <- x[,seq(nzc)]%*%beta eps <- rnorm(n) y <- fx+eps px <- exp(fx) px <- px/(1+px) ly <- rbinom(n=length(px),prob=px,size=1) mod.glmnet.sx <- glmnet(sx,y) plotmo1(mod.glmnet.sx, all2=TRUE) # will give warning: too many predictors to plot all pairs plotmo1(mod.glmnet.sx, all2=2, caption="all2=2") # test all2=2 plotmo1(mod.glmnet.sx, all2=2, degree2=1:3, caption="all2=2 degree2=1:3") plotres(mod.glmnet.sx) par(org.par) par(mfrow=c(2,4), mar=c(3,3,3,1), mgp=c(1.5,0.5,0), oma=c(0,0,2.5,0)) y <- trees$Volume x <- as.matrix(data.frame(Girth=trees$Girth, Height=trees$Height)) glmnet <- glmnet(x, y) plotres(glmnet, do.par=FALSE, caption="glmnet and lm: top and bottom should be the same") lm <- lm(Volume~., data=trees) plotres(lm, do.par=FALSE, SHOWCALL=TRUE) par(mfrow=c(3,2), mar=c(3,3,3,1), mgp=c(1.5,0.5,0), oma=c(0,0,2.5,0)) plotres(glmnet, do.par=FALSE, which=c(1,3), w1.xvar="norm", caption="glmnet with various options", SHOWCALL=TRUE) plotres(glmnet, trace=1, do.par=FALSE, which=c(1,3), SHOWCALL=TRUE) plotres(glmnet, trace=1, do.par=FALSE, which=c(1,3), predict.s=5, SHOWCALL=TRUE) par(org.par) printf("======== glmnet additional tests\n") set.seed(2015) p <- 10 n <- 30 x <- cbind(matrix(rnorm(n*p),n,p)) y <- rowSums(x[,1:3]^3) glmnet <- glmnet(x,y) plotres(glmnet, SHOWCALL=TRUE, caption="glmnet: y <- rowSums(x[,1:3]^3)") plotres(glmnet, SHOWCALL=TRUE, w1.xvar="norm") par(mfrow=c(1,1)) omar <- par("mar") ocex.axis <- par("cex.axis") ocex.lab <- par("cex.lab") plotres(glmnet, SHOWCALL=TRUE, which=1) stopifnot(par("mar") == omar) stopifnot(par("cex.axis") == ocex.axis) stopifnot(par("cex.lab") == ocex.lab) par(org.par) # test some args for plot_glmnet plotres(glmnet, predict.s=.05, SHOWCALL=TRUE, trace=0, col.main=2, w1.xlab="my xlab", w1.ylab="my ylab", w1.main="test some args for plot_glmnet1", w1.col=4:1) plot_glmnet(glmnet, trace=0, col.main=2, main="test some args for plot_glmnet2", xlab="my xlab", ylab="my ylab", col=4:1, ylim=c(-2,4)) # TODO xlim=c(-5,3)) plotres(glmnet, predict.s=.05, SHOWCALL=TRUE, which=c(1,3), grid.col="gray", do.par=2) plotres(glmnet, predict.s=.05, SHOWCALL=TRUE, which=c(1,3), w1.s.col=0, do.par=0) par(org.par) # TODO the following issues a stream of warnings: restarting interrupted promise evaluation expect.err(try(plotres(glmnet, w1.col=nonesuch)), "cannot evaluate 'col'") printf("======== glmnet multinomial (multnet)\n") par(mfrow=c(4,4), mar=c(3,3,3,1)) set.seed(2016) n <- 200 p <- 4 x <- matrix(rnorm(n*p), n, p) colnames(x) <- paste("x", 1:ncol(x), sep="") # "1" is correlated with x[,1], "4" is correlated with x[,2], "2" and "3" not correlated y <- ifelse(x[,1] > 0.5, 1, ifelse(x[,2] > 0.0, 4, sample(c(2,3), size=nrow(x), replace=TRUE))) print(cov(x, y)) y <- factor(y) # TODO Following causes the following warning: # Warning: from glmnet Fortran code (error code -90); Convergence for 90th lambda value not reached after maxit=100000 iterations; solutions for larger lambdas returned multinomial.mod <- glmnet(x, y, family="multinomial") plotres(multinomial.mod, nresponse=1, w1.main="nresponse=1", main="family=\"multinomial\"", smooth.col=0, info=TRUE, trace=0, which=c(1,3), do.par=FALSE, xlim=c(-.2,1.2), ylim=c(-1.2, 1.2)) plotres(multinomial.mod, nresponse=2, w1.main="nresponse=2", smooth.col=0, info=TRUE, trace=0, which=c(1,3), do.par=FALSE, xlim=c(-.2,1.2), ylim=c(-1.2, 1.2)) plotres(multinomial.mod, nresponse=3, w1.main="nresponse=3", smooth.col=0, info=TRUE, trace=0, which=c(1,3), do.par=FALSE, xlim=c(-.2,1.2), ylim=c(-1.2, 1.2)) plotres(multinomial.mod, nresponse=4, w1.main="nresponse=4", smooth.col=0, info=TRUE, trace=0, which=c(1,3), do.par=FALSE, xlim=c(-.2,1.2), ylim=c(-1.2, 1.2)) plotmo(multinomial.mod, nresponse=1, trace=0, do.par=FALSE, degree1=1:2) plotmo(multinomial.mod, nresponse=2, trace=0, do.par=FALSE, degree1=1:2) par(mgp=c(1.5, .4, 0)) plot(multinomial.mod, xvar="norm") # compare to plot.glmnet par(org.par) # compare to earth par(mfrow=c(4,3), mar=c(3,3,1,1)) yfac <- factor(c("a","b","c","d")[y]) earth.mod <- earth(x, yfac, trace=0) plotres(earth.mod, nresponse=1, main=sprint("multiresponse\nnresponse=1 rsq %.2g", earth.mod$rsq.per.response[1]), which=3, xlim=c(-.2, 1.2), ylim=c(-1.2, 1.2), smooth.col=0, info=TRUE, do.par=FALSE, trace=0, jitter=7, cex.response=.7) plotmo(earth.mod, nresponse=1, do.par=FALSE) plotres(earth.mod, nresponse=2, main=sprint("nresponse=2 rsq %.2g", earth.mod$rsq.per.response[2]), which=3, xlim=c(-.2, 1.2), ylim=c(-1.2, 1.2), smooth.col=0, info=TRUE, do.par=FALSE, trace=0, jitter=7, cex.response=.7) plotmo(earth.mod, nresponse=2, do.par=FALSE) plotres(earth.mod, nresponse=3, main=sprint("nresponse=3 rsq %.2g", earth.mod$rsq.per.response[3]), which=3, xlim=c(-.2, 1.2), ylim=c(-1.2, 1.2), smooth.col=0, info=TRUE, do.par=FALSE, trace=0, jitter=7, cex.response=.7) plotmo(earth.mod, nresponse=3, do.par=FALSE) plotres(earth.mod, nresponse=4, main=sprint("nresponse=4 rsq %.2g", earth.mod$rsq.per.response[4]), which=3, xlim=c(-.2, 1.2), ylim=c(-1.2, 1.2), smooth.col=0, info=TRUE, do.par=FALSE, trace=0, jitter=7, cex.response=.7) plotmo(earth.mod, nresponse=4, do.par=FALSE) print(summary(earth.mod)) par(org.par) printf("======== binomial model\n") set.seed(2019) n <- 50 p <- 4 x <- matrix(rnorm(n*p), n, p) colnames(x) <- paste("x", 1:ncol(x), sep="") y <- ifelse(x[,1] + x[,2] + .1 * rnorm(n) > .5, TRUE, FALSE) print(cov(x, y)) y <- factor(y) glmnet.binomial <- glmnet(x, y, family="binomial") par(mfrow=c(2,3), mar=c(3,3,1,1)) plotres(glmnet.binomial, info=T, predict.s=.02, which=c(1,3), do.par=FALSE, w1.main="glmnet.binomial") plot(glmnet.binomial) earth.mod <- earth(x, y) set.seed(2019) plotres(earth.mod, info=T, which=c(1,3), do.par=FALSE) par(org.par) par(mfrow=c(2,4), mar=c(3,3,1,1)) set.seed(2019) plotmo(glmnet.binomial, do.par=FALSE) plotmo(earth.mod, do.par=FALSE, main="binomial earth.mod") par(org.par) printf("======== glmnet family=\"mgaussian\"\n") set.seed(2015) p <- 10 n <- 30 x <- cbind((1:n)/n, matrix(rnorm(n*(p-1)),n,p-1)) colnames(x) <- paste0("x", 1:p) # ymultresp <- cbind(rowSums(x[,1:5]^3), rowSums(x[,5:p]^3), 1:n) set.seed(1) ymultresp <- cbind(x[,1]+.001*rnorm(n), rowSums(x[,2:5]^3), rnorm(n)) glmnet.mgaussian <- glmnet(x, ymultresp, family="mgaussian") plotres(glmnet.mgaussian, nresponse=1, SHOWCALL=TRUE, which=c(1:3), do.par=2, info=1) # manually calculate the residuals plot(x=predict(glmnet.mgaussian, newx=x, s=0)[,1,1], y=ymultresp[,1] - predict(glmnet.mgaussian, newx=x, s=0)[,1,1], pch=20, xlab="Fitted", ylab="Residuals", main="Manually calculated residuals, nresponse=1, s=0") abline(h=0, col="gray") par(org.par) plotres(glmnet.mgaussian, nresponse=2, SHOWCALL=TRUE, which=c(1:3), do.par=2, info=1) # manually calculate the residuals plot(x=predict(glmnet.mgaussian, newx=x, s=0)[,2,1], y=ymultresp[,2] - predict(glmnet.mgaussian, newx=x, s=0)[,2,1], pch=20, xlab="Fitted", ylab="Residuals", main="Manually calculated residuals, nresponse=2, s=0") abline(h=0, col="gray") par(org.par) plotmo(glmnet.mgaussian, nresponse=1, SHOWCALL=TRUE) plotmo(glmnet.mgaussian, nresponse=2, SHOWCALL=TRUE) graphics::par(mfrow=c(2,2), mgp=c(1.5,0.4,0), tcl=-0.3, cex.main=1, font.main=1, mar=c(4,3,1.2,0.8), oma=c(0,0,4,0), cex=0.83) plotres(glmnet.mgaussian, nresponse=2, SHOWCALL=TRUE, which=3, do.par=FALSE, caption="glmnet.mgaussian compare to manually calculated residuals") plot(x=predict(glmnet.mgaussian, newx=x, s=0)[,2,1], y=ymultresp[,2] - predict(glmnet.mgaussian, newx=x, s=0)[,2,1], pch=20, xlab="Fitted", ylab="Residuals", main="Manual residuals, nresponse=2, s=0") abline(h=0, col="gray") plotres(glmnet.mgaussian, nresponse=2, predict.s=.5, SHOWCALL=TRUE, which=3, do.par=FALSE) plot(x=predict(glmnet.mgaussian, newx=x, s=.5)[,2,1], y=ymultresp[,2] - predict(glmnet.mgaussian, newx=x, s=.5)[,2,1], pch=20, xlab="Fitted", ylab="Residuals", main="Manual residuals, nresponse=2, s=.5") abline(h=0, col="gray") plotres(glmnet.mgaussian, predict.s=.05, nresponse=3, info=TRUE, SHOWCALL=TRUE) # essentially random par(org.par) par(mfrow=c(2,3), mar=c(3,3,3,.5), oma=c(0,0,3,0), mgp=c(1.5,0.4,0), tcl=-0.3) data(trees) set.seed(2015) # variable with a long name x50 <- cbind(trees[,1:2], Girth12345678901234567890=rnorm(nrow(trees))) mod.with.long.name <- glmnet(data.matrix(x50),data.matrix(trees$Volume)) plotres(mod.with.long.name, which=1, caption="test plot_glmnet with x50 and x60") # one inactive variable (all coefs are zero for variable "rand") set.seed(2015) x60 <- cbind(trees[,1], rand=rnorm(nrow(trees)), trees[,2]) # complicate the issue: use an unnamed column (column 3) colnames(x60) <- c("Girth", "rand", "") mod.with.inactive.var <- glmnet(data.matrix(x60),data.matrix(trees$Volume)) mod.with.inactive.var$beta["rand",] = 0 # TODO hack force inactive variable plotres(mod.with.inactive.var, which=1) plotres(mod.with.inactive.var, which=1, w1.xvar="norm") # compare to plot.glmnet (but note that labels aren't always plotted unless par=c(1,1)?) plot(mod.with.inactive.var, xvar="norm", label=TRUE) # plotmo calls the unnamed column "x3", fair enough plotmo(mod.with.inactive.var, do.par=FALSE, pt.col=2) # single active variable x70 <- cbind(trees[,1,drop=F], 0) a <- glmnet(data.matrix(x70), data.matrix(trees$Volume)) par(org.par) par(mfrow=c(2,2), mar=c(3,3,2,4)) plotres(a, which=1, predict.s=1, caption="single active variable") plotres(a, which=1, w1.xvar="norm") plotres(a, which=1, w1.xvar="lambda") plotres(a, which=1, w1.xvar="dev") #--- test interaction of w1. and non w1 args ------------------------------------- #--- glmnet model, which=1 --- par(org.par) par(mfrow=c(4,3), mar=c(3, 3, 4, 1), mgp=c(2, 0.6, 0)) plotres(mod.glmnet.xmat, which=1, w1.xlim=c(6,-6), w1.ylim=c(-5,5), w1.col=1:2, w1.main="TEST INTERACTION OF W1 ARGS PAGE 1 (which=1)\n\nwhich=1 w1.xlim=c(6,-6)\nw1.ylim=c(-5,5)) w1.col=1:2,") plotres(mod.glmnet.xmat, which=1, cex.main=1.2, xlim=c(9,-9), ylim=c(-60,60), col=3:4, w1.main="which=1 xlim=c(9,-9)\nylim=c(-60,60)) col=3:4,") plotres(mod.glmnet.xmat, which=1, cex.main=1, xlim=c(9,-9), w1.xlim=c(6,-6), ylim=c(-60,60), w1.ylim=c(-5,5), w1.col=1:2, col=3:4, w1.main="which=1 xlim=c(9,-9), w1.xlim=c(6,-6)\nylim=c(-60,60), w1.ylim=c(-5,5)) w1.col=1:2, col=3:4") #--- glmnet model, which=c(1,3,4) --- plotres(mod.glmnet.xmat, which=c(1,3,4), cex.main=1, ylim=c(-70,70), xlim=c(-20, 60), col=2:3, do.par=FALSE, w1.main="TEST INTERACTION OF W1 ARGS PAGE 1 (which=c(1,3,4))\nlim=c(-70,70), xlim=c(-20, 60)") plotres(mod.glmnet.xmat, which=c(1,3,4), cex.main=1.2, ylim=c(-70,70), xlim=c(-20, 60), qq.xlim=c(-7,5), col=2:3, do.par=FALSE, w1.main="ylim=c(-70,70), xlim=c(-20, 60)\nqq.xlim=c(-7,5)") plotres(mod.glmnet.xmat, which=c(1,3,4), cex.main=1.2, w1.ylim=c(-7,7), w1.xlim=c(4,-4), col=2:3, do.par=FALSE, w1.main="w1.ylim=c(-7,7), w1.xlim=c(4,-4)") # plotres(mod.glmnet.xmat, which=c(1,3,4), cex.main=.9, # w1.ylim=c(-7,7), ylim=c(-20,20), # qq.xlim=c(-7,5), col=2:3, do.par=FALSE, # qq.ylim=c(-100,100), # main="w1.ylim=c(-7,7) ylim=c(-20,20)\nqq.xlim=c(-7,5) qq.ylim=c(-100,100)") par(org.par) par(mfrow=c(3,3), mar=c(3, 3, 4, 1), mgp=c(2, 0.6, 0)) plotres(mod.glmnet.xmat, which=c(1,3,4), do.par=FALSE, # w1.main="which=c(1,3,4)", w1.xlim=c(6,-6), w1.ylim=c(-5,5), w1.col=2:3, w1.main="TEST INTERACTION OF W1 ARGS PAGE 2\n\nwhich=c(1,3,4) w1.xlim=c(6,-6)\nw1.ylim=c(-5,5)) w1.col=2:3") plotres(mod.glmnet.xmat, which=c(1,3,4), w1.cex.main=1, do.par=FALSE, # w1.main="which=c(1,3,4)", xlim=c(-20,70), ylim=c(-60,60), w1.col=2:3, col=3:4, w1.main="which=c(1,3,4) ylim=c(-60,60))\nw1.col=2:3, col=3:4") plotres(mod.glmnet.xmat, which=c(1,3,4), w1.cex.main=1, do.par=FALSE, # w1.main="which=c(1,3,4)", xlim=c(-20,70), w1.xlim=c(6,-6), ylim=c(-60,60), w1.ylim=c(-5,5), col=3:4, w1.main="which=c(1,3,4) xlim=c(9,-9), w1.xlim=c(6,-6)\nylim=c(-60,60), w1.ylim=c(-5,5)) w1.col=1:2, col=3:4") par(org.par) #-- make sure that we can work with all families set.seed(2016) par(mfrow=c(3,3), mar=c(3,3,3,1)) n <- 100 p <- 4 x <- matrix(rnorm(n*p), n, p) g2 <- sample(1:2, n, replace=TRUE) for(family in c("gaussian","binomial","poisson")) { mod <- glmnet(x,g2,family=family) plot(mod, xvar="lambda") plotres(mod, w1.xvar="lambda", main=paste("family", family), which=c(1,3), do.par=FALSE) } # cox library(plotmo) n <- 100 p <- 20 nzc <- trunc(p/10) set.seed(2016) beta <- rnorm(nzc) x7 <- matrix(rnorm(n*p), n, p) beta <- rnorm(nzc) fx <- x7[,seq(nzc)] %*% beta/3 hx <- exp(fx) ty <- rexp(n, hx) tcens <- rbinom(n=n, prob=.3, size=1)# censoring indicator y <- cbind(time=ty, status=1-tcens) # y=Surv(ty,1-tcens) with library(survival) glmnet.cox <- glmnet(x=x7, y=y, family="cox") plot(glmnet.cox) title("glmnet.cox", line=2) plot_glmnet(glmnet.cox, xvar="norm") plotres(glmnet.cox, which=3, do.par=FALSE) par(org.par) # test col argument par(mfrow=c(2,3), mar=c(3,3,5,1), cex=1) mod <- glmnet(as.matrix(mtcars[-1]), mtcars[,1]) plot_glmnet(mod, main="plot_glmnet default") plot_glmnet(mod, col=c(1,2,3,0,0,NA,0,0,0,0), main="col=c(1,2,3,0,0,NA,0,0,0,0)") g <- "gray" plot_glmnet(mod, col=c("black","red","green",g,g,g,g,g,"steelblue","darkorange"), main="col=c('black','red','green',g,g,g,g,g,'steelblue','darkorange')") plot_glmnet(mod, col=c("black","red","green",0,0,0,0,0,"steelblue","darkorange"), main="col=c('black','red','green',0,0,0,0,0,'steelblue','darkorange')") plot_glmnet(mod, col=c("black","red", 0), main="col=c('black','red', 0)") # test recycling, including 0 par(org.par) source("test.epilog.R") plotmo/inst/slowtests/test.prolog.R0000644000176200001440000000310513727235376017231 0ustar liggesusers# test.prolog.R # A safe version of sprintf. # Like sprintf except that %s on NULL prints "NULL" rather than # preventing the entire string from being printed # # e.g. sprintf("abc %s def", NULL) returns an empty string -- a silent failure! # but sprint("abc %s def", NULL) returns "abc NULL def" # # e.g. sprintf("abc %d def", NULL) returns an empty string! # but sprint("abc %d def", NULL) causes an error msg (not a silent failure) sprint <- function(fmt, ...) { dots <- list(...) dots <- lapply(dots, function(e) if(is.null(e)) "NULL" else e) do.call(sprintf, c(fmt, dots)) } printf <- function(fmt, ...) cat(sprint(fmt, ...), sep="") cat0 <- function(...) cat(..., sep="") strip.space <- function(s) gsub("[ \t\n]", "", s) # test that we got an error as expected from a try() call expect.err <- function(object, expected.msg="") { if(class(object)[1] != "try-error") stop("Did not get expected error: ", expected.msg) else { msg <- attr(object, "condition")$message[1] if(length(grep(expected.msg, msg, fixed=TRUE))) cat0("Got expected error from ", deparse(substitute(object)), "\n") else stop(sprint("Expected: %s\n Got: %s", expected.msg, substr(msg[1], 1, 1000))) } } empty.plot <- function() { plot(0, 0, col=0, bty="n", xaxt="n", yaxt="n", xlab="", ylab="", main="") } options(warn=1) # print warnings as they occur if(!interactive()) postscript(paper="letter") org.par <- par(no.readonly=TRUE) set.seed(2020) plotmo/inst/slowtests/test.glmnet.Rout.save0000644000176200001440000013550014567065443020706 0ustar liggesusers> # test.glmnet.R: glmnet tests for plotmo and plotres > > source("test.prolog.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix > library(glmnet) Loading required package: Matrix Loaded glmnet 4.1-8 > data(ozone1) > data(etitanic) > get.tit <- function() # abbreviated titanic data + { + tit <- etitanic + pclass <- as.character(tit$pclass) + # change the order of the factors so not alphabetical + pclass[pclass == "1st"] <- "first" + pclass[pclass == "2nd"] <- "class2" + pclass[pclass == "3rd"] <- "classthird" + tit$pclass <- factor(pclass, levels=c("class2", "classthird", "first")) + # log age is so we have a continuous predictor even when model is age~. + set.seed(2015) + tit$logage <- log(tit$age) + rnorm(nrow(tit)) + tit$parch <- NULL + # by=12 gives us a small fast model with an additive and a interaction term + tit <- tit[seq(1, nrow(etitanic), by=12), ] + } > plotmo1 <- function(object, ..., trace=0, SHOWCALL=TRUE, caption=NULL) { + if(is.null(caption)) + caption <- paste(deparse(substitute(object)), collapse=" ") + call <- match.call(expand.dots=TRUE) + call <- strip.space(paste(deparse(substitute(call)), collapse=" ")) + printf("%s\n", call) + plotmo(object, trace=trace, SHOWCALL=SHOWCALL, caption=caption, ...) + } > plotres1 <- function(object, ..., trace=0, SHOWCALL=TRUE, caption=NULL) { + if(is.null(caption)) + caption <- paste(deparse(substitute(object)), collapse=" ") + call <- match.call(expand.dots=TRUE) + call <- strip.space(paste(deparse(substitute(call)), collapse=" ")) + printf("%s\n", call) + plotres(object, trace=trace, SHOWCALL=SHOWCALL, caption=caption, ...) + } > tit <- get.tit() > set.seed(2015) > xmat <- as.matrix(tit[,c(2,5,6)]) > set.seed(2015) > mod.glmnet.xmat <- glmnet(xmat, tit[,4]) > # plotmo on glmnet mods is boring but we test it anyway > plotmo1(mod.glmnet.xmat) plotmo1(object=mod.glmnet.xmat) plotmo grid: survived sibsp logage 0 0 3.06991 > plotres1(mod.glmnet.xmat) plotres1(object=mod.glmnet.xmat) > > # compare to plot.glmnet > par(mfrow=c(4,2), mar=c(3,6,3.5,6)) # extra side margins for more square plots > plot_glmnet(mod.glmnet.xmat, main="mod.glmnet.xmat\ncompare to plot.glmnet") > plot(0,0) > plot_glmnet(mod.glmnet.xmat, xvar="norm", col=c(3,2,1)) > plot(mod.glmnet.xmat, xvar="norm") > plot_glmnet(mod.glmnet.xmat, xvar="lambda") > plot(mod.glmnet.xmat, xvar="lambda") > plot_glmnet(mod.glmnet.xmat, xvar="dev") > plot(mod.glmnet.xmat, xvar="dev") > par(org.par) > > set.seed(2015) > mod.cv.glmnet.xmat <- cv.glmnet(xmat, tit[,4], nfolds=3) > > # following was needed before plotmo 3.1.3 (before adding plotmo.prolog.cv.glmnet) > # mod.cv.glmnet.xmat$x <- as.data.frame(xmat) > # mod.cv.glmnet.xmat$y <- tit[,4] > > cat("==Test plotmo trace=1 and lambda.min\n") ==Test plotmo trace=1 and lambda.min > plotmo1(mod.cv.glmnet.xmat, predict.s="lambda.min", trace=1) plotmo1(object=mod.cv.glmnet.xmat,predict.s="lambda.min",trace=1) stats::predict(cv.glmnet.object, matrix[3,3], type="response", s="lambda.min") stats::fitted(object=cv.glmnet.object) fitted() was unsuccessful, will use predict() instead got model response from getCall(object)$y plotmo grid: survived sibsp logage 0 0 3.06991 > cat("==Test plotmo trace=2 and lambda.min\n") ==Test plotmo trace=2 and lambda.min > plotmo1(mod.cv.glmnet.xmat, predict.s="lambda.min", trace=2) plotmo1(object=mod.cv.glmnet.xmat,predict.s="lambda.min",trace=2) plotmo trace 2: plotmo(object, trace=trace, SHOWCALL=SHOWCALL, caption=caption, ...) --get.model.env for object with class cv.glmnet object call is cv.glmnet(x=xmat, y=tit[, 4], nfolds=3) assuming the environment of the cv.glmnet model is that of plotmo's caller: env(..., call, caption, object, SHOWCALL, trace) --plotmo_prolog for cv.glmnet object 'object' --plotmo_x for cv.glmnet object get.object.x: object$x is NULL (and it has no colnames) object call is cv.glmnet(x=xmat, y=tit[, 4], nfolds=3) get.x.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$x, env(..., call, caption, object, SHOWCALL, trace)) getCall(object)$x is usable and has column names survived sibsp logage plotmo_x returned[88,3]: survived sibsp logage 1 1 0 1.821847 13 1 0 3.814495 26 0 0 3.094392 ... 0 0 5.950193 1308 0 0 5.116245 ----Metadata: plotmo_predict with nresponse=NULL and newdata=NULL plotmo_predict with NULL newdata (nrows=3), using plotmo_x to get the data --plotmo_x for cv.glmnet object get.object.x: object$x is NULL (and it has no colnames) object call is cv.glmnet(x=xmat, y=tit[, 4], nfolds=3) get.x.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$x, env(..., call, caption, object, SHOWCALL, trace)) getCall(object)$x is usable and has column names survived sibsp logage plotmo_x returned[88,3]: survived sibsp logage 1 1 0 1.821847 13 1 0 3.814495 26 0 0 3.094392 ... 0 0 5.950193 1308 0 0 5.116245 will use the above data instead of newdata=NULL for predict.cv.glmnet stats::predict(cv.glmnet.object, matrix[3,3], type="response", s="lambda.min") predict returned[3,1]: s="lambda.min" 1 25.64083 13 34.58457 26 31.45755 predict after processing with nresponse=NULL is [3,1]: s="lambda.min" 1 25.64083 13 34.58457 26 31.45755 ----Metadata: plotmo_fitted with nresponse=NULL stats::fitted(object=cv.glmnet.object) fitted() was unsuccessful, will use predict() instead plotmo_predict with NULL newdata, using plotmo_x to get the data --plotmo_x for cv.glmnet object get.object.x: object$x is NULL (and it has no colnames) object call is cv.glmnet(x=xmat, y=tit[, 4], nfolds=3) get.x.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$x, env(..., call, caption, object, SHOWCALL, trace)) getCall(object)$x is usable and has column names survived sibsp logage plotmo_x returned[88,3]: survived sibsp logage 1 1 0 1.821847 13 1 0 3.814495 26 0 0 3.094392 ... 0 0 5.950193 1308 0 0 5.116245 will use the above data instead of newdata=NULL for predict.cv.glmnet stats::predict(cv.glmnet.object, matrix[88,3], type="response", s="lambda.min") predict returned[88,1]: s="lambda.min" 1 25.64083 13 34.58457 26 31.45755 ... 44.27544 1308 40.53237 predict after processing with nresponse=NULL is [88,1]: s="lambda.min" 1 25.64083 13 34.58457 26 31.45755 ... 44.27544 1308 40.53237 got fitted values by calling predict (see above) ----Metadata: plotmo_y with nresponse=NULL --plotmo_y with nresponse=NULL for cv.glmnet object get.object.y: object$y is NULL (and it has no colnames) object call is cv.glmnet(x=xmat, y=tit[, 4], nfolds=3) get.y.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$y, env(..., call, caption, object, SHOWCALL, trace)) getCall(object)$y is usable but without colnames so we will keep on searching names(call) is "" "x" "y" "nfolds" the name of argument 2 is "y" so we will not process it with argn object$y is NULL call$y is usable but without colnames but we will use it anyway plotmo_y returned[88,1] with no column names: 1 29 2 24 3 25 ... 41 88 27 plotmo_y after processing with nresponse=NULL is [88,1] with no column names: 1 29 2 24 3 25 ... 41 88 27 converted nresponse=NA to nresponse=1 nresponse=1 (was NA) ncol(fitted) 1 ncol(predict) 1 ncol(y) 1 ----Metadata: plotmo_y with nresponse=1 --plotmo_y with nresponse=1 for cv.glmnet object get.object.y: object$y is NULL (and it has no colnames) object call is cv.glmnet(x=xmat, y=tit[, 4], nfolds=3) get.y.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$y, env(..., call, caption, object, SHOWCALL, trace)) getCall(object)$y is usable but without colnames so we will keep on searching names(call) is "" "x" "y" "nfolds" the name of argument 2 is "y" so we will not process it with argn object$y is NULL call$y is usable but without colnames but we will use it anyway got model response from getCall(object)$y plotmo_y returned[88,1] with no column names: 1 29 2 24 3 25 ... 41 88 27 plotmo_y after processing with nresponse=1 is [88,1]: plotmo_y 1 29 2 24 3 25 ... 41 88 27 got response name "s="lambda.min"" from yhat resp.levs is NULL ----Metadata: done number of x values: survived 2 sibsp 5 logage 88 ----plotmo_singles for cv.glmnet object singles: 1 survived, 2 sibsp, 3 logage ----plotmo_pairs for cv.glmnet object Error in formula.default(object) : invalid formula formula(object) failed for cv.glmnet object in plotmo.pairs.default Error in x$terms %||% attr(x, "terms") %||% stop("no terms component nor attribute") : no terms component nor attribute terms(object) failed for cv.glmnet object in plotmo.pairs.default no pairs graphics::par(mfrow=c(2,2), mgp=c(1.5,0.4,0), tcl=-0.3, font.main=2, mar=c(3,2,1.2,0.8), oma=c(0,0,4,0), cex.main=1.2, cex.lab=1, cex.axis=1, cex=0.83) ----Figuring out ylim --get.ylim.by.dummy.plots --plot.degree1(draw.plot=FALSE) degree1 plot1 (pmethod "plotmo") variable survived newdata[2,3]: survived sibsp logage 1 0 0 3.06991 2 1 0 3.06991 stats::predict(cv.glmnet.object, matrix[2,3], type="response", s="lambda.min") predict returned[2,1]: s="lambda.min" 1 31.34766 2 31.24259 predict after processing with nresponse=1 is [2,1]: s="lambda.min" 1 31.34766 2 31.24259 Reducing trace level for subsequent degree1 plots degree1 plot2 (pmethod "plotmo") variable sibsp degree1 plot3 (pmethod "plotmo") variable logage --done get.ylim.by.dummy.plots ylim c(4.856, 44.28) clip TRUE --plot.degree1(draw.plot=TRUE) plotmo grid: survived sibsp logage 0 0 3.06991 graphics::plot.default(x=c(0,0.5,0.5,1), y=c(31.35,31.35,3...), type="n", main="1 survived", xlab="", ylab="", xaxt="s", yaxt="s", xlim=c(-0.1,1.1), ylim=c(4.86,44.28)) > cat("==Test plotres trace=1 and lambda.1se\n") ==Test plotres trace=1 and lambda.1se > plotres1(mod.cv.glmnet.xmat, predict.s="lambda.1se", trace=1) plotres1(object=mod.cv.glmnet.xmat,predict.s="lambda.1se",trace=1) stats::residuals(object=cv.glmnet.object, type="response") residuals() was unsuccessful, will use predict() instead stats::predict(cv.glmnet.object, matrix[3,3], type="response", s="lambda.1se") stats::fitted(object=cv.glmnet.object) fitted() was unsuccessful, will use predict() instead got model response from getCall(object)$y graphics::plot(cv.glmnet.object) training rsq 0.24 > cat("==Test plotres trace=2 and lambda.1se\n") ==Test plotres trace=2 and lambda.1se > plotres1(mod.cv.glmnet.xmat, predict.s="lambda.1se", trace=2) plotres1(object=mod.cv.glmnet.xmat,predict.s="lambda.1se",trace=2) plotres trace 2: plotres(object, trace=trace, SHOWCALL=SHOWCALL, caption=caption, ...) --get.model.env for object with class cv.glmnet object call is cv.glmnet(x=xmat, y=tit[, 4], nfolds=3) assuming the environment of the cv.glmnet model is that of plotres's caller: env(..., call, caption, object, SHOWCALL, trace) --plotmo_prolog for cv.glmnet object 'object' ----Metadata: plotmo_resids(object, type="response", nresponse=NULL) doTryCatch invoked call.dots TRACE plotmo_resids via try called call.dots(residuals, DROP="*", KEEP="PREFIX", TRACE=if(trace==0)-1elsetr...), force.object=object, force.type=residtype, SHOWCALL=TRUE, predict.s="lambda.1se") PREFIX residuals. DROP .* KEEP >STANDARDPREFIXES|^force\.|^def\.|^drop\. >PREFIX|^residuals\. >CALLARGS|^force\.object$|^force\.type$ >EXPLICIT input dotnames force.object force.type SHOWCALL predict.s after DROP and KEEP force.object force.type return dotnames object type stats::residuals(object=cv.glmnet.object, type="response") residuals() was unsuccessful, will use predict() instead ----Metadata: plotmo_predict with nresponse=NULL and newdata=NULL plotmo_predict with NULL newdata (nrows=3), using plotmo_x to get the data --plotmo_x for cv.glmnet object get.object.x: object$x is NULL (and it has no colnames) object call is cv.glmnet(x=xmat, y=tit[, 4], nfolds=3) get.x.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$x, env(..., call, caption, object, SHOWCALL, trace)) getCall(object)$x is usable and has column names survived sibsp logage plotmo_x returned[88,3]: survived sibsp logage 1 1 0 1.821847 13 1 0 3.814495 26 0 0 3.094392 ... 0 0 5.950193 1308 0 0 5.116245 will use the above data instead of newdata=NULL for predict.cv.glmnet stats::predict(cv.glmnet.object, matrix[3,3], type="response", s="lambda.1se") predict returned[3,1]: s="lambda.1se" 1 26.57900 13 33.26779 26 30.85060 predict after processing with nresponse=NULL is [3,1]: s="lambda.1se" 1 26.57900 13 33.26779 26 30.85060 ----Metadata: plotmo_fitted with nresponse=NULL stats::fitted(object=cv.glmnet.object) fitted() was unsuccessful, will use predict() instead plotmo_predict with NULL newdata, using plotmo_x to get the data --plotmo_x for cv.glmnet object get.object.x: object$x is NULL (and it has no colnames) object call is cv.glmnet(x=xmat, y=tit[, 4], nfolds=3) get.x.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$x, env(..., call, caption, object, SHOWCALL, trace)) getCall(object)$x is usable and has column names survived sibsp logage plotmo_x returned[88,3]: survived sibsp logage 1 1 0 1.821847 13 1 0 3.814495 26 0 0 3.094392 ... 0 0 5.950193 1308 0 0 5.116245 will use the above data instead of newdata=NULL for predict.cv.glmnet stats::predict(cv.glmnet.object, matrix[88,3], type="response", s="lambda.1se") predict returned[88,1]: s="lambda.1se" 1 26.57900 13 33.26779 26 30.85060 ... 40.43678 1308 37.63743 predict after processing with nresponse=NULL is [88,1]: s="lambda.1se" 1 26.57900 13 33.26779 26 30.85060 ... 40.43678 1308 37.63743 got fitted values by calling predict (see above) ----Metadata: plotmo_y with nresponse=NULL --plotmo_y with nresponse=NULL for cv.glmnet object get.object.y: object$y is NULL (and it has no colnames) object call is cv.glmnet(x=xmat, y=tit[, 4], nfolds=3) get.y.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$y, env(..., call, caption, object, SHOWCALL, trace)) getCall(object)$y is usable but without colnames so we will keep on searching names(call) is "" "x" "y" "nfolds" the name of argument 2 is "y" so we will not process it with argn object$y is NULL call$y is usable but without colnames but we will use it anyway plotmo_y returned[88,1] with no column names: 1 29 2 24 3 25 ... 41 88 27 plotmo_y after processing with nresponse=NULL is [88,1] with no column names: 1 29 2 24 3 25 ... 41 88 27 converted nresponse=NA to nresponse=1 nresponse=1 (was NA) ncol(fitted) 1 ncol(predict) 1 ncol(y) 1 ----Metadata: plotmo_y with nresponse=1 --plotmo_y with nresponse=1 for cv.glmnet object get.object.y: object$y is NULL (and it has no colnames) object call is cv.glmnet(x=xmat, y=tit[, 4], nfolds=3) get.y.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$y, env(..., call, caption, object, SHOWCALL, trace)) getCall(object)$y is usable but without colnames so we will keep on searching names(call) is "" "x" "y" "nfolds" the name of argument 2 is "y" so we will not process it with argn object$y is NULL call$y is usable but without colnames but we will use it anyway got model response from getCall(object)$y plotmo_y returned[88,1] with no column names: 1 29 2 24 3 25 ... 41 88 27 plotmo_y after processing with nresponse=1 is [88,1]: plotmo_y 1 29 2 24 3 25 ... 41 88 27 got response name "s="lambda.1se"" from yhat resp.levs is NULL ----Metadata: done --plotmo_response for plotmo_rsq1 --plotmo_response for newdata: NULL plotmo_response trace 2: plotmo_response(object=object, newdata=newdata, trace=max(0,trace), nresponse=meta$nresponse, type=meta$type, meta=meta, ...) --get.model.env for object with class cv.glmnet object call is cv.glmnet(x=xmat, y=tit[, 4], nfolds=3) using attr(obj,".Environment") saved with cv.glmnet model: env(..., call, caption, object, SHOWCALL, trace) --plotmo_y with nresponse=1 for cv.glmnet object get.object.y: object$y is NULL (and it has no colnames) object call is cv.glmnet(x=xmat, y=tit[, 4], nfolds=3) get.y.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$y, env(..., call, caption, object, SHOWCALL, trace)) getCall(object)$y is usable but without colnames so we will keep on searching names(call) is "" "x" "y" "nfolds" the name of argument 2 is "y" so we will not process it with argn object$y is NULL call$y is usable but without colnames but we will use it anyway plotmo_y returned[88,1] with no column names: 1 29 2 24 3 25 ... 41 88 27 plotmo_y after processing with nresponse=1 is [88,1]: plotmo_y 1 29 2 24 3 25 ... 41 88 27 response is usable and has column name plotmo_y plotmo_response returned[88,1]: plotmo_y 1 29 2 24 3 25 ... 41 88 27 plotmo_response after processing with nresponse=1 is [88,1]: plotmo_y 1 29 2 24 3 25 ... 41 88 27 --plotmo_predict for plotmo_rsq1 plotmo_predict with NULL newdata, using plotmo_x to get the data --plotmo_x for cv.glmnet object get.object.x: object$x is NULL (and it has no colnames) object call is cv.glmnet(x=xmat, y=tit[, 4], nfolds=3) get.x.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$x, env(..., call, caption, object, SHOWCALL, trace)) getCall(object)$x is usable and has column names survived sibsp logage plotmo_x returned[88,3]: survived sibsp logage 1 1 0 1.821847 13 1 0 3.814495 26 0 0 3.094392 ... 0 0 5.950193 1308 0 0 5.116245 will use the above data instead of newdata=NULL for predict.cv.glmnet stats::predict(cv.glmnet.object, matrix[88,3], type="response", s="lambda.1se") predict returned[88,1]: s="lambda.1se" 1 26.57900 13 33.26779 26 30.85060 ... 40.43678 1308 37.63743 predict after processing with nresponse=1 is [88,1]: s="lambda.1se" 1 26.57900 13 33.26779 26 30.85060 ... 40.43678 1308 37.63743 ----plotmo_rinfo: plotmo_resids(object, type="response", nresponse=1) doTryCatch invoked call.dots TRACE plotmo_resids via try called call.dots(residuals, DROP="*", KEEP="PREFIX", TRACE=if(trace==0)-1elsetr...), force.object=object, force.type=residtype, SHOWCALL=TRUE, predict.s="lambda.1se") PREFIX residuals. DROP .* KEEP >STANDARDPREFIXES|^force\.|^def\.|^drop\. >PREFIX|^residuals\. >CALLARGS|^force\.object$|^force\.type$ >EXPLICIT input dotnames force.object force.type SHOWCALL predict.s after DROP and KEEP force.object force.type return dotnames object type stats::residuals(object=cv.glmnet.object, type="response") calling predict() because residuals() was unsuccessful plotmo_predict with NULL newdata, using plotmo_x to get the data --plotmo_x for cv.glmnet object get.object.x: object$x is NULL (and it has no colnames) object call is cv.glmnet(x=xmat, y=tit[, 4], nfolds=3) get.x.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$x, env(..., call, caption, object, SHOWCALL, trace)) getCall(object)$x is usable and has column names survived sibsp logage plotmo_x returned[88,3]: survived sibsp logage 1 1 0 1.821847 13 1 0 3.814495 26 0 0 3.094392 ... 0 0 5.950193 1308 0 0 5.116245 will use the above data instead of newdata=NULL for predict.cv.glmnet stats::predict(cv.glmnet.object, matrix[88,3], type="response", s="lambda.1se") predict returned[88,1]: s="lambda.1se" 1 26.57900 13 33.26779 26 30.85060 ... 40.43678 1308 37.63743 predict after processing with nresponse=1 is [88,1]: s="lambda.1se" 1 26.57900 13 33.26779 26 30.85060 ... 40.43678 1308 37.63743 --plotmo_y with nresponse=1 for cv.glmnet object get.object.y: object$y is NULL (and it has no colnames) object call is cv.glmnet(x=xmat, y=tit[, 4], nfolds=3) get.y.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$y, env(..., call, caption, object, SHOWCALL, trace)) getCall(object)$y is usable but without colnames so we will keep on searching names(call) is "" "x" "y" "nfolds" the name of argument 2 is "y" so we will not process it with argn object$y is NULL call$y is usable but without colnames but we will use it anyway plotmo_y returned[88,1] with no column names: 1 29 2 24 3 25 ... 41 88 27 plotmo_y after processing with nresponse=1 is [88,1]: plotmo_y 1 29 2 24 3 25 ... 41 88 27 residuals returned[88,1]: resids 1 2.4210049 2 -9.2677944 3 -5.8505971 ... 0.5632234 88 -10.6374291 residuals after processing with nresponse=1 is [88,1]: resids 1 2.4210049 2 -9.2677944 3 -5.8505971 ... 0.5632234 88 -10.6374291 generated the residuals using plotmo_predict() and plotmo_y() ----plotmo_rinfo: done graphics::par(mfrow=c(2,2), mgp=c(1.5,0.4,0), tcl=-0.3, font.main=1, mar=c(4,3,1.2,0.8), oma=c(0,0,4,0), cex.main=1, cex.lab=1, cex.axis=1, cex=0.83) graphics::plot(cv.glmnet.object) training rsq 0.24 > > set.seed(2015) > x <- matrix(rnorm(100*20),100,20) # 20 variables > y <- rnorm(100) > mod <- glmnet(x,y) > plotmo1(mod) plotmo1(object=mod) plotmo grid: x1 x2 x3 x4 x5 x6 -0.02229245 -0.03060877 0.02595536 -0.2306748 0.2048663 -0.2711153 x7 x8 x9 x10 x11 x12 x13 0.04214883 -0.1573321 0.05656354 -0.2789684 -0.01729983 0.05494411 -0.04358897 x14 x15 x16 x17 x18 x19 x20 -0.184689 -0.01875314 -0.08998893 0.05206396 0.1317551 -0.033794 0.1125339 > > # test w1.label > par(mfrow=c(2,3)) > par(cex=1) > par(mar=c(3,3,3,1)) > plotres(mod, which=1, w1.main="default w1.label") > plotres(mod, which=1, w1.label=5, w1.main="w1.label=5") > plotres(mod, which=1, w1.label=0, w1.main="w1.label=0") > plotres(mod, which=1, w1.label=TRUE, w1.main="w1.label=TRUE") > plotres(mod, which=1, w1.label=100, w1.main="w1.label=100") > par(org.par) > > # test w1 and non w1 args passed > par(mfrow=c(2,2), mar=c(4,4,4,4), cex=1) > > plot_glmnet(mod, w1.col=3:4, w1.xvar="norm", + main="plot_glmnet\nw1.col=3:4 w1.xvar=\"norm\"") > > plot_glmnet(mod, col=3:4, xvar="norm", + main="plot_glmnet\ncol=3:4 xvar=\"norm\"") > > plot_glmnet(mod, col=3:4, w1.col=1:2, + w1.xvar="norm", xvar="lambda", + main="plot_glmnet\ncol=3:4 w1.col=1:2\nw1.xvar=\"norm\", xvar=\"lambda\"") > > par(org.par) > par(mfrow=c(3,2), mar=c(3,4,4,4), cex=1) > > plotres(mod, which=c(1,3), do.par=FALSE, w1.col=3:4, w1.xvar="norm", + w1.main="plotres\nw1.col=3:4 w1.xvar=\"norm\"") > > plotres(mod, which=c(1,3), do.par=FALSE, col=3:4, xvar="norm", + w1.main="plotres\nplotres\ncol=3:4 xvar=\"norm\"") > > plotres(mod, which=c(1,3), do.par=FALSE, col=3:4, w1.col=1:2, + w1.main="plotres\ncol=3:4 w1.col=1:2") > > par(org.par) > > # glmnet with sparse matrices > set.seed(2015) > n <- 100 > p <- 20 > nzc <- trunc(p/10) > x <- matrix(rnorm(n*p),n,p) > iz <- sample(1:(n*p),size=n*p*.85,replace=FALSE) > x[iz] <- 0 > sx <- Matrix(x,sparse=TRUE) > # colnames(sx) <- paste("x", 1:ncol(sx), sep="") # need column names for plotmo > inherits(sx,"sparseMatrix") # confirm that it is sparse [1] TRUE > beta <- rnorm(nzc) > fx <- x[,seq(nzc)]%*%beta > eps <- rnorm(n) > y <- fx+eps > px <- exp(fx) > px <- px/(1+px) > ly <- rbinom(n=length(px),prob=px,size=1) > mod.glmnet.sx <- glmnet(sx,y) > plotmo1(mod.glmnet.sx, all2=TRUE) # will give warning: too many predictors to plot all pairs plotmo1(object=mod.glmnet.sx,all2=TRUE) Warning: too many predictors to plot all pairs, so plotting degree2 plots for just the first 7 predictors. Call plotmo with all2=2 to plot degree2 plots for up to 20 predictors. plotmo grid: x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 x19 x20 0 0 > plotmo1(mod.glmnet.sx, all2=2, caption="all2=2") # test all2=2 plotmo1(object=mod.glmnet.sx,all2=2,caption="all2=2") More than 64 degree2 plots. Consider using plotmo's degree2 argument to limit the number of plots. For example, degree2=1:10 or degree2="x1" Call plotmo with trace=-1 to make this message go away. plotmo grid: x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 x19 x20 0 0 > plotmo1(mod.glmnet.sx, all2=2, degree2=1:3, caption="all2=2 degree2=1:3") plotmo1(object=mod.glmnet.sx,all2=2,degree2=1:3,caption="all2=2degree2=1:3") plotmo grid: x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 x19 x20 0 0 > plotres(mod.glmnet.sx) > par(org.par) > > par(mfrow=c(2,4), mar=c(3,3,3,1), mgp=c(1.5,0.5,0), oma=c(0,0,2.5,0)) > y <- trees$Volume > x <- as.matrix(data.frame(Girth=trees$Girth, Height=trees$Height)) > glmnet <- glmnet(x, y) > plotres(glmnet, do.par=FALSE, caption="glmnet and lm: top and bottom should be the same") > lm <- lm(Volume~., data=trees) > plotres(lm, do.par=FALSE, SHOWCALL=TRUE) > > par(mfrow=c(3,2), mar=c(3,3,3,1), mgp=c(1.5,0.5,0), oma=c(0,0,2.5,0)) > plotres(glmnet, do.par=FALSE, which=c(1,3), w1.xvar="norm", + caption="glmnet with various options", SHOWCALL=TRUE) > plotres(glmnet, trace=1, do.par=FALSE, which=c(1,3), SHOWCALL=TRUE) stats::residuals(object=elnet.object, type="response") residuals() was unsuccessful, will use predict() instead stats::predict(elnet.object, matrix[3,2], type="response", s=0) stats::fitted(object=elnet.object) fitted() was unsuccessful, will use predict() instead got model response from getCall(object)$y plot_glmnet(elnet.object, xvar="rlambda", grid.col=0, s=0, nresponse=1) training rsq 0.95 > plotres(glmnet, trace=1, do.par=FALSE, which=c(1,3), predict.s=5, SHOWCALL=TRUE) stats::residuals(object=elnet.object, type="response") residuals() was unsuccessful, will use predict() instead stats::predict(elnet.object, matrix[3,2], type="response", s=5) stats::fitted(object=elnet.object) fitted() was unsuccessful, will use predict() instead got model response from getCall(object)$y plot_glmnet(elnet.object, xvar="rlambda", grid.col=0, s=5, nresponse=1) training rsq 0.84 > par(org.par) > > printf("======== glmnet additional tests\n") ======== glmnet additional tests > set.seed(2015) > p <- 10 > n <- 30 > x <- cbind(matrix(rnorm(n*p),n,p)) > y <- rowSums(x[,1:3]^3) > glmnet <- glmnet(x,y) > plotres(glmnet, SHOWCALL=TRUE, caption="glmnet: y <- rowSums(x[,1:3]^3)") > plotres(glmnet, SHOWCALL=TRUE, w1.xvar="norm") > par(mfrow=c(1,1)) > omar <- par("mar") > ocex.axis <- par("cex.axis") > ocex.lab <- par("cex.lab") > plotres(glmnet, SHOWCALL=TRUE, which=1) > stopifnot(par("mar") == omar) > stopifnot(par("cex.axis") == ocex.axis) > stopifnot(par("cex.lab") == ocex.lab) > par(org.par) > > # test some args for plot_glmnet > plotres(glmnet, predict.s=.05, SHOWCALL=TRUE, trace=0, col.main=2, + w1.xlab="my xlab", w1.ylab="my ylab", + w1.main="test some args for plot_glmnet1", + w1.col=4:1) > > plot_glmnet(glmnet, trace=0, col.main=2, main="test some args for plot_glmnet2", + xlab="my xlab", ylab="my ylab", + col=4:1, ylim=c(-2,4)) # TODO xlim=c(-5,3)) > > plotres(glmnet, predict.s=.05, SHOWCALL=TRUE, which=c(1,3), grid.col="gray", do.par=2) > plotres(glmnet, predict.s=.05, SHOWCALL=TRUE, which=c(1,3), w1.s.col=0, do.par=0) > par(org.par) > > # TODO the following issues a stream of warnings: restarting interrupted promise evaluation > expect.err(try(plotres(glmnet, w1.col=nonesuch)), "cannot evaluate 'col'") Warning in eval(dots[[i]]) : restarting interrupted promise evaluation Warning in eval(dots[[i]]) : restarting interrupted promise evaluation Warning in eval(dots[[i]]) : restarting interrupted promise evaluation Warning in eval(dots[[i]]) : restarting interrupted promise evaluation Warning in eval(dots[[i]]) : restarting interrupted promise evaluation Warning in eval(dots[[i]]) : restarting interrupted promise evaluation Warning in eval(dots[[i]]) : restarting interrupted promise evaluation Warning in eval(dots[[i]]) : restarting interrupted promise evaluation Warning in eval(dots[[i]]) : restarting interrupted promise evaluation Warning in eval(dots[[i]]) : restarting interrupted promise evaluation Warning in eval(dots[[i]]) : restarting interrupted promise evaluation Warning in eval(dots[[i]]) : restarting interrupted promise evaluation Warning in eval(dots[[i]]) : restarting interrupted promise evaluation Warning in eval(dots[[i]]) : restarting interrupted promise evaluation Warning in eval(dots[[i]]) : restarting interrupted promise evaluation Warning in eval(dots[[i]]) : restarting interrupted promise evaluation Warning in eval(dots[[i]]) : restarting interrupted promise evaluation Warning in eval(dots[[i]], envir = env, enclos = env) : restarting interrupted promise evaluation Warning in eval(dots[[i]], envir = env, enclos = env) : restarting interrupted promise evaluation Warning in eval(dots[[i]], envir = env, enclos = env) : restarting interrupted promise evaluation Warning in eval(dots[[i]], envir = env, enclos = env) : restarting interrupted promise evaluation Warning in eval(dots[[i]], envir = env, enclos = env) : restarting interrupted promise evaluation Error in eval(dots[[idot]], parent.frame(1)) : ..6 used in an incorrect context, no ... to look in plot_glmnet(elnet.object, xvar="rlambda", grid.col=0, col=..6, s=0, nresponse=1) Error in eval(dots[[idot]], parent.frame(1)) : ..6 used in an incorrect context, no ... to look in Error : cannot evaluate 'col' Got expected error from try(plotres(glmnet, w1.col = nonesuch)) > > printf("======== glmnet multinomial (multnet)\n") ======== glmnet multinomial (multnet) > par(mfrow=c(4,4), mar=c(3,3,3,1)) > set.seed(2016) > n <- 200 > p <- 4 > x <- matrix(rnorm(n*p), n, p) > colnames(x) <- paste("x", 1:ncol(x), sep="") > > # "1" is correlated with x[,1], "4" is correlated with x[,2], "2" and "3" not correlated > y <- ifelse(x[,1] > 0.5, 1, + ifelse(x[,2] > 0.0, 4, + sample(c(2,3), size=nrow(x), replace=TRUE))) > print(cov(x, y)) [,1] x1 -0.84023279 x2 0.38654310 x3 -0.11396993 x4 -0.07611821 > y <- factor(y) > > # TODO Following causes the following warning: > # Warning: from glmnet Fortran code (error code -90); Convergence for 90th lambda value not reached after maxit=100000 iterations; solutions for larger lambdas returned > multinomial.mod <- glmnet(x, y, family="multinomial") Warning: from glmnet C++ code (error code -90); Convergence for 90th lambda value not reached after maxit=100000 iterations; solutions for larger lambdas returned > > plotres(multinomial.mod, nresponse=1, w1.main="nresponse=1", + main="family=\"multinomial\"", + smooth.col=0, info=TRUE, + trace=0, which=c(1,3), do.par=FALSE, xlim=c(-.2,1.2), ylim=c(-1.2, 1.2)) > > plotres(multinomial.mod, nresponse=2, w1.main="nresponse=2", + smooth.col=0, info=TRUE, + trace=0, which=c(1,3), do.par=FALSE, xlim=c(-.2,1.2), ylim=c(-1.2, 1.2)) > > plotres(multinomial.mod, nresponse=3, w1.main="nresponse=3", + smooth.col=0, info=TRUE, + trace=0, which=c(1,3), do.par=FALSE, xlim=c(-.2,1.2), ylim=c(-1.2, 1.2)) > > plotres(multinomial.mod, nresponse=4, w1.main="nresponse=4", + smooth.col=0, info=TRUE, + trace=0, which=c(1,3), do.par=FALSE, xlim=c(-.2,1.2), ylim=c(-1.2, 1.2)) > > plotmo(multinomial.mod, nresponse=1, trace=0, do.par=FALSE, degree1=1:2) plotmo grid: x1 x2 x3 x4 -0.01157106 0.1530614 0.04853916 0.02097713 > plotmo(multinomial.mod, nresponse=2, trace=0, do.par=FALSE, degree1=1:2) plotmo grid: x1 x2 x3 x4 -0.01157106 0.1530614 0.04853916 0.02097713 > > par(mgp=c(1.5, .4, 0)) > plot(multinomial.mod, xvar="norm") # compare to plot.glmnet > par(org.par) > > # compare to earth > par(mfrow=c(4,3), mar=c(3,3,1,1)) > yfac <- factor(c("a","b","c","d")[y]) > earth.mod <- earth(x, yfac, trace=0) > > plotres(earth.mod, nresponse=1, + main=sprint("multiresponse\nnresponse=1 rsq %.2g", earth.mod$rsq.per.response[1]), + which=3, xlim=c(-.2, 1.2), ylim=c(-1.2, 1.2), + smooth.col=0, info=TRUE, + do.par=FALSE, trace=0, jitter=7, cex.response=.7) > plotmo(earth.mod, nresponse=1, do.par=FALSE) plotmo grid: x1 x2 x3 x4 -0.01157106 0.1530614 0.04853916 0.02097713 > > plotres(earth.mod, nresponse=2, + main=sprint("nresponse=2 rsq %.2g", earth.mod$rsq.per.response[2]), + which=3, xlim=c(-.2, 1.2), ylim=c(-1.2, 1.2), + smooth.col=0, info=TRUE, + do.par=FALSE, trace=0, jitter=7, cex.response=.7) > plotmo(earth.mod, nresponse=2, do.par=FALSE) plotmo grid: x1 x2 x3 x4 -0.01157106 0.1530614 0.04853916 0.02097713 > > plotres(earth.mod, nresponse=3, + main=sprint("nresponse=3 rsq %.2g", earth.mod$rsq.per.response[3]), + which=3, xlim=c(-.2, 1.2), ylim=c(-1.2, 1.2), + smooth.col=0, info=TRUE, + do.par=FALSE, trace=0, jitter=7, cex.response=.7) > plotmo(earth.mod, nresponse=3, do.par=FALSE) plotmo grid: x1 x2 x3 x4 -0.01157106 0.1530614 0.04853916 0.02097713 > > plotres(earth.mod, nresponse=4, + main=sprint("nresponse=4 rsq %.2g", earth.mod$rsq.per.response[4]), + which=3, xlim=c(-.2, 1.2), ylim=c(-1.2, 1.2), + smooth.col=0, info=TRUE, + do.par=FALSE, trace=0, jitter=7, cex.response=.7) > plotmo(earth.mod, nresponse=4, do.par=FALSE) plotmo grid: x1 x2 x3 x4 -0.01157106 0.1530614 0.04853916 0.02097713 > > print(summary(earth.mod)) Call: earth(x=x, y=yfac, trace=0) a b c d (Intercept) -0.00759508 0.4777590 0.32170406 0.2081320 h(x1-0.333835) 2.90462369 -0.8647319 -0.45258311 -1.5873087 h(x1-0.698191) -2.95380448 0.8748909 0.44797354 1.6309401 h(x2- -0.724713) 0.00083945 0.8851614 -0.25504553 -0.6309554 h(x2- -0.399683) 0.00512171 -1.9558653 -0.04067399 1.9914176 h(x2-0.255847) -0.00181500 1.1141555 0.31084638 -1.4231869 Selected 6 of 14 terms, and 2 of 4 predictors Termination condition: Reached nk 21 Importance: x1, x2, x3-unused, x4-unused Number of terms at each degree of interaction: 1 5 (additive model) GCV RSS GRSq RSq a 0.01233701 2.203452 0.9438697 0.9493692 b 0.10618691 18.965513 0.3429519 0.4073277 c 0.08491793 15.166767 0.1053911 0.1930425 d 0.07399172 13.215291 0.6874511 0.7180738 All 0.27743357 49.551022 0.6109269 0.6490472 > > par(org.par) > > printf("======== binomial model\n") ======== binomial model > > set.seed(2019) > n <- 50 > p <- 4 > x <- matrix(rnorm(n*p), n, p) > colnames(x) <- paste("x", 1:ncol(x), sep="") > y <- ifelse(x[,1] + x[,2] + .1 * rnorm(n) > .5, TRUE, FALSE) > print(cov(x, y)) [,1] x1 0.26996406 x2 0.19322507 x3 0.04850061 x4 0.01568008 > y <- factor(y) > glmnet.binomial <- glmnet(x, y, family="binomial") > par(mfrow=c(2,3), mar=c(3,3,1,1)) > plotres(glmnet.binomial, info=T, predict.s=.02, which=c(1,3), do.par=FALSE, w1.main="glmnet.binomial") > plot(glmnet.binomial) > earth.mod <- earth(x, y) > set.seed(2019) > plotres(earth.mod, info=T, which=c(1,3), do.par=FALSE) > par(org.par) > par(mfrow=c(2,4), mar=c(3,3,1,1)) > set.seed(2019) > plotmo(glmnet.binomial, do.par=FALSE) plotmo grid: x1 x2 x3 x4 0.05687241 -0.2477018 -0.1266239 -0.2475514 > plotmo(earth.mod, do.par=FALSE, main="binomial earth.mod") plotmo grid: x1 x2 x3 x4 0.05687241 -0.2477018 -0.1266239 -0.2475514 > par(org.par) > > printf("======== glmnet family=\"mgaussian\"\n") ======== glmnet family="mgaussian" > set.seed(2015) > p <- 10 > n <- 30 > x <- cbind((1:n)/n, matrix(rnorm(n*(p-1)),n,p-1)) > colnames(x) <- paste0("x", 1:p) > # ymultresp <- cbind(rowSums(x[,1:5]^3), rowSums(x[,5:p]^3), 1:n) > set.seed(1) > ymultresp <- cbind(x[,1]+.001*rnorm(n), rowSums(x[,2:5]^3), rnorm(n)) > glmnet.mgaussian <- glmnet(x, ymultresp, family="mgaussian") > plotres(glmnet.mgaussian, nresponse=1, SHOWCALL=TRUE, which=c(1:3), do.par=2, info=1) > # manually calculate the residuals > plot(x=predict(glmnet.mgaussian, newx=x, s=0)[,1,1], + y=ymultresp[,1] - predict(glmnet.mgaussian, newx=x, s=0)[,1,1], + pch=20, xlab="Fitted", ylab="Residuals", + main="Manually calculated residuals, nresponse=1, s=0") > abline(h=0, col="gray") > par(org.par) > plotres(glmnet.mgaussian, nresponse=2, SHOWCALL=TRUE, which=c(1:3), do.par=2, info=1) > # manually calculate the residuals > plot(x=predict(glmnet.mgaussian, newx=x, s=0)[,2,1], + y=ymultresp[,2] - predict(glmnet.mgaussian, newx=x, s=0)[,2,1], + pch=20, xlab="Fitted", ylab="Residuals", + main="Manually calculated residuals, nresponse=2, s=0") > abline(h=0, col="gray") > par(org.par) > plotmo(glmnet.mgaussian, nresponse=1, SHOWCALL=TRUE) plotmo grid: x1 x2 x3 x4 x5 x6 0.5166667 0.002216547 0.3749872 -0.1927516 -0.3806807 -0.03575992 x7 x8 x9 x10 0.01386232 0.0135174 0.04028881 0.0426105 > plotmo(glmnet.mgaussian, nresponse=2, SHOWCALL=TRUE) plotmo grid: x1 x2 x3 x4 x5 x6 0.5166667 0.002216547 0.3749872 -0.1927516 -0.3806807 -0.03575992 x7 x8 x9 x10 0.01386232 0.0135174 0.04028881 0.0426105 > > graphics::par(mfrow=c(2,2), mgp=c(1.5,0.4,0), tcl=-0.3, cex.main=1, + font.main=1, mar=c(4,3,1.2,0.8), oma=c(0,0,4,0), cex=0.83) > > plotres(glmnet.mgaussian, nresponse=2, SHOWCALL=TRUE, which=3, do.par=FALSE, + caption="glmnet.mgaussian compare to manually calculated residuals") > plot(x=predict(glmnet.mgaussian, newx=x, s=0)[,2,1], + y=ymultresp[,2] - predict(glmnet.mgaussian, newx=x, s=0)[,2,1], + pch=20, xlab="Fitted", ylab="Residuals", + main="Manual residuals, nresponse=2, s=0") > abline(h=0, col="gray") > > plotres(glmnet.mgaussian, nresponse=2, predict.s=.5, SHOWCALL=TRUE, which=3, do.par=FALSE) > plot(x=predict(glmnet.mgaussian, newx=x, s=.5)[,2,1], + y=ymultresp[,2] - predict(glmnet.mgaussian, newx=x, s=.5)[,2,1], + pch=20, xlab="Fitted", ylab="Residuals", + main="Manual residuals, nresponse=2, s=.5") > abline(h=0, col="gray") > > plotres(glmnet.mgaussian, predict.s=.05, nresponse=3, info=TRUE, SHOWCALL=TRUE) # essentially random > > par(org.par) > par(mfrow=c(2,3), mar=c(3,3,3,.5), oma=c(0,0,3,0), mgp=c(1.5,0.4,0), tcl=-0.3) > > data(trees) > set.seed(2015) > # variable with a long name > x50 <- cbind(trees[,1:2], Girth12345678901234567890=rnorm(nrow(trees))) > mod.with.long.name <- glmnet(data.matrix(x50),data.matrix(trees$Volume)) > plotres(mod.with.long.name, which=1, caption="test plot_glmnet with x50 and x60") > > # one inactive variable (all coefs are zero for variable "rand") > set.seed(2015) > x60 <- cbind(trees[,1], rand=rnorm(nrow(trees)), trees[,2]) > # complicate the issue: use an unnamed column (column 3) > colnames(x60) <- c("Girth", "rand", "") > mod.with.inactive.var <- glmnet(data.matrix(x60),data.matrix(trees$Volume)) > mod.with.inactive.var$beta["rand",] = 0 # TODO hack force inactive variable > plotres(mod.with.inactive.var, which=1) > plotres(mod.with.inactive.var, which=1, w1.xvar="norm") > # compare to plot.glmnet (but note that labels aren't always plotted unless par=c(1,1)?) > plot(mod.with.inactive.var, xvar="norm", label=TRUE) > # plotmo calls the unnamed column "x3", fair enough > plotmo(mod.with.inactive.var, do.par=FALSE, pt.col=2) plotmo grid: Girth rand x3 12.9 0.004544606 76 > > # single active variable > x70 <- cbind(trees[,1,drop=F], 0) > a <- glmnet(data.matrix(x70), data.matrix(trees$Volume)) > par(org.par) > par(mfrow=c(2,2), mar=c(3,3,2,4)) > plotres(a, which=1, predict.s=1, caption="single active variable") > plotres(a, which=1, w1.xvar="norm") > plotres(a, which=1, w1.xvar="lambda") > plotres(a, which=1, w1.xvar="dev") > > #--- test interaction of w1. and non w1 args ------------------------------------- > > #--- glmnet model, which=1 --- > > par(org.par) > par(mfrow=c(4,3), mar=c(3, 3, 4, 1), mgp=c(2, 0.6, 0)) > > plotres(mod.glmnet.xmat, which=1, + w1.xlim=c(6,-6), + w1.ylim=c(-5,5), + w1.col=1:2, + w1.main="TEST INTERACTION OF W1 ARGS PAGE 1 (which=1)\n\nwhich=1 w1.xlim=c(6,-6)\nw1.ylim=c(-5,5)) w1.col=1:2,") > > plotres(mod.glmnet.xmat, which=1, cex.main=1.2, + xlim=c(9,-9), + ylim=c(-60,60), + col=3:4, + w1.main="which=1 xlim=c(9,-9)\nylim=c(-60,60)) col=3:4,") > > plotres(mod.glmnet.xmat, which=1, cex.main=1, + xlim=c(9,-9), w1.xlim=c(6,-6), + ylim=c(-60,60), w1.ylim=c(-5,5), + w1.col=1:2, col=3:4, + w1.main="which=1 xlim=c(9,-9), w1.xlim=c(6,-6)\nylim=c(-60,60), w1.ylim=c(-5,5)) w1.col=1:2, col=3:4") > > #--- glmnet model, which=c(1,3,4) --- > > plotres(mod.glmnet.xmat, which=c(1,3,4), cex.main=1, + ylim=c(-70,70), xlim=c(-20, 60), + col=2:3, do.par=FALSE, + w1.main="TEST INTERACTION OF W1 ARGS PAGE 1 (which=c(1,3,4))\nlim=c(-70,70), xlim=c(-20, 60)") > > plotres(mod.glmnet.xmat, which=c(1,3,4), cex.main=1.2, + ylim=c(-70,70), xlim=c(-20, 60), qq.xlim=c(-7,5), + col=2:3, do.par=FALSE, + w1.main="ylim=c(-70,70), xlim=c(-20, 60)\nqq.xlim=c(-7,5)") > > plotres(mod.glmnet.xmat, which=c(1,3,4), cex.main=1.2, + w1.ylim=c(-7,7), w1.xlim=c(4,-4), col=2:3, do.par=FALSE, + w1.main="w1.ylim=c(-7,7), w1.xlim=c(4,-4)") > > # plotres(mod.glmnet.xmat, which=c(1,3,4), cex.main=.9, > # w1.ylim=c(-7,7), ylim=c(-20,20), > # qq.xlim=c(-7,5), col=2:3, do.par=FALSE, > # qq.ylim=c(-100,100), > # main="w1.ylim=c(-7,7) ylim=c(-20,20)\nqq.xlim=c(-7,5) qq.ylim=c(-100,100)") > > par(org.par) > par(mfrow=c(3,3), mar=c(3, 3, 4, 1), mgp=c(2, 0.6, 0)) > > plotres(mod.glmnet.xmat, which=c(1,3,4), do.par=FALSE, # w1.main="which=c(1,3,4)", + w1.xlim=c(6,-6), + w1.ylim=c(-5,5), + w1.col=2:3, + w1.main="TEST INTERACTION OF W1 ARGS PAGE 2\n\nwhich=c(1,3,4) w1.xlim=c(6,-6)\nw1.ylim=c(-5,5)) w1.col=2:3") > > plotres(mod.glmnet.xmat, which=c(1,3,4), w1.cex.main=1, do.par=FALSE, # w1.main="which=c(1,3,4)", + xlim=c(-20,70), + ylim=c(-60,60), + w1.col=2:3, + col=3:4, + w1.main="which=c(1,3,4) ylim=c(-60,60))\nw1.col=2:3, col=3:4") > > plotres(mod.glmnet.xmat, which=c(1,3,4), w1.cex.main=1, do.par=FALSE, # w1.main="which=c(1,3,4)", + xlim=c(-20,70), w1.xlim=c(6,-6), + ylim=c(-60,60), w1.ylim=c(-5,5), + col=3:4, + w1.main="which=c(1,3,4) xlim=c(9,-9), w1.xlim=c(6,-6)\nylim=c(-60,60), w1.ylim=c(-5,5)) w1.col=1:2, col=3:4") > > par(org.par) > > #-- make sure that we can work with all families > > set.seed(2016) > par(mfrow=c(3,3), mar=c(3,3,3,1)) > n <- 100 > p <- 4 > x <- matrix(rnorm(n*p), n, p) > g2 <- sample(1:2, n, replace=TRUE) > for(family in c("gaussian","binomial","poisson")) { + mod <- glmnet(x,g2,family=family) + plot(mod, xvar="lambda") + plotres(mod, w1.xvar="lambda", main=paste("family", family), + which=c(1,3), do.par=FALSE) + } > # cox > library(plotmo) > n <- 100 > p <- 20 > nzc <- trunc(p/10) > set.seed(2016) > beta <- rnorm(nzc) > x7 <- matrix(rnorm(n*p), n, p) > beta <- rnorm(nzc) > fx <- x7[,seq(nzc)] %*% beta/3 > hx <- exp(fx) > ty <- rexp(n, hx) > tcens <- rbinom(n=n, prob=.3, size=1)# censoring indicator > y <- cbind(time=ty, status=1-tcens) # y=Surv(ty,1-tcens) with library(survival) > glmnet.cox <- glmnet(x=x7, y=y, family="cox") > plot(glmnet.cox) > title("glmnet.cox", line=2) > plot_glmnet(glmnet.cox, xvar="norm") > plotres(glmnet.cox, which=3, do.par=FALSE) > par(org.par) > > # test col argument > par(mfrow=c(2,3), mar=c(3,3,5,1), cex=1) > mod <- glmnet(as.matrix(mtcars[-1]), mtcars[,1]) > plot_glmnet(mod, main="plot_glmnet default") > plot_glmnet(mod, col=c(1,2,3,0,0,NA,0,0,0,0), main="col=c(1,2,3,0,0,NA,0,0,0,0)") > g <- "gray" > plot_glmnet(mod, col=c("black","red","green",g,g,g,g,g,"steelblue","darkorange"), main="col=c('black','red','green',g,g,g,g,g,'steelblue','darkorange')") > plot_glmnet(mod, col=c("black","red","green",0,0,0,0,0,"steelblue","darkorange"), main="col=c('black','red','green',0,0,0,0,0,'steelblue','darkorange')") > plot_glmnet(mod, col=c("black","red", 0), main="col=c('black','red', 0)") # test recycling, including 0 > par(org.par) > > source("test.epilog.R") plotmo/inst/slowtests/test.modguide.bat0000755000176200001440000000154714563571565020106 0ustar liggesusers@rem test.modguide.bat: test model1 and model2 (linmod examples) in modguide.pdf @echo test.modguide.bat @"C:\PROGRA~1\R\R-4.3.2\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.modguide.R @if %errorlevel% equ 0 goto good1: @echo R returned errorlevel %errorlevel%, see test.modguide.Rout: @echo. @tail test.modguide.Rout @echo test.modguide.R @exit /B 1 :good1 mks.diff test.modguide.Rout test.modguide.Rout.save @if %errorlevel% equ 0 goto good2: @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.modguide.save.ps @exit /B 1 :good2 @rem test.modguide.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.modguide.save.ps @if %errorlevel% equ 0 goto good3: @echo === Files are different === @exit /B 1 :good3 @rm -f test.modguide.Rout @rm -f Rplots.ps @exit /B 0 plotmo/inst/slowtests/x10000644000176200001440000000002514360014534015060 0ustar liggesusersmmpf mlbench interpplotmo/inst/slowtests/test.plotmo3.R0000644000176200001440000005007413737416454017332 0ustar liggesusers# test.plotmo3.R: extra tests for plotmo version 3 and higher source("test.prolog.R") library(earth) data(ozone1) data(etitanic) options(warn=1) # print warnings as they occur # check check.numeric.scalar xtest <- NA expect.err(try(plotmo:::check.numeric.scalar(xtest)), "'xtest' is NA") xtest <- NULL expect.err(try(plotmo:::check.numeric.scalar(xtest)), "'xtest' is NULL") expect.err(try(plotmo:::check.numeric.scalar(NA)), "argument is NA") expect.err(try(plotmo:::check.numeric.scalar(NULL)), "argument is NULL") expect.err(try(plotmo:::check.numeric.scalar(try)), "'try' must be numeric (whereas its current class is \"function\")") expect.err(try(plotmo:::check.numeric.scalar('try')), "\"try\" must be numeric (whereas its current class is \"character\")") expect.err(try(plotmo:::check.numeric.scalar(NULL)), "argument is NULL") expect.err(try(plotmo:::check.numeric.scalar(1234, min=2, max=3)), "argument=1234 but it should be between 2 and 3") expect.err(try(plotmo:::check.numeric.scalar(0.1234, min=2, max=3)), "argument=0.1234 but it should be between 2 and 3") expect.err(try(plotmo:::check.numeric.scalar(.1234, min=2, max=3)), "argument=0.1234 but it should be between 2 and 3") expect.err(try(plotmo:::check.numeric.scalar(+1234, min=2, max=3)), "argument=1234 but it should be between 2 and 3") expect.err(try(plotmo:::check.numeric.scalar(-1234, min=2, max=3)), "argument=-1234 but it should be between 2 and 3") expect.err(try(plotmo:::check.numeric.scalar(+.1234, min=2, max=3)), "argument=0.1234 but it should be between 2 and 3") expect.err(try(plotmo:::check.numeric.scalar(-.1234, min=2, max=3)), "argument=-0.1234 but it should be between 2 and 3") expect.err(try(plotmo:::check.numeric.scalar("", min=0, max=3)), "\"\" must be numeric (whereas its current class is \"character\"") x.numeric.scalar <- 1234 expect.err(try(plotmo:::check.numeric.scalar(x.numeric.scalar, min=0, max=3)), "x.numeric.scalar=1234 but it should be between 0 and 3") stopifnot(identical(plotmo:::check.numeric.scalar(x.numeric.scalar, min=2, max=1235), 1234)) stopifnot(identical(plotmo:::check.numeric.scalar(1234, min=2, max=1235), 1234)) # check check.integer.scalar xtest <- NA expect.err(try(plotmo:::check.integer.scalar(xtest)), "'xtest' is NA") xtest <- NULL expect.err(try(plotmo:::check.integer.scalar(xtest)), "'xtest' is NULL") expect.err(try(plotmo:::check.integer.scalar(NA)), "argument is NA") expect.err(try(plotmo:::check.integer.scalar(NA, null.ok=TRUE)), "argument is NA") expect.err(try(plotmo:::check.integer.scalar(NULL)), "argument is NULL") expect.err(try(plotmo:::check.integer.scalar(xtest, na.ok=TRUE)), "'xtest' is NULL") expect.err(try(plotmo:::check.integer.scalar("xyz", na.ok=TRUE)), "\"xyz\" is a string but it should be an integer, or NA, or TRUE or FALSE") expect.err(try(plotmo:::check.integer.scalar("TRUE", na.ok=TRUE)), "\"TRUE\" is a string but it should be an integer, or NA, or TRUE or FALSE") stopifnot(identical(plotmo:::check.integer.scalar(TRUE), TRUE)) stopifnot(identical(plotmo:::check.integer.scalar(NA, na.ok=TRUE), NA)) x.integer.scalar <- 1234L expect.err(try(plotmo:::check.integer.scalar(x.integer.scalar, min=0, max=3)), "x.integer.scalar=1234 but it should be between 0 and 3") stopifnot(identical(plotmo:::check.integer.scalar(x.integer.scalar, min=2, max=1235), 1234L)) stopifnot(identical(plotmo:::check.integer.scalar(1234, min=2, max=1235), 1234)) stopifnot(identical(plotmo:::check.integer.scalar(x.integer.scalar, min=2, max=1235), 1234L)) stopifnot(identical(plotmo:::check.integer.scalar(1234, min=2, max=1235), 1234)) xtest <- 1.234 expect.err(try(plotmo:::check.integer.scalar(xtest, min=0, max=3)), "xtest=1.234 but it should be an integer, or TRUE or FALSE") # check check.vec xtest <- "x" expect.err(try(plotmo:::check.vec(xtest, "xtest", na.ok=TRUE)), "'xtest' is not numeric") xtest <- as.double(NA) print(plotmo:::check.vec(xtest, "xtest", na.ok=TRUE)) xtest <- as.double(1:3) print(plotmo:::check.vec(xtest, "xtest", na.ok=TRUE)) xtest <- c(1,2,3,1/0,5,6,7) expect.err(try(plotmo:::check.vec(xtest, "xtest", na.ok=TRUE)), "non-finite value in xtest") xtest <- c(1,2,3,NA,5,6,7) expect.err(try(plotmo:::check.vec(xtest, "xtest")), "NA in xtest") xtest <- c(1,2,3) expect.err(try(plotmo:::check.vec(xtest, "xtest", expected.len=2)), "'xtest' has the wrong length 3, expected 2") print(plotmo:::check.vec(c(TRUE, FALSE), "c(TRUE, FALSE)")) plotmo1 <- function(object, ..., trace=0, SHOWCALL=TRUE, caption=NULL) { if(is.null(caption)) caption <- paste(deparse(substitute(object)), collapse=" ") call <- match.call(expand.dots=TRUE) call <- strip.space(paste(deparse(substitute(call)), collapse=" ")) printf("%s\n", call) plotmo(object, trace=trace, SHOWCALL=SHOWCALL, caption=caption, ...) } plotres1 <- function(object, ..., trace=0, SHOWCALL=TRUE, caption=NULL) { if(is.null(caption)) caption <- paste(deparse(substitute(object)), collapse=" ") call <- match.call(expand.dots=TRUE) call <- strip.space(paste(deparse(substitute(call)), collapse=" ")) printf("%s\n", call) plotres(object, trace=trace, SHOWCALL=SHOWCALL, caption=caption, ...) } # basic tests of plotmo on abbreviated titanic data get.tita <- function() { tita <- etitanic pclass <- as.character(tita$pclass) # change the order of the factors so not alphabetical pclass[pclass == "1st"] <- "first" pclass[pclass == "2nd"] <- "class2" pclass[pclass == "3rd"] <- "classthird" tita$pclass <- factor(pclass, levels=c("class2", "classthird", "first")) # log age is so we have a continuous predictor even when model is age~. set.seed(2015) tita$logage <- log(tita$age) + rnorm(nrow(tita)) tita$parch <- NULL # by=12 gives us a small fast model with an additive and a interaction term tita[seq(1, nrow(etitanic), by=12), ] } tita <- get.tita() mod.lm.age <- lm(age~., data=tita) plotmo1(mod.lm.age) plotmo1(mod.lm.age, level=.95) plotmo1(mod.lm.age, level=.95, col.resp=3) sexn <- as.numeric(tita$sex) mod.lm.sexn <- lm(sexn~.-sex, data=tita) plotmo1(mod.lm.sexn) plotmo1(mod.lm.sexn, level=.95) set.seed(2020) mod.earth.age <- earth(age~., data=tita, degree=2, nfold=3, ncross=3, varmod.method="lm") plotmo1(mod.earth.age) plotmo1(mod.earth.age, level=.9, degree2=0) # tita[,4] is age set.seed(2020) mod.earth.tita.age <- earth(tita[,-4], tita[,4], degree=2, nfold=3, ncross=3, trace=.5, varmod.method="lm") cat("\nsummary(mod.earth.tita.age)\n") print(summary(mod.earth.tita.age)) plotmo1(mod.earth.tita.age) plotmo1(mod.earth.tita.age, level=.9, degree2=0) set.seed(2020) a.earth.sex <- earth(sex~., data=tita, degree=2, nfold=3, ncross=3, varmod.method="lm") plotmo1(a.earth.sex) plotmo1(a.earth.sex, level=.9) plotmo1(a.earth.sex, type="class") expect.err(try(plotmo1(a.earth.sex, level=.9, degree2=0, type="class")), "predicted values are strings") # tita[,3] is sex set.seed(2020) mod.earth.tita <- earth(tita[,-3], tita[,3], degree=2, nfold=3, ncross=3, varmod.method="lm") plotmo1(mod.earth.tita) plotmo1(mod.earth.tita, level=.9, degree2=0) plotmo1(mod.earth.tita, type="class") expect.err(try(plotmo1(mod.earth.tita, level=.9, degree2=0, type="class")), "predicted values are strings") set.seed(2020) mod.earth.sex <- earth(sex~., data=tita, degree=2, nfold=3, ncross=3, varmod.method="earth", glm=list(family=binomial)) plotmo1(mod.earth.sex) plotmo1(mod.earth.sex, type="link") plotmo1(mod.earth.sex, type="class") plotmo1(mod.earth.sex, level=.9, type="earth") # tita[,3] is sex set.seed(2020) mod.earth.tita <- earth(tita[,-3], tita[,3], degree=2, nfold=3, ncross=3, varmod.method="earth", glm=list(family=binomial)) plotmo1(mod.earth.tita) plotmo1(mod.earth.tita, type="link") plotmo1(mod.earth.tita, type="class") plotmo1(mod.earth.tita, level=.9, type="earth") # check factor handling when factors are not ordered alphabetically tita.orgpclass <- etitanic[seq(1, nrow(etitanic), by=12), ] tita <- get.tita() tita$logage <- NULL tita.orgpclass$parch <- NULL stopifnot(names(tita.orgpclass) == names(tita)) a.tita.orgpclass <- earth(pclass~., degree=2, data=tita.orgpclass) a.tita <- earth(pclass~., degree=2, data=tita) options(warn=2) # treat warnings as errors expect.err(try(plotmo(a.tita)), "Defaulting to nresponse=1, see above messages") options(warn=1) # following two graphs should be identical plotmo1(a.tita.orgpclass, nresponse="1st", all1=T, col.resp=3, type2="im") plotmo1(a.tita, nresponse="first", all1=T, col.resp=3, type2="im") # following two graphs should be identical plotmo1(a.tita.orgpclass, nresponse="2nd", all1=T) plotmo1(a.tita, nresponse="class2", all1=T) tita <- get.tita() mod.earth.pclass <- earth(pclass~., data=tita, degree=2) options(warn=2) # treat warnings as errors expect.err(try(plotmo1(mod.earth.pclass)), "Defaulting to nresponse=1, see above messages") options(warn=1) plotmo1(mod.earth.pclass, nresponse="fi") plotmo1(mod.earth.pclass, nresponse="first") plotmo1(mod.earth.pclass, nresponse=3) plotmo1(mod.earth.pclass, type="class") plotmo1(mod.earth.pclass, nresponse=1, type="class", grid.levels=list(sex="fem"), smooth.col="indianred", smooth.lwd=2, pt.col=as.numeric(tita$pclass)+1, pt.pch=1) # tita[,1] is pclass mod.earth.tita <- earth(tita[,-1], tita[,1], degree=2) options(warn=2) # treat warnings as errors expect.err(try(plotmo1(mod.earth.tita)), "Defaulting to nresponse=1, see above messages") options(warn=1) plotmo1(mod.earth.tita, nresponse="first") plotmo1(mod.earth.tita, type="class") mod.earth.pclass2 <- earth(pclass~., data=tita, degree=2, glm=list(family=binomial)) # expect.err(try(plotmo1(mod.earth.pclass2)), "nresponse is not specified") plotmo1(mod.earth.pclass2, nresponse=3) plotmo1(mod.earth.pclass2, type="link", nresponse=3) plotmo1(mod.earth.pclass2, type="class") # tita[,1] is pclass mod.earth.tita <- earth(tita[,-1], tita[,1], degree=2, glm=list(family=binomial)) plotmo1(mod.earth.tita, nresponse=3) plotmo1(mod.earth.tita, type="link", nresponse=3) plotmo1(mod.earth.tita, type="class") # plotmo vignette examples # use a small set of variables for illustration printf("library(earth)\n") library(earth) # for ozone1 data data(ozone1) oz <- ozone1[, c("O3", "humidity", "temp", "ibt")] lm.model.vignette <- lm(O3 ~ humidity + temp*ibt, data=oz) # linear model plotmo1(lm.model.vignette, pt.col="gray", nrug=-1) plotmo1(lm.model.vignette, level=.9) printf("library(mda)\n") library(mda) mars.model.vignette1 <- mars(oz[,-1], oz[,1], degree=2) plotmo1(mars.model.vignette1) plotres1(mars.model.vignette1) mars.model.vignette2 <- mars(oz[,-1,drop=FALSE], oz[,1,drop=FALSE], degree=2) plotmo1(mars.model.vignette2) # TODO causes Error in lm.fit(object$x, y, singular.ok = FALSE) : (list) object cannot be coerced to type 'double' # although still works # the error is mars.to.earth try(hatvalues.lm.fit(lm.fit(object$x, y, singular.ok=FALSE))) plotres1(mars.model.vignette2, trace=1) printf("library(rpart)\n") library(rpart) # rpart rpart.model.vignette <- rpart(O3 ~ ., data=oz) plotmo1(rpart.model.vignette, all2=TRUE) expect.err(try(plotmo1(rpart.model.vignette, level=.9)), "the level argument is not supported for \"rpart\" objects") # commented out because is slow and already tested in test.non.earth.R # printf("library(randomForest)\n") # library(randomForest) # randomForest # rf.model.vignette <- randomForest(O3~., data=oz) # plotmo1(rf.model.vignette) # partialPlot(rf.model.vignette, oz, temp) # compare to partial-dependence plot printf("library(gbm)\n") library(gbm) # gbm set.seed(2016) gbm.model.vignette <- gbm(O3~., data=oz, dist="gaussian", inter=2, n.trees=100) # commented out following because they always take the whole page # plot(gbm.model.vignette, i.var=2) # compare to partial-dependence plots # plot(gbm.model.vignette, i.var=c(2,3)) set.seed(2016) plotmo1(gbm.model.vignette, caption="gbm.model.vignette") # commented out because is slow and already tested elsewhere # printf("library(mgcv)\n") # library(mgcv) # gam # gam.model.vignette <- gam(O3 ~ s(humidity)+s(temp)+s(ibt)+s(temp,ibt), data=oz) # plotmo1(gam.model.vignette, level=.95, all2=TRUE) printf("library(nnet)\n") library(nnet) # nnet set.seed(4) nnet.model.vignette <- nnet(O3~., data=scale(oz), size=2, decay=0.01, trace=FALSE) plotmo1(nnet.model.vignette, type="raw", all2=T) printf("library(MASS)\n") library(MASS) # qda lcush <- data.frame(Type=as.numeric(Cushings$Type),log(Cushings[,1:2])) lcush <- lcush[1:21,] qda.model.vignette <- qda(Type~., data=lcush) plotmo1(qda.model.vignette, type="class", all2=TRUE, type2="contour", ngrid2=100, contour.nlevels=2, contour.drawlabels=FALSE, pt.col=as.numeric(lcush$Type)+1, pt.pch=as.character(lcush$Type)) # miscellaneous other examples tita <- get.tita() mod.glm.sex <- glm(sex~., data=tita, family=binomial) plotmo1(mod.glm.sex, pt.col=as.numeric(tita$pclass)+1) # tita[,4] is age, tita[,1] is pclass printf("library(lars)\n") library(lars) set.seed(2015) xmat <- as.matrix(tita[,c(2,5,6)]) mod.lars.xmat <- lars(xmat, tita[,4]) par(mfrow=c(2,2)) plot(mod.lars.xmat) plotmo1(mod.lars.xmat, nresponse=4, do.par=F) plotres(mod.lars.xmat, trace=0, nresponse=4) if(0) { # TODO fails with R-3.4.2: object '.QP_qpgen2' not found printf("library(cosso)\n") library(cosso) set.seed(2016) cosso <- cosso(xmat,tita[,4],family="Gaussian") # TODO tell maintainer of cosso that you have to do this class(cosso) <- "cosso" set.seed(2016) plotmo1(cosso) set.seed(2016) plotres(cosso) } # examples from James, Witten, et al. ISLR book # I tested all models in their scripts manually. # All worked except for exceptions below. printf("library(pls)\n") library(pls) printf("library(ISLR)\n") library(ISLR) Hitters=na.omit(Hitters) set.seed(1) x <- model.matrix(Salary~.,Hitters)[,-1] y <- Hitters$Salary train=sample(1:nrow(x), nrow(x)/2) pcr.fit1=pcr(Salary~., data=Hitters,subset=train,scale=TRUE, validation="CV") plotmo1(pcr.fit1, nresponse=10) # set.seed(1) # x <- model.matrix(Salary~.,Hitters)[,-1] # y <- Hitters$Salary # train=sample(1:nrow(x), nrow(x)/2) # pcr.fit2=pcr(y~x,scale=TRUE,ncomp=7) # # TODO following gives Error: predictions returned the wrong length (got 263 but expected 50) # plotmo1(pcr.fit2, nresponse=5) library(splines) fit.lm2=lm(wage~bs(age,knots=c(25,40,60)),data=Wage) par(mfrow=c(1,2),mar=c(4.5,4.5,1,1),oma=c(0,0,4,0)) agelims=range(Wage$age) age.grid=seq(from=agelims[1],to=agelims[2]) pred=predict(fit.lm2,newdata=list(age=age.grid),se=T) plot(Wage$age,Wage$wage,col="gray", ylim=c(0,320)) lines(age.grid,pred$fit,lwd=2) lines(age.grid,pred$fit+2*pred$se,lty="dashed") lines(age.grid,pred$fit-2*pred$se,lty="dashed") fit.lm2=lm(wage~bs(age,knots=c(25,40,60)),data=Wage,model=F) # TODO delete plotmo1(fit.lm2, col.resp=2, do.par=F, level=.95, ylim=c(0,320), nrug=TRUE, caption="fit.lm2", ylab="wage") fit.glm2 <- glm(I(wage>250)~poly(age,4),data=Wage,family=binomial) par(mfrow=c(1,2),mar=c(4.5,4.5,1,1),oma=c(0,0,4,0)) agelims=range(Wage$age) age.grid=seq(from=agelims[1],to=agelims[2]) # their plot preds=predict(fit.glm2,newdata=list(age=age.grid),se=T) pfit=exp(preds$fit)/(1+exp(preds$fit)) se.bands.logit = cbind(preds$fit+2*preds$se.fit, preds$fit-2*preds$se.fit) se.bands = exp(se.bands.logit)/(1+exp(se.bands.logit)) preds=predict(fit.glm2,newdata=list(age=age.grid),type="response",se=T) plot(Wage$age,I(Wage$wage>250),xlim=agelims,type="n",ylim=c(0,.2)) points(jitter(Wage$age), I((Wage$wage>250)/5),cex=.5,pch="|",col="darkgrey") lines(age.grid,pfit,lwd=2, col="blue") matlines(age.grid,se.bands,lwd=1,col="blue",lty=3) # plotmo plot, side by side # TODO Warning: the level argument may not be properly supported on glm objects built with weights plotmo1(fit.glm2, level=.95, degree1.col="blue", ylim=c(0,.2), do.par=FALSE, nrug=-1, caption="fit.glm2", ylab="I(wage > 250)") # Test deparsing of the formula in plotmo.pairs.default # TODO Height is included in the plots even though formula says -Height Height2 <- trees$Height^2 a <- lm(Volume~(Girth*Height2)-Height, data=trees, x=TRUE, model=FALSE) plotmo(a) # test "the variable on the right side of the formula is a matrix or data.frame" # TODO would like to solve this problem options(warn=2) data(gasoline, package="pls") earth.octane <- earth(octane ~ NIR, data=gasoline) print(summary(earth.octane)) # ok plotres(earth.octane) # ok expect.err(try(plotmo(earth.octane)), "the variable on the right side of the formula is a matrix or data.frame") options(warn=1) # TODO May 2020 'ElemStatLearn' is not available (for R version 4.0.0) # library(ElemStatLearn) # x <- mixture.example$x # g <- mixture.example$y # lm.mixture.example <- lm(g ~ x) # options(warn=2) # expect.err(try(plotmo(lm.mixture.example)), "the variable on the right side of the formula is a matrix or data.frame") # options(warn=1) # test variable names with $ are not supported a <- earth(O3~ozone1$doy, data=ozone1) expect.err(try(plotmo(a)), "cannot get the original model predictors") a <- earth(O3~ozone1$doy + temp, data=ozone1) expect.err(try(plotmo(a)), "cannot get the original model predictors") a <- lm(O3~ozone1$doy, data=ozone1) expect.err(try(plotmo(a)), "cannot get the original model predictors") a <- lm(O3~ozone1$doy + temp, data=ozone1) expect.err(try(plotmo(a)), "cannot get the original model predictors") #--- test interaction of w1. and non w1 args ------------------------------------- par(mfrow=c(4,3), mar=c(3, 3, 4, 1), mgp=c(2, 0.6, 0)) mod78 <- earth(Volume ~ ., data = trees) par(mfrow=c(3,4), mar=c(3, 3, 3, 1), mgp=c(2, 0.6, 0)) # multiple which, earth model plotres(mod78, cex.main=1, ylim=c(-.5, .8), xlim=c(-2, 7), col=2:3, do.par=FALSE, w1.main=c("ylim=c(-.5, .8)\nxlim=c(-2, 7) col=2:3")) # multiple which, earth model plotres(mod78, cex.main=.7, w1.ylim=c(-.5, .8), w1.xlim=c(-2, 7), col=2:3, do.par=FALSE, ylim=c(-10,10), xlim=c(-30, 100), w1.main=c("w1.ylim=c(-.5, .8) w1.xlim=c(-2, 7)\nylim=c(-10,10), xlim=c(-30, 100)")) par(org.par) par(mfrow=c(3,4), mar=c(3, 3, 3, 1), mgp=c(2, 0.6, 0)) # which=1, earth model plotres(mod78, which=1, cex.main=.8, col=2:3, main="which=1, no other ylim args", w1.main="which=1, no other ylim args") plotres(mod78, which=1, cex.main=.8, col=2:3, w1.ylim=c(.3,.98), w1.xlim=c(-2, 7), main="w1.ylim=c(.3,.98)\nw1.xlim=c(-2, 7)") plotres(mod78, which=1, cex.main=.8, col=2:3, ylim=c(.3,.98), xlim=c(-2, 7), main="ylim=c(.3,.98)\nxlim=c(-2, 7)") # ylim gets passed to modsel plotres(mod78, which=1, cex.main=.75, col=2:3, w1.ylim=c(.3,.98), ylim=c(-.5,.5), w1.xlim=c(-2, 7), xlim=c(-90, 90), main="w1.ylim=c(.3,.98), ylim=c(-.5,.5)\nw1.xlim=c(-2, 7), xlim=c(-90, 90)") # ignore ylim # which=3, earth model plotres(mod78, which=3, cex.main=1, col=2:3, main="which=3, no other ylim args") plotres(mod78, which=3, cex.main=1, col=2:3, w1.ylim=c(.3,.98), w1.xlim=c(-2, 7), main="w1.ylim=c(.3,.98)\nw1.xlim=c(-2, 7)") # not usual, ignore w1.ylim plotres(mod78, which=3, cex.main=1, col=2:3, ylim=c(-10,10), xlim=c(-90,90), main="which=3, ylim=c(-10,10)\nxlim=c(-90,90)") plotres(mod78, which=3, cex.main=1, col=2:3, w1.ylim=c(.3,.98), ylim=c(-10,10), w1.xlim=c(-2, 7), xlim=c(-90,90), main="w1.ylim=c(.3,.98) ylim=c(-10,10)\nw1.xlim=c(-2, 7), xlim=c(-90,90)") par(org.par) nullarg <- NULL expect.err(try(plotmo(nullarg)), "argument 'nullarg' is NULL") expect.err(try(plotmo(NULL)), "argument 'NULL' is NULL") expect.err(try(plotmo(0)), "'0' is not an S3 model") expect.err(try(plotmo(list(1,2))), "'list(1, 2)' is a plain list, not an S3 model") expect.err(try(plotmo(list(1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0))), "object is a plain list, not an S3 model") source("test.epilog.R") plotmo/inst/slowtests/test.fac.bat0000755000176200001440000000154214563571565017035 0ustar liggesusers@rem test.fac.bat: test factor plotting in plotmo. This also tests swapxy, xflip, and yflip @rem Stephen Milborrow, Berea Mar 2011 @echo test.fac.bat @"C:\PROGRA~1\R\R-4.3.2\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.fac.R @if %errorlevel% equ 0 goto good1: @echo R returned errorlevel %errorlevel%, see test.fac.Rout: @echo. @tail test.fac.Rout @echo test.fac.R @exit /B 1 :good1 mks.diff test.fac.Rout test.fac.Rout.save @if %errorlevel% equ 0 goto good2: @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.fac.save.ps @exit /B 1 :good2 @rem test.fac.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.fac.save.ps @if %errorlevel% equ 0 goto good3: @echo === Files are different === @exit /B 1 :good3 @rm -f test.fac.Rout @rm -f Rplots.ps @exit /B 0 plotmo/inst/slowtests/test.plotres.Rout.save0000644000176200001440000003563314563614021021102 0ustar liggesusers> # test.plotres.R > > source("test.prolog.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix > data(ozone1) > data(etitanic) > example(plotres) plotrs> # we use lm in this example, but plotres is more useful for models plotrs> # that don't have a function like plot.lm for plotting residuals plotrs> plotrs> lm.model <- lm(Volume~., data=trees) plotrs> plotres(lm.model) > > # basic tests of plotmo on abbreviated titanic data > > get.tit <- function() + { + tit <- etitanic + pclass <- as.character(tit$pclass) + # change the order of the factors so not alphabetical + pclass[pclass == "1st"] <- "first" + pclass[pclass == "2nd"] <- "class2" + pclass[pclass == "3rd"] <- "classthird" + tit$pclass <- factor(pclass, levels=c("class2", "classthird", "first")) + # log age is so we have a continuous predictor even when model is age~. + set.seed(2015) + tit$logage <- log(tit$age) + rnorm(nrow(tit)) + tit$parch <- NULL + # by=12 gives us a small fast model with an additive and a interaction term + tit <- tit[seq(1, nrow(etitanic), by=12), ] + } > > tit <- get.tit() > > plotlm1 <- function(object) + { + old.par <- par(no.readonly=TRUE) + on.exit(par(old.par)) + par(mfrow=c(2,2), oma=c(0,0,3,0), mar=c(4, 3, 3, 1.5), + mgp=c(1.5, 0.4, 0), tcl=-.3, font.main=1, cex.main=1) + plot(object, sub.caption="standard call to plot.lm") + } > plotlm.using.plotres <- function(object) + { + old.par <- par(no.readonly=TRUE) + on.exit(par(old.par)) + par(mfrow=c(2,2), oma=c(0,0,3,0), mar=c(4, 3, 3, 1.5), + mgp=c(1.5, 0.4, 0), tcl=-.3, font.main=1, cex.main=1) + # residuals vs fitted + plotres(object, pch=1, which=3, + caption=paste(deparse(object$call), collapse=" ")) + # QQ plot + plotres(object, pch=1, which=4, standardize=TRUE) + # scale-location plot + plotres(object, pch=1, which=6, standardize=TRUE) + # leverage plot + plotres(object, pch=1, which=3, versus=4, standardize=TRUE) + } > lm.mod <- lm(Volume~., data=trees) > plotlm1(lm.mod) > plotlm.using.plotres(lm.mod) > > # various arguments > > plotres(lm.mod, SHOWCALL=TRUE) > plotres(lm.mod, level=.95, id.n=-3, SHOWCALL=TRUE) > lm.tit <- lm(survived~., data=tit) > col <- ifelse(tit$survived, "green", "red") > pch <- ifelse(tit$sex == "male", 20, 6) > plotres(lm.tit, level=.95, col=col, pch=pch, + level.shade="gray", level.shade2="lightgray", SHOWCALL=TRUE) > plotres(lm.tit, col.resp=3, cum.col=2, cum.cex=1.2, grid.col=5, qq.col=1, qq.cex=.3, SHOWCALL=TRUE) > plotres(lm.tit, pt.col="pink", smooth.col=0, SHOWCALL=TRUE) > plotres(lm.tit, smooth.col=3, smooth.lwd=1.2, smooth.lty=2, smooth.f=.2, + label.col=4, label.cex=.9, label.font=2, SHOWCALL=TRUE) > foo <- function() + { + afoo <- earth(O3~., data=ozone1, deg=2) + old.par <- par(no.readonly=TRUE) + on.exit(par(old.par)) + par(mfrow=c(2,2), oma=c(0,0,3,0), mar=c(4, 3, 3, 1.5), + mgp=c(1.5, 0.4, 0), tcl=-.3, font.main=1, cex.main=1) + # test xlim ylim etc. on qq and cum plots + plotres(afoo, which=2, trace=0, xlim=c(0,20), ylim=c(-.2,1.1), grid.col="pink", info=TRUE) + plotres(afoo, which=2, trace=0, + grid.col="pink", info=TRUE, cum.col=2, cum.cex=1.4) + plotres(afoo, which=4) + plotres(afoo, which=4, trace=0, xlim=c(-7,7), ylim=c(-20, 20), + qq.col=2, qq.cex=.5, label.col=1, qqline.col="orange", qqline.lty=1) + # check xlim and ylim apply only to resids plots if multiple plots + plotres(afoo, which=c(2:5), trace=0, xlim=c(-1,5), ylim=c(-8, 8), + qq.col=2, qq.cex=.5, label.col=1, qqline.col="orange", smooth.col=3, smooth.lwd=2) + } > foo() > > # test id.n and npoints > set.seed(1066) > a20 <- earth(Volume~., data=trees, ncr=3, nfo=3, varmod.method="lm", keepxy=TRUE) > par(mfrow=c(2,2), oma=c(0,0,3,0), mar=c(4, 3, 3, 1.5), mgp=c(1.5, 0.4, 0), tcl=-.3, cex=1) > plot(a20, which=3, standardize=TRUE, smooth.col=0, id.n=-1, main="a20-00, smooth.col=0, id.n=-1", + caption="test id.n and npoints") > plot(a20, which=3, standardize=TRUE, smooth.col=0, id.n=10, main="a20-01, smooth.col=0, id.n=10") > # this tests cex with do.par=FALSE > plot(a20, which=3, standardize=TRUE, smooth.col=0, npoints=10, cex=.8, main="a20-02, smooth.col=0, npoints=10, cex=.8") > # TODO labels are hosed in the following > plot(a20, which=3, standardize=TRUE, smooth.col=0, npoints=5, id.n=10, main="a20-03, labels hosed\nsmooth.col=0, npoints=10, id.n=10") > > # test leverages and handling of unity leverages > lm.mod <- lm(Volume~., data=trees) > par(mfrow=c(2,2), oma=c(0,0,3,0), mar=c(4, 3, 3, 1.5), mgp=c(1.5, 0.4, 0), tcl=-.3, cex=1) > a20$leverages[31] <- 1 # fake a unity leverage > plot(a20, which=3, versus=4, standardize=TRUE, main="resids vs leverage\nunity leverage", + caption="leverage plots") > plotres(a20, which=3, standardize=TRUE, main="resids vs fitted\nunity leverage") > plotres(lm.mod, which=3, versus=4, standardize=TRUE, main="lever plot for lm.mod") > plotres(lm.mod, which=3, versus=4, standardize=TRUE, main="cook args", + cook.levels=c(.5, .8, 1), cook.col="blue", cook.lty=2) > > plot(a20, which=3, versus=4, standardize=TRUE, info=TRUE, main="resids vs leverage\nunity leverage", + caption="leverage plots with info=TRUE") > plotres(a20, which=3, standardize=TRUE, info=TRUE, main="resids vs fitted\nunity leverage") > plotres(lm.mod, which=3, versus=4, standardize=TRUE, info=TRUE, main="lever plot for lm.mod") > plotres(lm.mod, which=3, versus=4, standardize=TRUE, info=TRUE, main="cook args", + cook.levels=c(.5, .8, 1), cook.col="blue", cook.lty=2) > > # back compat tests > par(mfrow=c(2,2), oma=c(0,0,3,0), mar=c(4, 3, 3, 1.5), mgp=c(1.5, 0.4, 0), tcl=-.3) > plotres(a20, which=3, col.smooth=4, smooth.lwd=2, smooth.lty=2, + main="a20-04 col.smooth=4, smooth.lwd=2, smooth.lty=2", + caption="back compat tests with plot.earth") > plotres(a20, which=4, qq.col=3, + qqline.col="lightblue", qqline.lty=2, main="a20-05 qq.col=3") > plotres(a20, which=4, qqline.col=0, main="a20-06 qqline.col=0") > # set.seed(1066) > # mod.earth.tit <- earth(tit[,-3], tit[,3], degree=2, nfold=3, ncross=3, varmod.method="earth", keepxy=TRUE) > plot(0,0) > plot(a20, which=1, col.grid="pink", col.rsq=3, lty.rsq=1, main="a20-07 col.grid=\"pink\", col.rsq=3, lty.rsq=1") > > # TODO following not working? > plot(a20, which=3, col.cv=4, col.grid="pink", main="a20-08 col.cv=4, col.grid=\"pink\"") > > plot(a20, which=3, col.points="orange", cex.points=1.5, main="a20-09 col.points=\"orange\", cex.points=1.5") > plot(a20, which=3, col.residuals="orange", smooth.f=.2, col.line=3, main="a20-10 col.residuals=\"orange\", smooth.f=.2, col.line=3") > > # test graphics args outside do.par > par(col.main="#456789") > cat("before par: cex=", par("cex"), " col.main=", par("col.main"), " col.axis=", par("col.axis"), "\n", sep="") before par: cex=0.83 col.main=#456789 col.axis=black > plot(a20, which=c(2,3), caption="a20 which=c(2,3) (i.e. do.par=TRUE) no cex") > plot(a20, which=c(2,3), cex=1, caption="a20 which=c(2,3) (i.e. do.par=TRUE) cex=1, plot should be identical to previous page") > plot(a20, which=c(2,3), cex=1.2, caption="a20 which=c(2,3) (i.e. do.par=TRUE) cex=1.2") > plot(a20, which=3, main="no cex", caption="a20 test graphics args with do.par=FALSE") > plot(a20, which=3, cex=1, main="cex=1") > plot(a20, which=3, cex=.8, main="cex=.8") > plot(a20, which=3, cex=1.1, col.main=2, col.axis="blue", col.lab=3, font.lab=2, + main="cex=1.1, col.main=2, col.axis=\"blue\", col.lab=3, font.lab=2") > # all of these should have been restored > cat("after par: cex=", par("cex"), " col.main=", par("col.main"), " col.axis=", par("col.axis"), "\n", sep="") after par: cex=0.83 col.main=#456789 col.axis=black > stopifnot(par("col.main") == "#456789") > par(col.main=1) > > survived <- as.numeric(tit$survived) # 0 or 1 > sex <- as.numeric(tit$sex) # 1 or 2 > pclass <- as.numeric(tit$pclass) # 1,2, or 3 > age <- tit$age # .2 to 80 > > printf("======== basic operation, compare to plot.lm etc.\n") ======== basic operation, compare to plot.lm etc. > par(mfrow=c(2,2), mar=c(3,3,3,1), mgp=c(1.5,0.5,0), oma=c(0,0,2.5,0)) > lm <- lm(survived~sex+pclass+age) > plot(lm, which=5, pch=20) > plot(0, 0) > plot(lm, which=1, pch=20) > plot(lm, which=2, pch=20) > plotres(lm, standardize=1, cook.levels=c(.1,.2,.3), SHOWCALL=TRUE) > elm <- earth(survived~sex+pclass+age, linpreds=TRUE, thresh=0, penalty=-1) > plotres(elm, col=survived+2, SHOWCALL=TRUE) > set.seed(2015) > elm.glm <- earth(survived~sex+pclass+age, linpreds=TRUE, thresh=0, penalty=-1, + glm=list(family=binomial), + ncr=3, nfold=3, varmod.method="lm") > plotres(elm.glm, col=survived+2, SHOWCALL=TRUE) > > printf("======== check type arg with earth\n") ======== check type arg with earth > par(mfrow=c(2,2), mar=c(3,3,3,1), mgp=c(1.5,0.5,0), oma=c(0,0,2.5,0)) > # following two are equivalent > # TODO $$ following look wrong (the plots have changed from plotmo/earth pre Sep 2020) > plotres(elm.glm, col=survived+2, standardize=TRUE, + which=3, do.par=FALSE, main="standardize=TRUE") > mtext("elm.glm with various type options", outer=TRUE, font=2, line=1, cex=1) > plotres(elm.glm, col=survived+2, type="standardize", + which=3, do.par=FALSE, main="type=\"standardize\"\nequivalent to standardize=TRUE") > # TODO double standardization, should not be allowed > plotres(elm.glm, col=survived+2, standardize=TRUE, type="standardize", + which=3, do.par=FALSE, + main="standard=TRUE, type=\"deviance\"\ndouble standardization") > plotres(elm.glm, col=survived+2, type="deviance", + which=3, do.par=FALSE, main="type=\"deviance\"") > > printf("======== multiple response earth models\n") ======== multiple response earth models > par(mfrow=c(2,2), mar=c(3,3,3,1), mgp=c(1.5,0.5,0), oma=c(0,0,2.5,0)) > set.seed(2015) > emulti0 <- earth(cbind(Volume, Volume + 100 + 5 * rnorm(nrow(trees)))~., data=trees) > set.seed(2015) > plot(emulti0, nresponse=2, which=3, do.par=FALSE, main="emulti0 nresponse=2") > set.seed(2015) > rnorm1 <- rnorm(nrow(trees)) > emulti <- earth(cbind(Volume, Volume + 100 + 5 * rnorm1)~., data=trees) > plot(emulti, nresponse=2, + which=3, do.par=FALSE, main="emulti nresponse=2") > mtext("multiple response earth models", outer=TRUE, font=2, line=1, cex=1) > plot(emulti, nresponse=2, FORCEPREDICT=TRUE, + which=3, do.par=FALSE, main="emulti, nresponse=2\nFORCEPREDICT=TRUE") > > printf("======== earth model with a factor response\n") ======== earth model with a factor response > epclass <- earth(pclass~., data=tit) > par(mfrow=c(2,2), mar=c(3,3,3,1), mgp=c(1.5,0.5,0), oma=c(0,0,2.5,0)) > set.seed(2015) > plot(epclass, nresponse="first", trace=1, + which=3, do.par=FALSE, main="pclass response, nresponse=\"first\"") stats::residuals(object=earth.object, type="response") stats::fitted(object=earth.object) got model response from model.frame(pclass ~ survived + sex + age + sibsp..., data=call$data, na.action="na.fail") training rsq 0.23 > mtext("earth model with a factor response", outer=TRUE, font=2, line=1, cex=1) > plot(epclass, nresponse="first", trace=1, FORCEPREDICT=TRUE, + which=3, do.par=FALSE, + main="pclass response, nresponse=\"first\"\nFORCEPREDICT=TRUE") stats::predict(earth.object, NULL, type="response") stats::fitted(object=earth.object) got model response from model.frame(pclass ~ survived + sex + age + sibsp..., data=call$data, na.action="na.fail") training rsq 0.23 > > printf("======== glm\n") ======== glm > glm <- glm(survived~sex+pclass+age, family=binomial) > par(mfrow=c(2,2), mar=c(3,3,3,1), mgp=c(1.5,0.5,0), oma=c(0,0,2.5,0)) > plot(glm, which=1, pch=20, main="plot.lm") > mtext("glm model with plot.lm and plotres", outer=TRUE, font=2, line=1, cex=1) > plotres(glm, which=3, main="plotres glm survived") > # with plotres we can also plot pearson etc. residuals > plotres(glm, which=3, type="pearson", main="plotres glm survived\ntype=\"pearson\"") > > printf("======== rpart\n") ======== rpart > library(rpart) > par(mfrow=c(2,2), mar=c(3,3,3,1), mgp=c(1.5,0.5,0), oma=c(0,0,2.5,0)) > rpart <- rpart(survived~sex+pclass+age) > plotres(rpart, SHOWCALL=TRUE) > plotres(rpart, SHOWCALL=TRUE, FORCEPREDICT=TRUE) # identical > # TODO following fails in plotmo.predict.rpart (which is called to get the fitted values) > # plotres(rpart, type="pearson") > plotres(rpart, jitter=3, w1.extra=100, w1.under=TRUE, w1.branch.type=5, + col=survived+2, smooth.col=NA, label.col=1, SHOWCALL=TRUE) > > fit <- rpart(Kyphosis ~ Age + Number + Start, data = kyphosis) > plotres(fit, nresponse=1, SHOWCALL=TRUE, jitter=5) > plotres(fit, nresponse=2, SHOWCALL=TRUE, jitter=TRUE) > > printf("======== versus=\"b:\"\n") ======== versus="b:" > > library(gam) Loading required package: splines Loading required package: foreach Loaded gam 1.22-3 > gam.package.loaded <- "package:gam" %in% search() > mgcv.package.loaded <- "package:mgcv" %in% search() > if(mgcv.package.loaded && gam.package.loaded) { + # prevent downstream confusing error messages + stop0("both 'gam' and 'mgcv' are loaded") + } > library(earth) > data(ozone1) > data(ozone1) > oz <- ozone1[, c("O3", "humidity", "temp", "ibt")] > gam.mod <- gam(O3^(1/3) ~ lo(humidity)+lo(ibt,temp), data=oz) > plotmo(gam.mod, SHOWCALL=TRUE) plotmo grid: humidity ibt temp 64 167.5 62 > plotres(gam.mod, SHOWCALL=TRUE) > plotres(gam.mod, versus="b:", SHOWCALL=TRUE) > plotres(gam.mod, versus="b:ib", info=TRUE, SHOWCALL=TRUE) > > gam.linear.humidity.only <- gam(O3^(1/3) ~ humidity, data=oz) > plotres(gam.linear.humidity.only, versus="b:", SHOWCALL=TRUE) > > library(mda) Loading required package: class Loaded mda 0.5-4 > mars <- mars(ozone1[,2:3], ozone1[,1], degree=2) > mars.to.earth <- mars.to.earth(mars) Converted mars(x=ozone1[,2:3], y=ozone1[,1], degree=2) to earth(x=ozone1[,2:3], y=ozone1[,1], degree=2) > plotres(mars, versus="b:", caption="mars model, versus=\"b:\"", SHOWCALL=TRUE) > plotres(mars.to.earth, versus="b:", caption="earth model, versus=\"b:\", should be same as previous page", SHOWCALL=TRUE) > plotres(mars, versus="b:1", caption="mars model, versus=\"b:1\"", SHOWCALL=TRUE) > > # lars is tested in plotmo3.R > # gbm is tested in plotmo3.R > # TODO fda is not tested > > source("test.epilog.R") plotmo/inst/slowtests/test.parsnip.R0000644000176200001440000002740614564116107017403 0ustar liggesusers# test.parsnip.R: test the parsnip package with earth and other models # Stephen Milborrow Sep 2020 Petaluma source("test.prolog.R") options(warn=1) # print warnings as they occur library(earth) cat("loading parsnip libraries\n") # these libraries take several seconds to load library(tidymodels, quietly=TRUE, verbose=FALSE) library(timetk) library(lubridate) cat("loaded parsnip libraries\n") cat("parsnip version:", as.character(packageVersion("parsnip")[[1]]), "\n") vdata <- data.frame( resp = 1:23, bool = c(F, F, F, F, F, T, T, T, T, T, T, T, T, F, F, T, T, T, T, T, T, T, T), ord = ordered(c("ORD1", "ORD1", "ORD1", "ORD1", "ORD1", "ORD1", "ORD1", "ORD3", "ORD1", "ORD2", "ORD2", "ORD2", "ORD2", "ORD2", "ORD2", "ORD2", "ORD3", "ORD3", "ORD3", "ORD2", "ORD2", "ORD2", "ORD2"), levels=c("ORD1", "ORD3", "ORD2")), fac = as.factor(c("FAC1", "FAC1", "FAC1", "FAC2", "FAC2", "FAC2", "FAC3", "FAC1", "FAC1", "FAC1", "FAC2", "FAC2", "FAC2", "FAC2", "FAC2", "FAC2", "FAC3", "FAC3", "FAC3", "FAC1", "FAC3", "FAC3", "FAC3")), str = c("STR1", "STR1", "STR1", # WILL BE TREATED LIKE A FACTOR "STR1", "STR1", "STR1", "STR2", "STR2", "STR2", "STR3", "STR3", "STR2", "STR3", "STR2", "STR3", "STR2", "STR3", "STR3", "STR3", "STR3", "STR3", "STR3", "STR3"), num = c(1, 9, 2, 3, 14, 5, 6, 4, 5, 6.5, 3, 6, 5, 3, 4, 5, 6, 4, 5, 16.5, 3, 16, 15), sqrt_num = sqrt( c(1, 9, 2, 3, 14, 5, 6, 4, 5, 6.5, 3, 6, 5, 3, 4, 5, 6, 4, 5, 16.5, 3, 16, 15)), int = c(1L, 1L, 3L, 3L, 4L, 4L, 3L, 5L, 3L, 6L, 7L, 8L, 10L, 13L, 14L, 3L, 13L, 5L, 13L, 16L, 17L, 18L, 11L), date = as.Date( c("2018-08-01", "2018-08-02", "2018-08-03", "2018-08-04", "2018-08-05", "2018-08-06", "2018-08-07", "2018-08-08", "2018-08-08", "2018-08-10", "2018-08-10", "2018-08-11", "2018-08-11", "2018-08-11", "2018-08-12", "2018-08-13", "2018-08-10", "2018-08-15", "2018-08-17", "2018-08-04", "2018-08-19", "2018-08-03", "2018-08-18")), date_num = as.numeric(as.Date( c("2018-08-01", "2018-08-02", "2018-08-03", "2018-08-04", "2018-08-05", "2018-08-06", "2018-08-07", "2018-08-08", "2018-08-08", "2018-08-10", "2018-08-10", "2018-08-11", "2018-08-11", "2018-08-11", "2018-08-12", "2018-08-13", "2018-08-10", "2018-08-15", "2018-08-17", "2018-08-04", "2018-08-19", "2018-08-03", "2018-08-18")))) set.seed(2020) splits <- initial_time_split(vdata, prop=.9) #--- lm ---------------------------------------------------------------------- lm1 <- lm(resp~num+fac:int+date+ord+str, data=training(splits)) cat("lm1:\n") print(summary(lm1)) set.seed(2020) lmpar <- linear_reg(mode = "regression") %>% set_engine("lm") %>% fit(resp~num+fac:int+date+ord+str, data = training(splits)) stopifnot(identical(lm1$coeff, lmpar$fit$coeff)) predict.lm1 <- predict(lm1, testing(splits)) predict.lmpar <- lmpar %>% predict(testing(splits)) stopifnot(all(predict.lm1 == predict.lmpar)) par(mfrow = c(3, 3), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) plotmo(lm1, do.par=2, SHOWCALL=TRUE) plotres(lm1, which=c(3,1), do.par=FALSE) plotmo(lmpar, do.par=2, SHOWCALL=TRUE) plotres(lmpar, which=c(3,1), do.par=FALSE) plotmo(lmpar$fit, do.par=2, SHOWCALL=TRUE) plotres(lmpar$fit, which=c(3,1), do.par=FALSE) par(org.par) lmpar.sqrtnum <- linear_reg(mode = "regression") %>% set_engine("lm") %>% fit(resp~sqrt(num), data = training(splits)) #$$ TODO # expect.err(try(plotmo(lmpar.sqrtnum)), # "cannot get the original model predictors") #--- earth ------------------------------------------------------------------- # note that sqrt(num) is ok, unlike parsnip models for lm and rpart earth1 <- earth(resp~sqrt(num)+int+ord:bool+fac+str+date, degree=2, data=training(splits), pmethod="none") cat("earth1:\n") print(summary(earth1)) set.seed(2020) earthpar <- mars(mode = "regression", prune_method="none", prod_degree=2) %>% set_engine("earth") %>% fit(resp~sqrt(num)+int+ord:bool+fac+str+date, data = training(splits)) cat("earthpar:\n") print(earthpar) cat("summary(earthpar$fit)\n") print(summary(earthpar$fit)) stopifnot(identical(earth1$coeff, earthpar$fit$coeff)) predict.earth1 <- predict(earth1, testing(splits)) predict.earthpar <- earthpar %>% predict(testing(splits)) stopifnot(all(predict.earth1 == predict.earthpar)) par(mfrow = c(3, 3), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) plotmo(earth1, do.par=2, pt.col=3, SHOWCALL=TRUE) set.seed(2020) plotres(earth1, which=c(1,3), do.par=FALSE, pt.col=3, legend.pos="topleft") par(org.par) par(mfrow = c(3, 3), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) plotmo(earthpar, do.par=2, pt.col=3, SHOWCALL=TRUE) set.seed(2020) plotres(earthpar, which=c(1,3), do.par=FALSE, pt.col=3, legend.pos="topleft") par(org.par) par(mfrow = c(3, 3), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) plotmo(earthpar$fit, do.par=2, pt.col=3, SHOWCALL=TRUE) set.seed(2020) plotres(earthpar$fit, which=c(1,3), do.par=FALSE, pt.col=3, legend.pos="topleft") par(org.par) #--- rpart ------------------------------------------------------------------- library(rpart) library(rpart.plot) rpart1 <- rpart(resp~num+fac+int+date+ord+str, data=training(splits), control=rpart.control(minsplit=1, cp=.0001)) cat("\nrpart.rules(rpart1)\n") print(rpart.rules(rpart1)) set.seed(2020) # TODO note need of model=TRUE below (needed only for further processing with e.g. plotmo) rpartpar <- decision_tree(mode = "regression", min_n=1, cost_complexity=.0001) %>% set_engine("rpart", model=TRUE) %>% fit(resp~num+fac+int+date+ord+str, data = training(splits)) cat("\nrpart.rules(rpartpar$fit)\n") print(rpart.rules(rpartpar$fit)) predict.rpart1 <- predict(rpart1, testing(splits)) predict.rpartpar <- rpartpar %>% predict(testing(splits)) stopifnot(all(predict.rpart1 == predict.rpartpar)) par(mfrow = c(3, 3), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) plotmo(rpart1, do.par=2, SHOWCALL=TRUE, trace=0) plotres(rpart1, which=c(3,1), do.par=FALSE) plotmo(rpartpar, do.par=2, SHOWCALL=TRUE, trace=0) plotres(rpartpar, which=c(3,1), do.par=FALSE) plotmo(rpartpar$fit, do.par=2, SHOWCALL=TRUE) plotres(rpartpar$fit, which=c(3,1), do.par=FALSE) par(org.par) # TODO note that this differs from the above rpart model in that we don't use model=TRUE rpartpar.nosavemodel <- decision_tree(mode = "regression", min_n=1, cost_complexity=.0001) %>% set_engine("rpart") %>% fit(resp~num+fac+int+date+str, data = training(splits)) cat("\nrpart.rules(rpartpar.nosavemodel$fit)\n") options(warn=2) expect.err(try(rpart.rules(rpartpar.nosavemodel$fit)), "Cannot retrieve the data used to build the model") options(warn=1) expect.err(try(plotmo(rpartpar.nosavemodel)), "Cannot plot parsnip rpart model: need model=TRUE in call to rpart") rpart.sqrtnum <- decision_tree(mode = "regression", min_n=1, cost_complexity=.0001) %>% set_engine("rpart", model=TRUE) %>% fit(resp~sqrt(num)+fac+int+date+ord+str, data = training(splits)) cat("\nrpart.rules(rpart.sqrtnum$fit)\n") print(rpart.rules(rpart.sqrtnum$fit)) # ok #$$ TODO # expect.err(try(plotmo(rpart.sqrtnum)), # "cannot get the original model predictors") #----------------------------------------------------------------------------------- # Test fix for github bug report https://github.com/tidymodels/parsnip/issues/341 # (fixed Sep 2020) cat("===m750a first example===\n") set.seed(2020) m750a <- m4_monthly %>% filter(id == "M750") %>% select(-id) print(m750a) # a tibble set.seed(2020) splits_a <- initial_time_split(m750a, prop = 0.9) earth_m750a <- earth(log(value) ~ as.numeric(date) + month(date, label = TRUE), data = training(splits_a), degree=2) print(summary(earth_m750a)) set.seed(2020) model_m750a <- mars(mode = "regression", prod_degree=2) %>% set_engine("earth") %>% fit(log(value) ~ as.numeric(date) + month(date, label = TRUE), data = training(splits_a)) print(summary(model_m750a$fit)) stopifnot(identical(earth_m750a$coeff, model_m750a$fit$coeff)) predict_earth_m750a <- predict(earth_m750a, newdata=testing(splits_a)[1:3,]) predict_m750a <- model_m750a %>% predict(testing(splits_a)[1:3,]) stopifnot(max(c(9.238049628, 9.240535151, 9.232361834) - predict_m750a) < 1e-8) stopifnot(max(predict_earth_m750a - predict_m750a) < 1e-20) par(mfrow = c(2, 2), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) set.seed(2020) plotmo(model_m750a, trace=2, do.par=FALSE, pt.col="green", main="model_m750a", SHOWCALL=TRUE) set.seed(2020) plotmo(model_m750a$fit, trace=1, do.par=FALSE, pt.col="green", main="model_m750a$fit", SHOWCALL=TRUE) set.seed(2020) plotmo(earth_m750a, trace=1, do.par=FALSE, pt.col="green", main="earth_m750a", SHOWCALL=TRUE) par(org.par) cat("===m750a second example===\n") set.seed(2020) m750b <- m4_monthly %>% filter(id == "M750") %>% select(-id) %>% rename(date2 = date) print(m750b) # tibble set.seed(2020) splits_b <- initial_time_split(m750b, prop = 0.9) set.seed(2020) model_m750b <- mars(mode = "regression") %>% set_engine("earth") %>% fit(log(value) ~ as.numeric(date2) + month(date2, label = TRUE), data = training(splits_b)) # new data that only contains the feature "date" as a predictor future_data <- m750b %>% future_frame(date2, .length_out = "3 years") print(future_data) # a tibble with a single column of class "Date" stopifnot(class(future_data[,1,drop=TRUE]) == "Date") predict_m750a <- model_m750b %>% predict(new_data = future_data) par(mfrow = c(2, 2), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) set.seed(2020) plotmo(model_m750b, trace=2, do.par=FALSE, pt.col="green", main="model_m750b", SHOWCALL=TRUE) set.seed(2020) plotmo(model_m750b$fit, trace=1, do.par=FALSE, pt.col="green", main="model_m750b$fit", SHOWCALL=TRUE) par(org.par) #----------------------------------------------------------------------------------- # multiple response earth model data(etitanic) etit <- etitanic etit$survived <- factor(ifelse(etitanic$survived == 1, "yes", "no"), levels = c("yes", "no")) etit$notsurvived <- factor(ifelse(etitanic$survived == 0, "notsurvived", "survived"), levels = c("notsurvived", "survived")) set.seed(2020) earth_tworesp <- earth(survived + notsurvived ~ ., data=etit, degree=2) print(summary(earth_tworesp)) # TODO following commented out because parsnip (version 0.1.5) says "'+' not meaningful for factors" # set.seed(2020) # mars_tworesp <- mars(mode = "regression", prod_degree=2) %>% # set_engine("earth") %>% # fit(survived + notsurvived~., data=etit) # print(summary(mars_tworesp)) # print(summary(mars_tworesp$fit)) # # stopifnot(identical(earth_tworesp$coeff, mars_tworesp$fit$coeff)) # # predict.earth_tworesp <- predict(earth_tworesp, etit[3:6,]) # predict.mars_tworesp <- mars_tworesp %>% predict(etit[3:6,]) # stopifnot(all(predict.earth_tworesp == predict.mars_tworesp)) # # plotmo(earth_tworesp, trace=0, nresponse=1, SHOWCALL=TRUE) # plotmo(mars_tworesp, trace=0, nresponse=1, SHOWCALL=TRUE) # plotmo(mars_tworesp, trace=0, nresponse=2, SHOWCALL=TRUE) source("test.epilog.R") plotmo/inst/slowtests/test.degree.R0000644000176200001440000001057013727235376017166 0ustar liggesusers# test.pre.R: test the degree1 and degree2 and related args source("test.prolog.R") library(earth) library(plotmo) # test character degree1 and degree2 (added in plotmo version 1.3-0) data(ozone1) a80 <- earth(O3~., data=ozone1, degree=2) plotmo(a80, degree1="i", degree2="t", caption='degree1="i", degree2="t"') plotmo(a80, degree1="^temp$", degree2="^dpg$", caption='degree1="^temp$", degree2="^dpg$"') # Expect Warning: "nonesuch1" in degree1 does not regex-match any variables, ditto for degree2 plotmo(a80, degree1=c("temp", "nonesuch1"), degree2="vis", caption='degree1=c("temp", "nonesuch1"), degree2="vis")') # Expect above warnings and also Warning: nothing to plot plotmo(a80, degree1="nonesuch1", degree2="nonesuch2") # tests for plotmo version 3.3.7 (degree1 and degree2 handling changed) data(etitanic) a81 <- earth(survived~., data=etitanic, degree=2) options(warn=1) # print warnings as they occur plotmo(a81) # degree1 tests par(mfrow=c(3,3), mar=c(1,2.5,2,1), oma=c(0,0,4,0)) plotmo(a81, do.par=FALSE, degree1="pclass", degree2=0, main='degree1="pclass"', caption="test degree1 with strings") options(warn=2) # treat warnings as errors expect.err(try(plotmo(a81, do.par=FALSE, degree1="survived", degree2=0)), '"survived" in degree1 does not regex-match any names') options(warn=1) # print warnings as they occur plotmo(a81, do.par=FALSE, degree1="sibsp", degree2=0, main='degree1="sibsp"') # parch does not appear in the standard degree1 plotmo plots, but we can still specify it explictly plotmo(a81, do.par=FALSE, degree1="parch", degree2=0, trace=0, main='degree1="parch"') plotmo(a81, do.par=FALSE, degree1=c("sibsp", "pclass"), degree2=0, main='degree1=c("sibsp", "pclass")') par(org.par) # degree2 tests par(mfrow=c(3,3), mar=c(1,2.5,2,1), oma=c(0,0,4,0)) plotmo(a81, do.par=FALSE, degree1=0, degree2="pclass", main='degree2="pclass"', caption="test degree2 with two strings") plotmo(a81, do.par=FALSE, degree1=0, degree2=c("age", "se"), persp.theta=-35, main='degree2=c("age", "se")\npersp.theta=-35') plotmo(a81, do.par=FALSE, degree1=0, degree2="ag", main='degree2="ag"') plotmo(a81, do.par=FALSE, degree1=0, degree2=c("sex", "sibsp"), main='degree2=c("sex", "sibsp"') plotmo(a81, do.par=FALSE, degree1=0, degree2=c("sibsp", "sex"), main='degree2=c("sibsp", "sex")') options(warn=2) # treat warnings as errors expect.err(try(plotmo(a81, do.par=FALSE, degree1=0, degree2=c("pclass", "nonesuch"))), "\"nonesuch\" in degree2 does not regex-match any names") expect.err(try(plotmo(a81, do.par=FALSE, degree1=0, degree2=c("nonesuch1", "nonesuch2"))), "\"nonesuch1\" in degree2 does not regex-match any names") expect.err(try(plotmo(a81, do.par=FALSE, degree1=0, degree2=c("nonesuch", "pclass"))), "\"nonesuch\" in degree2 does not regex-match any names") options(warn=1) # print warnings as they occur par(org.par) par(mfrow=c(2,2), mar=c(1,2.5,2,1), oma=c(0,0,4,0)) # check that order of strings in two string degree2 is observed cat('\n\ndegree2=c("age", "se"):\n') plotmo(a81, do.par=FALSE, degree1=0, degree2=c("age", "se"), main='degree2=c("age", "se")') cat('\n\ndegree2=c("se", "age"):\n') plotmo(a81, do.par=FALSE, degree1=0, degree2=c("se", "age"), main='degree2=c("se", "age")') # check handling of bad strings in two string degree2 cat('\n\ndegree2=c("nonesuch", "age"):\n') try(plotmo(a81, do.par=FALSE, degree1=0, degree2=c("nonesuch", "age"), main='degree2=c("nonesuch", "age")')) cat('\n\ndegree2=c("age", "nonesuch"):\n') try(plotmo(a81, do.par=FALSE, degree1=0, degree2=c("age", "nonesuch"), main='degree2=c("age", "nonesuch")')) cat('\n\ndegree2=c("nevermore", "nonesuch"):\n') try(plotmo(a81, do.par=FALSE, degree1=0, degree2=c("nevermore", "nonesuch"), main='degree2=c("nevermore", "nonesuch")')) # follow should still plot the degree1 plot even though degree2 spec is wrong cat('\n\ndegree1=1, degree2=c("nevermore", "nonesuch"):\n') try(plotmo(a81, do.par=FALSE, degree1=1, degree2=c("nevermore", "nonesuch"), main='degree1=1\ndegree2=c("nevermore", "nonesuch")')) # expect warning: both elements of degree2 are the same cat('\n\ndegree2=c("sex", "sex"):\n') try(plotmo(a81, do.par=FALSE, degree1=0, degree2=c("sex", "sex"), main='degree1=1\ndegree2=c("sex", "sex")')) par(org.par) source("test.epilog.R") plotmo/inst/slowtests/test.c50.bat0000755000176200001440000000142314563571565016671 0ustar liggesusers@rem test.c50.bat: c50 tests for plotmo and plotres @echo test.c50.bat @"C:\PROGRA~1\R\R-4.3.2\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.c50.R @if %errorlevel% equ 0 goto good1: @echo R returned errorlevel %errorlevel%, see test.c50.Rout: @echo. @tail test.c50.Rout @echo test.c50.R @exit /B 1 :good1 mks.diff test.c50.Rout test.c50.Rout.save @if %errorlevel% equ 0 goto good2: @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.c50.save.ps @exit /B 1 :good2 @rem test.c50.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.c50.save.ps @if %errorlevel% equ 0 goto good3: @echo === Files are different === @exit /B 1 :good3 @rm -f test.c50.Rout @rm -f Rplots.ps @exit /B 0 plotmo/inst/slowtests/linmod.R0000644000176200001440000002555313727275573016251 0ustar liggesusers# linmod.R: Example S3 linear model. # # See www.milbo.org/doc/modguide.pdf. # This software may be freely used. linmod <- function(...) UseMethod("linmod") linmod.default <- function(x = stop("no 'x' argument"), y = stop("no 'y' argument"), keep = FALSE, ...) { stop.if.dot.arg.used(...) xmat <- as.matrix(x) # use name "(Intercept)" here so coef names match linmod.formula x <- cbind("(Intercept)" = 1, xmat) fit <- linmod.fit(x, y) fit$call <- match.call() if(keep) { fit$x <- xmat # save y as a one-column matrix, so can use colname to save response name colname <- deparse(substitute(y))[1] colname <- gsub(" ", "", substr(colname, 1, 100)) # strip spaces, truncate fit$y <- as.matrix(y, ncol = 1) colnames(fit$y) <- colname } fit } linmod.formula <- function(formula = stop("no 'formula' argument"), data = parent.frame(), keep = FALSE, ...) { stop.if.dot.arg.used(...) if(is.matrix(data)) # allow data to be a matrix data <- as.data.frame(data) # will create colnames V1 V2 V3 if necessary # note that na.action=na.pass because we will catch NAs later # in linmod.fit, for uniformity with linmod.default mf <- model.frame(formula = formula, data = data, na.action = na.pass) terms <- attr(mf, "terms") x <- model.matrix(terms, mf) y <- model.response(mf) fit <- linmod.fit(x, y) fit$call <- match.call() fit$terms <- terms fit$xlevels <- .getXlevels(terms, mf) # for use by predict.linmod if(keep) fit$data <- data fit } linmod.fit <- function(x = stop("no 'x' argument"), y = stop("no 'y' argument"), ...) { # internal function, not for the casual user # if model has an intercept, the first col of x must be intercept (all 1s) stop.if.dot.arg.used(...) x <- check.linmod.x(x) y <- check.linmod.y(x, y) fit <- do.linmod.fit(x, y) class(fit) <- "linmod" fit } check.linmod.x <- function(x) { if(!is.matrix(x)) stop("'x' is not a matrix or could not be converted to a matrix") if(NROW(x) == 0 || NCOL(x) == 0) stop("'x' is empty") if(anyNA(x)) stop("NA in 'x'") # checking just the first column of x suffices because all columns # of a matrix have the same type # we allow is.logical because qr etc. treat logical vars as numeric if(!is.numeric(x[,1]) && !is.logical(x[,1])) stop("non-numeric column in 'x'") # ensure all columns in x are named (needed for names in vcov etc.) # use the same naming convention as lm (prefix for unnamed cols is "V") missing.colnames <- if(is.null(colnames(x))) 1:NCOL(x) else nchar(colnames(x)) == 0 colnames(x)[missing.colnames] <- c("(Intercept)", paste("V", seq_len(NCOL(x) - 1), sep = ""))[missing.colnames] duplicated <- which(duplicated(colnames(x))) if(length(duplicated)) stop("column name \"", colnames(x)[duplicated[1]], "\" in 'x' is duplicated") x } check.linmod.y <- function(x, y) { # as.vector(as.matrix(y)) is necessary when y is a data.frame # (because as.vector alone on a data.frame returns a data.frame) y <- as.vector(as.matrix(y)) if(length(y) == 0) stop("'y' is empty") if(anyNA(y)) stop("NA in 'y'") if(!is.numeric(y) && !is.logical(y)) stop("'y' is not numeric or logical") if(length(y) != nrow(x)) stop("nrow(x) is ", nrow(x), " but length(y) is ", length(y)) y } do.linmod.fit <- function(x, y) { # workhorse function for fitting linear models # essential processing and sanity checks on x and y are already completed # x is a numeric matrix, y is a numeric vector qx <- qr(x) # QR-decomposition of x if(qx$rank < ncol(x)) stop("'x' is singular (it has ", ncol(x), " columns but its rank is ", qx$rank, ")\n colnames(x): ", paste0(colnames(x), collapse=' ')) coef <- solve.qr(qx, y) # compute (x'x)^(-1) x'y stopifnot(!anyNA(coef)) # NA impossible after rank check above df.residual <- max(0, nrow(x) - ncol(x)) # degrees of freedom sigma2 <- sum((y - x %*% coef)^2) / df.residual # variance of residuals vcov <- sigma2 * chol2inv(qx$qr) # covar mat is sigma^2 * (x'x)^(-1) fitted.values <- qr.fitted(qx, y) colnames(vcov) <- rownames(vcov) <- colnames(x) names(fitted.values) <- rownames(x) colnames(coef) <- colnames(y) # returned fields match lm's fields list(coefficients = coef, residuals = y - fitted.values, rank = qx$rank, fitted.values = fitted.values, vcov = vcov, sigma = sqrt(sigma2), df.residual = df.residual) } predict.linmod <- function(object = stop("no 'object' argument"), newdata = NULL, type = "response", ...) { stopifnot(inherits(object, "linmod")) stop.if.dot.arg.used(...) match.arg(type, "response") # the type argument is not yet supported if(is.null(newdata)) yhat <- fitted(object) else { if(NROW(newdata) == 0) stop("'newdata' is empty") # preempt obscure message later x <- if(is.null(object$terms)) # model built with linmod.default? process.newdata(object, newdata) else # model built with linmod.formula process.newdata.formula(object, newdata) # The following tests suffice to catch all illegal input. However # they aren't ideal in that they don't always direct you to the root # cause of the problem (i.e. the error messages aren't always optimal). nvar <- length(object$coefficients) - 1 # nbr vars, -1 for intercept if(ncol(x) - 1 != nvar) stop("ncol(newdata) is ", ncol(x) - 1, " but should be ", nvar) if(anyNA(x)) stop("NA in 'newdata'") if(!is.numeric(x[,1]) && !is.logical(x[,1])) stop("non-numeric column in 'newdata' (after processing)") yhat <- as.vector(do.predict.linmod(object, x)) names(yhat) <- rownames(x) } yhat } process.newdata <- function(object, newdata) { # process newdata for models built with linmod.default x <- if(is.vector(newdata)) # allow newdata to be a vector matrix(newdata, ncol = length(object$coefficients) - 1) else as.matrix(newdata) # allow newdata to be a data.frame cbind(1, x) # return data with an intercept column } process.newdata.formula <- function(object, newdata) { # process newdata for models built with linmod.formula newdata <- as.data.frame(newdata) # allows newdata to be a matrix terms <- object$terms dataClasses <- attr(terms, "dataClasses") iresp <- attr(terms, "response") terms <- delete.response(terms) # na.action=na.pass because we will catch NAs after (for clearer error msg) # xlevels is needed to convert strings to factor levels, for example: # a <- linmod(Sepal.Length~Species,data=iris) # predict(a,newdata=data.frame(Species="setosa")) mf <- model.frame(terms, newdata, na.action = na.pass, xlev = object$xlevels) if(anyNA(mf)) stop("NA in 'newdata'") if(NROW(mf) != NROW(newdata)) { # Get here when model.frame() issues # Warning: 'newdata' had M rows but variables found have N rows # Must stop, else the call to model.matrix() below would silently return bad data. # If a variable is missing, print its name to help the user. # TODO This will erroneously identify "sqrt(x)" as a missing var in the # formula "y ~ sqrt(x)" (because the var is wrapped in a func call). varnames <- names(dataClasses) varnames <- varnames[-iresp] missing <- which(!(varnames %in% colnames(newdata))) missing.msg <- "" if(length(missing)) missing.msg <- paste0(" (variable '", varnames[missing[1]], "' may be missing from newdata)") stop("newdata has ", NROW(newdata), " rows but model.frame returned ", NROW(mf), " rows", missing.msg) } .checkMFClasses(dataClasses, mf) # check types in newdata match original data model.matrix(terms, mf) } do.predict.linmod <- function(object, x) { # workhorse function for linear model predictions # processing by model.matrix etc. and sanity checks on x already completed # x is a numeric matrix (if model has intercept, first col of x is all 1s) x %*% coef(object) } summary.linmod <- function(object = stop("no 'object' argument"), ...) { stop.if.dot.arg.used(...) se <- sqrt(diag(object$vcov)) t.value <- coef(object) / se p.value <- if(object$df.residual == 0) # avoid warning from pt() rep_len(0, length.out=length(t.value)) else 2 * pt(-abs(t.value), df = object$df.residual) coefficients <- cbind(Estimate = coef(object), StdErr = se, t.value = t.value, p.value = p.value) retval <- list(call = object$call, coefficients = coefficients) class(retval) <- "summary.linmod" retval } print.linmod <- function(x = stop("no 'x' argument"), ...) { stop.if.dot.arg.used(...) print.model.call(x) print(x$coefficients) invisible(x) } print.summary.linmod <- function(x = stop("no 'x' argument"), ...) { stop.if.dot.arg.used(...) print.model.call(x) print(x$coefficients) invisible(x) } print.model.call <- function(x) { cat("Call: ") # print.lm has a newline here, but a space is more compact # use paste0 to convert vector of strings to single string if necessary cat(strwrap(paste0(deparse(x$call, control = NULL, nlines = 5), sep = " ", collapse = " "), exdent = 6), sep = "\n") cat("\n") } # stop.if.dot.arg.used will cause an error message if any args are passed to it. # We use it to test if any dots arg of the calling function was used, for # functions that must have a dots arg (to match the generic method) but don't # actually use the dots. This helps the user catch mistyped or illegal args. # R version 3.3-0 or higher has a function chkDots which could be used instead. stop.if.dot.arg.used <- function() { NULL } plotmo/inst/slowtests/test.printcall.Rout.save0000644000176200001440000002372714563614021021403 0ustar liggesusers> # test.printcall.R > # > # TODO we don't test use of printcall in a namespace > > source("test.prolog.R") > options(warnPartialMatchArgs=FALSE) > library(plotmo) Loading required package: Formula Loading required package: plotrix > for(all in c(FALSE, TRUE)) { + for(EVAL in c(FALSE, TRUE)) { + printf("=== Test printcall with all=%s EVAL=%s ===\n", all, EVAL) + + foo30 <- function() { plotmo:::printcall(all=all) } + foo30() + + foo32 <- function(...) { plotmo:::printcall(all=all); plotmo:::printdots(..., EVAL=EVAL) } + foo32() + foo32(a=31) + + + foo34 <- function(aa=1, ...) { plotmo:::printcall(all=all); plotmo:::printdots(..., EVAL=EVAL) } + foo34() + foo34(a=31) # argname a will be expanded to aa + foo34(a=31, x=1:10, y=NULL) + foo34(a=31, y=NULL) + foo34(x=stopifnot(TRUE), y=NULL) + + foo36 <- function(aa=NULL, ...) { plotmo:::printcall(all=all); plotmo:::printdots(..., EVAL=EVAL) } + foo36() + foo36(a=NULL) + foo36(a=1) + foo36(a=1:3) + foo36(a=1:3, x=NULL) + + # check formatting of various argument types + # note that we correctly don't call stopifnot(FALSE) (which would call stop) + + foo38 <- function(aa=1:3, bb=4:6, cc=print.default, + dd=stopifnot(FALSE), + ee=function(m=1) cat(m), ff=7, ...) + { plotmo:::printcall(all=all); plotmo:::printdots(..., EVAL=EVAL) } + foo38(x=matrix(ncol=1, nrow=3)) + + list1 <- list(aa=1:3, bb=4:6, cc=print.default, + dd=stopifnot(TRUE), + ee=function(m=1) cat(m), ff=7) + + cat("list1 ", plotmo:::list.as.char(list1), "\n", sep="") + + list2 <- list(lmmod=lm(Volume~Girth, data=trees), + boolean=c(TRUE, FALSE, TRUE, TRUE, FALSE, TRUE), env=parent.frame(), + chars=c("a", "b", "c", "a", "b", "c"), + trees=trees, l=list(x=1, y="2", z=foo38)) + + cat("list2 ", plotmo:::list.as.char(list2), "\n", sep="") + + # test unnamed arguments + + foo40 <- function(aa, ...) { plotmo:::printcall(all=all); plotmo:::printdots(..., EVAL=EVAL) } + foo40() + foo40(aa=b, c) + foo40(b, c) + + # test printcall when called in an S3 method + + foo.s3 <- function(a=NULL, ...) { UseMethod("foo.s3") } + foo.s3.list <- function(a=NULL, ...) { + cat("in foo.s3.list: "); plotmo:::printcall(all=all) + plotmo:::printdots(..., EVAL=EVAL) + } + foo.s3.default <- function(a=NULL, ...) { + cat("in foo.s3.default: "); plotmo:::printcall(all=all) + plotmo:::printdots(..., EVAL=EVAL) + } + foo.s3(a=list(m=1, n=2)) + foo.s3(a=NULL) + foo.s3(a=list(m=1, n=2, o=3, p=4, q=5, r=6, s=7, t=8, u=9), b=30) + + # test formatting with long argument list + + foo46 <- function(mmmmmmmmmmm=1000, nnnnnnnnnnn=2000, ooooooooooo=3000, ppppppppppp=4000, + qqqqqqqqqqq=5000, rrrrrrrrrrr=6000, sssssssssss=7000, ttttttttttt=8000, + uuuuuuuuuuu=9000, vvvvvvvvvvv=1000, wwwwwwwwwww=2000, xxxxxxxxxxx=3000, + ...) { plotmo:::printcall(all=all); plotmo:::printdots(..., EVAL=EVAL) } + foo46(a=30) + + # test call.as.char + + foo47 <- function(aa=1, ...) { s <- plotmo:::call.as.char(all=all); cat(s, "\n", sep="") } + foo47(b=30) + + # create a variable named foo48 in foo48 + foo48 <- function(aa=1, ...) { foo48 <- 99; s <- plotmo:::call.as.char(all=all); cat(s, "\n", sep="") } + foo48(b=30) + + # Note that the following doesn't do what you might expect. + # The calling function is print(), not foo50() as you may expecty. + + foo50 <- function(...) { print(plotmo:::call.as.char(all=all)) } + foo50(a=1) + } + } === Test printcall with all=FALSE EVAL=FALSE === foo30() foo32() foo32 dots: no dots foo32(a=31) foo32 dots: a=31 foo34() foo34 dots: no dots foo34(aa=31) foo34 dots: no dots foo34(aa=31, x=1:10, y=NULL) foo34 dots: x=..1, y=..2 foo34(aa=31, y=NULL) foo34 dots: y=..1 foo34(x=stopifnot(TRUE), y=NULL) foo34 dots: x=..1, y=..2 foo36() foo36 dots: no dots foo36(aa=NULL) foo36 dots: no dots foo36(aa=1) foo36 dots: no dots foo36(aa=1:3) foo36 dots: no dots foo36(aa=1:3, x=NULL) foo36 dots: x=..1 foo38(x=matrix(ncol=1,nrow=3)) foo38 dots: x=..1 list1 aa=c(1,2,3), bb=c(4,5,6), cc=function.object, dd=NULL, ee=function.object, ff=7 list2 lmmod=lm.object, boolean=c(TRUE,FALSE,TR...), env=R_GlobalEnv, chars=c("a","b","c","...), trees=data.frame[31,3], l=list(x=1, y="2", z=function.object) foo40() foo40 dots: no dots foo40(aa=b, c) foo40 dots: ..1 foo40(aa=b, c) foo40 dots: ..1 in foo.s3.list: foo.s3.list(a=list(m=1,n=2)) foo.s3.list dots: no dots in foo.s3.default: foo.s3.default(a=NULL) foo.s3.default dots: no dots in foo.s3.list: foo.s3.list(a=list(m=1,n=2,o=3,p=4,q=5,r=6,s=7,t=8,u=9), b=30) foo.s3.list dots: b=30 foo46(a=30) foo46 dots: a=30 foo47(b=30) foo48(b=30) [1] "print(x=plotmo:::call.as.char(all=all))" attr(,"fname") [1] "print" === Test printcall with all=FALSE EVAL=TRUE === foo30() foo32() foo32 dots: no dots foo32(a=31) foo32 dots: a=31 foo34() foo34 dots: no dots foo34(aa=31) foo34 dots: no dots foo34(aa=31, x=1:10, y=NULL) foo34 dots: x=c(1,2,3,4,5,6,7...), y=NULL foo34(aa=31, y=NULL) foo34 dots: y=NULL foo34(x=stopifnot(TRUE), y=NULL) foo34 dots: x=NULL, y=NULL foo36() foo36 dots: no dots foo36(aa=NULL) foo36 dots: no dots foo36(aa=1) foo36 dots: no dots foo36(aa=1:3) foo36 dots: no dots foo36(aa=1:3, x=NULL) foo36 dots: x=NULL foo38(x=matrix(ncol=1,nrow=3)) foo38 dots: x=c(NA,NA,NA) list1 aa=c(1,2,3), bb=c(4,5,6), cc=function.object, dd=NULL, ee=function.object, ff=7 list2 lmmod=lm.object, boolean=c(TRUE,FALSE,TR...), env=R_GlobalEnv, chars=c("a","b","c","...), trees=data.frame[31,3], l=list(x=1, y="2", z=function.object) foo40() foo40 dots: no dots foo40(aa=b, c) foo40 dots: function.object foo40(aa=b, c) foo40 dots: function.object in foo.s3.list: foo.s3.list(a=list(m=1,n=2)) foo.s3.list dots: no dots in foo.s3.default: foo.s3.default(a=NULL) foo.s3.default dots: no dots in foo.s3.list: foo.s3.list(a=list(m=1,n=2,o=3,p=4,q=5,r=6,s=7,t=8,u=9), b=30) foo.s3.list dots: b=30 foo46(a=30) foo46 dots: a=30 foo47(b=30) foo48(b=30) [1] "print(x=plotmo:::call.as.char(all=all))" attr(,"fname") [1] "print" === Test printcall with all=TRUE EVAL=FALSE === foo30() foo32() foo32 dots: no dots foo32(a=31) foo32 dots: a=31 foo34(aa=1) foo34 dots: no dots foo34(aa=31) foo34 dots: no dots foo34(aa=31, x=1:10, y=NULL) foo34 dots: x=..1, y=..2 foo34(aa=31, y=NULL) foo34 dots: y=..1 foo34(aa=1, x=stopifnot(TRUE), y=NULL) foo34 dots: x=..1, y=..2 foo36(aa=NULL) foo36 dots: no dots foo36(aa=NULL) foo36 dots: no dots foo36(aa=1) foo36 dots: no dots foo36(aa=1:3) foo36 dots: no dots foo36(aa=1:3, x=NULL) foo36 dots: x=..1 foo38(aa=1:3, bb=4:6, cc=print.default, dd=stopifnot(FALSE), ee=function(m=1)cat(m), ff=7, x=matrix(ncol=1,nrow=3)) foo38 dots: x=..1 list1 aa=c(1,2,3), bb=c(4,5,6), cc=function.object, dd=NULL, ee=function.object, ff=7 list2 lmmod=lm.object, boolean=c(TRUE,FALSE,TR...), env=R_GlobalEnv, chars=c("a","b","c","...), trees=data.frame[31,3], l=list(x=1, y="2", z=function.object) foo40(aa=) foo40 dots: no dots foo40(aa=b, c) foo40 dots: ..1 foo40(aa=b, c) foo40 dots: ..1 in foo.s3.list: foo.s3.list(a=list(m=1,n=2)) foo.s3.list dots: no dots in foo.s3.default: foo.s3.default(a=NULL) foo.s3.default dots: no dots in foo.s3.list: foo.s3.list(a=list(m=1,n=2,o=3,p=4,q=5,r=6,s=7,t=8,u=9), b=30) foo.s3.list dots: b=30 foo46(mmmmmmmmmmm=1000, nnnnnnnnnnn=2000, ooooooooooo=3000, ppppppppppp=4000, qqqqqqqqqqq=5000, rrrrrrrrrrr=6000, sssssssssss=7000, ttttttttttt=8000, uuuuuuuuuuu=9000, vvvvvvvvvvv=1000, wwwwwwwwwww=2000, xxxxxxxxxxx=3000, a=30) foo46 dots: a=30 foo47(aa=1, b=30) foo48(aa=1, b=30) [1] "print(x=plotmo:::call.as.char(all=all))" attr(,"fname") [1] "print" === Test printcall with all=TRUE EVAL=TRUE === foo30() foo32() foo32 dots: no dots foo32(a=31) foo32 dots: a=31 foo34(aa=1) foo34 dots: no dots foo34(aa=31) foo34 dots: no dots foo34(aa=31, x=1:10, y=NULL) foo34 dots: x=c(1,2,3,4,5,6,7...), y=NULL foo34(aa=31, y=NULL) foo34 dots: y=NULL foo34(aa=1, x=stopifnot(TRUE), y=NULL) foo34 dots: x=NULL, y=NULL foo36(aa=NULL) foo36 dots: no dots foo36(aa=NULL) foo36 dots: no dots foo36(aa=1) foo36 dots: no dots foo36(aa=1:3) foo36 dots: no dots foo36(aa=1:3, x=NULL) foo36 dots: x=NULL foo38(aa=1:3, bb=4:6, cc=print.default, dd=stopifnot(FALSE), ee=function(m=1)cat(m), ff=7, x=matrix(ncol=1,nrow=3)) foo38 dots: x=c(NA,NA,NA) list1 aa=c(1,2,3), bb=c(4,5,6), cc=function.object, dd=NULL, ee=function.object, ff=7 list2 lmmod=lm.object, boolean=c(TRUE,FALSE,TR...), env=R_GlobalEnv, chars=c("a","b","c","...), trees=data.frame[31,3], l=list(x=1, y="2", z=function.object) foo40(aa=) foo40 dots: no dots foo40(aa=b, c) foo40 dots: function.object foo40(aa=b, c) foo40 dots: function.object in foo.s3.list: foo.s3.list(a=list(m=1,n=2)) foo.s3.list dots: no dots in foo.s3.default: foo.s3.default(a=NULL) foo.s3.default dots: no dots in foo.s3.list: foo.s3.list(a=list(m=1,n=2,o=3,p=4,q=5,r=6,s=7,t=8,u=9), b=30) foo.s3.list dots: b=30 foo46(mmmmmmmmmmm=1000, nnnnnnnnnnn=2000, ooooooooooo=3000, ppppppppppp=4000, qqqqqqqqqqq=5000, rrrrrrrrrrr=6000, sssssssssss=7000, ttttttttttt=8000, uuuuuuuuuuu=9000, vvvvvvvvvvv=1000, wwwwwwwwwww=2000, xxxxxxxxxxx=3000, a=30) foo46 dots: a=30 foo47(aa=1, b=30) foo48(aa=1, b=30) [1] "print(x=plotmo:::call.as.char(all=all))" attr(,"fname") [1] "print" > source("test.epilog.R") plotmo/inst/slowtests/test.plotmo.args.bat0000755000176200001440000000160114563571565020545 0ustar liggesusers@rem test.plotmo.args.bat: test dot and other argument handling in plotmo @echo test.plotmo.args.bat @"C:\PROGRA~1\R\R-4.3.2\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.plotmo.args.R @if %errorlevel% equ 0 goto good1: @echo R returned errorlevel %errorlevel%, see test.plotmo.args.Rout: @echo. @tail test.plotmo.args.Rout @echo test.plotmo.args.R @exit /B 1 :good1 mks.diff test.plotmo.args.Rout test.plotmo.args.Rout.save @if %errorlevel% equ 0 goto good2: @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.plotmo.args.save.ps @exit /B 1 :good2 @rem test.plotmo.args.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.plotmo.args.save.ps @if %errorlevel% equ 0 goto good3: @echo === Files are different === @exit /B 1 :good3 @rm -f test.plotmo.args.Rout @rm -f Rplots.ps @exit /B 0 plotmo/inst/slowtests/test.linmod.R0000644000176200001440000017737314242001333017205 0ustar liggesusers# test.linmod.R: test example S3 model at http://www.milbo.org/doc/linmod.R source("test.prolog.R") source("linmod.R") # linear model code (http://www.milbo.org/doc/linmod.R) source("linmod.methods.R") # additional method functions for linmod options(warn=1) # print warnings as they occur almost.equal <- function(x, y, max=1e-8) { stopifnot(max >= 0 && max < .01) length(x) == length(y) && max(abs(x - y)) < max } # check that linmod model matches reference lm model in all essential details check.lm <- function(fit, ref, newdata=trees[3:5,], check.coef.names=TRUE, check.casenames=TRUE, check.newdata=TRUE, check.sigma=TRUE) { check.names <- function(fit.names, ref.names) { if(check.casenames && # lm always adds rownames even if "1", "2", "3": this seems # wasteful and not particulary helpful, so linmod doesn't do # this, hence the first !isTRUE(all.equal) below !isTRUE(all.equal(ref.names, paste(1:length(ref.names)))) && !isTRUE(all.equal(fit.names, ref.names))) { print(fit.names) print(ref.names) stop(deparse(substitute(fit.names)), " != ", deparse(substitute(ref.names))) } } cat0("check ", deparse(substitute(fit)), " vs ", deparse(substitute(ref)), "\n") stopifnot(coef(fit) == coef(ref)) if(check.coef.names) stopifnot(identical(names(coef(fit)), names(coef(ref)))) stopifnot(identical(dim(fit$coefficients), dim(ref$coefficients))) stopifnot(length(fit$coefficients) == length(ref$coefficients)) stopifnot(almost.equal(fit$coefficients, ref$coefficients)) stopifnot(identical(dim(fit$residuals), dim(ref$residuals))) stopifnot(length(fit$residuals) == length(ref$residuals)) stopifnot(almost.equal(fit$residuals, ref$residuals)) stopifnot(identical(dim(fit$fitted.values), dim(ref$fitted.values))) stopifnot(length(fit$fitted.values) == length(ref$fitted.values)) stopifnot(almost.equal(fit$fitted.values, ref$fitted.values)) stopifnot(identical(fit$rank, ref$rank)) if(!is.null(fit$vcov) && !is.null(ref$vcov)) { stopifnot(identical(dim(fit$vcov), dim(ref$vcov))) stopifnot(length(fit$vcov) == length(ref$vcov)) stopifnot(almost.equal(fit$vcov, ref$vcov)) } if(check.sigma) { ref.sigma <- ref$sigma if(is.null(ref.sigma)) # in lm models, sigma is only available from summary() ref.sigma <- summary(ref)$sigma stopifnot(almost.equal(fit$sigma, ref.sigma)) } stopifnot(almost.equal(fit$df.residual, ref$df.residual)) stopifnot(almost.equal(fitted(fit), fitted(ref))) check.names(names(fitted(fit)), names(fitted(ref))) stopifnot(almost.equal(residuals(fit), residuals(ref))) check.names(names(residuals(fit)), names(residuals(ref))) stopifnot(almost.equal(predict(fit), predict(ref))) check.names(names(predict(fit)), names(predict(ref))) if(check.newdata) { stopifnot(almost.equal(predict(fit, newdata=newdata), predict(ref, newdata=newdata))) check.names(names(predict(fit, newdata=newdata)), names(predict(ref, newdata=newdata))) } } tr <- trees # trees data but with rownames rownames(tr) <- paste("tree", 1:nrow(trees), sep="") linmod.form.Volume.tr <- linmod(Volume~., data=tr) cat0("==print(summary(linmod.form.Volume.tr))\n") print(summary(linmod.form.Volume.tr)) lm.Volume.tr <- lm(Volume~., data=tr) check.lm(linmod.form.Volume.tr, lm.Volume.tr) stopifnot(almost.equal(predict(linmod.form.Volume.tr, newdata=data.frame(Girth=10, Height=80)), 16.234045, max=1e-5)) stopifnot(almost.equal(predict(linmod.form.Volume.tr, newdata=as.matrix(tr[1:3,])), c(4.8376597, 4.5538516, 4.8169813), max=1e-5)) # character new data (instead of numeric) newdata.allchar <- as.data.frame(matrix("blank", ncol=3, nrow=3)) colnames(newdata.allchar) <- colnames(trees) expect.err(try(predict(lm.Volume.tr, newdata=newdata.allchar)), "variables 'Girth', 'Height' were specified with different types from the fit") expect.err(try(predict(linmod.form.Volume.tr, newdata=newdata.allchar)), "variables 'Girth', 'Height' were specified with different types from the fit") linmod.xy.Volume.tr <- linmod(tr[,1:2], tr[,3,drop=FALSE]) # x=data.frame y=data.frame cat0("==print(summary(linmod.xy.Volume.tr))\n") print(summary(linmod.xy.Volume.tr)) newdata.2col <- trees[3:5,1:2] check.lm(linmod.xy.Volume.tr, lm.Volume.tr, newdata=newdata.2col) stopifnot(almost.equal(predict(linmod.xy.Volume.tr, newdata=data.frame(Girth=10, Height=80)), 16.234045, max=1e-5)) stopifnot(almost.equal(predict(linmod.xy.Volume.tr, newdata=tr[1:3,1:2]), c(4.8376597, 4.5538516, 4.8169813), max=1e-5)) linmod50.xy.Volume.tr <- linmod(as.matrix(tr[,1:2]), as.matrix(tr[,3,drop=FALSE])) # x=matrix y=matrix check.lm(linmod50.xy.Volume.tr, lm.Volume.tr, newdata=newdata.2col) linmod51.xy.Volume.tr <- linmod(tr[,1:2], tr[,3]) # x=data.frame y=vector check.lm(linmod51.xy.Volume.tr, lm.Volume.tr, newdata=newdata.2col) linmod52.xy.Volume.tr <- linmod(as.matrix(tr[,1:2]), tr[,3]) # x=matrix y=vector check.lm(linmod52.xy.Volume.tr, lm.Volume.tr, newdata=newdata.2col) # newdata can be a vector stopifnot(almost.equal(predict(linmod.xy.Volume.tr, newdata=c(8.3, 70)), 4.8376597, max=1e-5)) stopifnot(almost.equal(predict(linmod.xy.Volume.tr, newdata=c(8.3, 8.6, 70, 65)), # 4 element vector, byrow=FALSE c(4.8376597, 4.5538516), max=1e-5)) options(warn=1) # print warnings as they occur # expect Warning: data length [3] is not a sub-multiple or multiple of the number of rows [2] stopifnot(almost.equal(predict(linmod.xy.Volume.tr, newdata=c(8.3, 9, 70)), # 3 element vector c(4.8376597, -12.7984291), max=1e-5)) options(warn=2) # treat warnings as errors stopifnot(almost.equal(predict(linmod.xy.Volume.tr, newdata=as.matrix(data.frame(Girth=10, Height=80))), 16.234045, max=1e-5)) # column names in newdata are ignored for linmod.default models stopifnot(almost.equal(predict(linmod.xy.Volume.tr, newdata=data.frame(name1.not.in.orig.data=10, name2.not.in.orig.datax2=80)), 16.234045, max=1e-5)) # note name reversed below but names still ignored, same predict result as c(Girth=10, Height=80) stopifnot(almost.equal(predict(linmod.xy.Volume.tr, newdata=data.frame(Height=10, Girth=80)), 16.234045, max=1e-5)) cat0("==print.default(linmod.form.Volume.tr)\n") print.default(linmod.form.Volume.tr) cat0("==check single x variable\n") linmod1a.form <- linmod(Volume~Height, data=tr) cat0("==print(summary(linmod1a.form))\n") print(summary(linmod1a.form)) lma.tr <- lm(Volume~Height, data=tr) check.lm(linmod1a.form, lma.tr) stopifnot(almost.equal(predict(linmod1a.form, newdata=data.frame(Height=80)), 36.34437, max=1e-5)) stopifnot(almost.equal(predict(linmod1a.form, newdata=data.frame(Girth=99, Height=80)), 36.34437, max=1e-5)) stopifnot(almost.equal(predict(linmod1a.form, newdata=as.matrix(tr[1:3,])), c(20.91087, 13.19412, 10.10742), max=1e-5)) linmod1a.xy <- linmod(tr[,2,drop=FALSE], tr[,3]) cat0("==print(summary(linmod1a.xy))\n") print(summary(linmod1a.xy)) check.lm(linmod1a.xy, lma.tr, newdata=trees[3:5,2,drop=FALSE]) check.lm(linmod1a.xy, lma.tr, newdata=trees[3:5,2,drop=TRUE], check.newdata=FALSE) # needed because predict.lm gives 'data' must be a data.frame, environment, or list stopifnot(almost.equal(predict(linmod1a.xy, newdata=trees[3:5,2,drop=FALSE]), predict(linmod1a.xy, newdata=trees[3:5,2,drop=TRUE]))) stopifnot(almost.equal(predict(linmod1a.xy, newdata=data.frame(Height=80)), 36.34437, max=1e-5)) stopifnot(almost.equal(predict(linmod1a.xy, newdata=tr[1:3,2]), c(20.91087, 13.19412, 10.10742), max=1e-5)) stopifnot(almost.equal(predict(linmod1a.xy, newdata=as.matrix(data.frame(Height=80))), 36.34437, max=1e-5)) # check that extra fields in predict newdata are ok with formula models stopifnot(almost.equal(predict(linmod.form.Volume.tr, newdata=data.frame(Girth=10, Height=80, extra=99)), predict(lm.Volume.tr, newdata=data.frame(Girth=10, Height=80)))) stopifnot(almost.equal(predict(linmod.form.Volume.tr, newdata=data.frame(Girth=10, Height=80, extra=99)), predict(lm.Volume.tr, newdata=data.frame(Girth=10, Height=80, extra=99)))) # check that extra fields in predict newdata are not ok with x,y models expect.err(try(predict(linmod.xy.Volume.tr, newdata=data.frame(Girth=10, Height=80, extra=99))), "ncol(newdata) is 3 but should be 2") # missing variables in newdata expect.err(try(predict(linmod.form.Volume.tr, newdata=data.frame(Girth=10))), "object 'Height' not found") expect.err(try(predict(linmod.form.Volume.tr, newdata=c(8.3, 70))), "object 'Girth' not found") expect.err(try(predict(lm.Volume.tr, newdata=data.frame(Girth=10))), "object 'Height' not found") expect.err(try(predict(linmod.xy.Volume.tr, newdata=data.frame(Girth=10))), "ncol(newdata) is 1 but should be 2") # check that rownames got propagated stopifnot(names(linmod.form.Volume.tr$residuals)[1] == "tree1") stopifnot(names(linmod.form.Volume.tr$fitted.values)[3] == "tree3") stopifnot(names(linmod.xy.Volume.tr$residuals)[1] == "tree1") stopifnot(names(linmod.xy.Volume.tr$fitted.values)[3] == "tree3") stopifnot(!is.null(names(linmod.xy.Volume.tr$residuals))) stopifnot(!is.null(names(linmod.xy.Volume.tr$fitted.values))) cat0("==print.default(linmod.xy.Volume.tr)\n") print.default(linmod.xy.Volume.tr) # check that we don't artificially add rownames when no original rownames linmod1a.xy <- linmod(trees[,1:2], trees[,3]) stopifnot(is.null(names(linmod1a.xy$residuals))) stopifnot(is.null(names(linmod1a.xy$fitted.values))) cat0("==example plots\n") library(plotmo) data(trees) linmod.form.Volume.trees <- linmod(Volume~., data=trees) print(linmod.form.Volume.trees) print(summary(linmod.form.Volume.trees)) linmod1.xy <- linmod(trees[,1:2], trees[,3]) print(linmod1.xy) print(summary(linmod1.xy)) plotmo(linmod.form.Volume.trees) plotmo(linmod1.xy) plotres(linmod.form.Volume.trees) plotres(linmod1.xy) cat0("==test keep arg\n") trees1 <- trees linmod.form.Volume.trees.keep <- linmod(Volume~., data=trees1, keep=TRUE) print(summary(linmod.form.Volume.trees.keep)) print(head(linmod.form.Volume.trees.keep$data)) stopifnot(dim(linmod.form.Volume.trees.keep$data) == c(nrow(trees1), ncol(trees1))) trees1 <- NULL # destroy orginal data so plotmo has to use keep data plotmo(linmod.form.Volume.trees.keep, pt.col=3) plotres(linmod.form.Volume.trees.keep) linmod.xy.keep <- linmod(trees[,1:2], trees[,3], keep=TRUE) print(summary(linmod.xy.keep)) print(head(linmod.xy.keep$x)) stopifnot(dim(linmod.xy.keep$x) == c(nrow(trees), 2)) stopifnot(class(linmod.xy.keep$x)[1] == "matrix") print(head(linmod.xy.keep$y)) stopifnot(dim(linmod.xy.keep$y) == c(nrow(trees), 1)) stopifnot(class(linmod.xy.keep$y)[1] == "matrix") linmod.xy.keep$call <- NULL # trick to force use of x and y in plotmo plotmo(linmod.xy.keep, pt.col=3) plotres(linmod.xy.keep) check.lm(linmod.form.Volume.trees.keep, linmod.xy.keep, check.casenames=FALSE, check.newdata=FALSE) cat0("==test keep arg with vector x\n") n <- 20 linmod.vecx.form.keep <- linmod(Volume~Height, data=trees[1:n,], keep=TRUE) print(summary(linmod.vecx.form.keep)) print(head(linmod.vecx.form.keep$data)) stopifnot(dim(linmod.vecx.form.keep$data) == c(n, ncol(trees))) stopifnot(class(linmod.vecx.form.keep$data) == class(trees)) plotmo(linmod.vecx.form.keep, pt.col=3) plotres(linmod.vecx.form.keep) linmod.vecx.xy.keep <- linmod(trees[1:n,2], trees[1:n,3], keep=TRUE) print(summary(linmod.vecx.xy.keep)) print(head(linmod.vecx.xy.keep$x)) stopifnot(dim(linmod.vecx.xy.keep$x) == c(n, 1)) stopifnot(class(linmod.vecx.xy.keep$x)[1] == "matrix") print(head(linmod.vecx.xy.keep$y)) stopifnot(dim(linmod.vecx.xy.keep$y) == c(n, 1)) stopifnot(class(linmod.vecx.xy.keep$y)[1] == "matrix") linmod.vecx.xy.keep$call <- NULL # trick to force use of x and y in plotmo plotmo(linmod.vecx.xy.keep, pt.col=3) plotres(linmod.vecx.xy.keep) check.lm(linmod.vecx.form.keep, linmod.vecx.xy.keep, newdata=trees[3:5,2,drop=FALSE], check.coef.names=FALSE, check.casenames=FALSE) cat0("==test model building with assorted numeric args\n") x <- tr[,1:2] y <- tr[,3] cat0("class(x)=", class(x), " class(y)=", class(y), "\n") # class(x)=data.frame class(y)=numeric linmod2.xy <- linmod(x, y) check.lm(linmod2.xy, lm.Volume.tr, newdata=newdata.2col) # check consistency with lm expect.err(try(linmod(y~x)), "invalid type (list) for variable 'x'") expect.err(try(lm(y~x)), "invalid type (list) for variable 'x'") linmod3.xy <- linmod(as.matrix(x), as.matrix(y)) check.lm(linmod3.xy, lm.Volume.tr, newdata=newdata.2col) linmod4.form <- linmod(y ~ as.matrix(x)) lm4 <- lm(y ~ as.matrix(x)) check.lm(linmod4.form, lm4, check.newdata=FALSE) stopifnot(coef(linmod4.form) == coef(lm.Volume.tr), gsub("as.matrix(x)", "", names(coef(linmod4.form)), fixed=TRUE) == names(coef(lm.Volume.tr))) xm <- as.matrix(x) cat0("class(xm)=", class(xm), " class(y)=", class(y), "\n") # class(xm)=matrix class(y)=numeric linmod5.form <- linmod(y ~ xm) lm5 <- lm(y ~ xm) check.lm(linmod5.form, lm5, check.newdata=FALSE) stopifnot(coef(linmod5.form) == coef(lm.Volume.tr), gsub("xm", "", names(coef(linmod5.form)), fixed=TRUE) == names(coef(lm.Volume.tr))) cat0("==test correct use of global x1 and y1, and of predict error handling\n") x1 <- tr[,1] y1 <- tr[,3] cat0("class(x1)=", class(x1), " class(y1)=", class(y1), "\n") # class(x1)=numeric class(y1)=numeric linmod.y1.x1 <- linmod(y1~x1) lm1 <- lm(y1~x1) linmod6.xy <- linmod(x1, y1) newdata.x1 <- trees[3:5,1,drop=FALSE] colnames(newdata.x1) <- "x1" stopifnot(almost.equal(predict(linmod.y1.x1, newdata=newdata.x1), c(7.63607739644657, 16.24803331528098, 17.26120459984973))) check.lm(linmod6.xy, linmod.y1.x1, newdata=x1[3:5], check.newdata=FALSE, # TODO needed because linmod.y1.x1 ignores newdata(!) check.coef.names=FALSE, check.casenames=FALSE) print(predict(linmod6.xy, newdata=x1[3:5])) stopifnot(almost.equal(predict(linmod6.xy, newdata=x1[3]), 7.63607739644657)) stopifnot(coef(linmod6.xy) == coef(linmod.y1.x1)) # names(coef(linmod.y1.x1) are "(Intercept)" "x1" stopifnot(names(coef(linmod6.xy)) == c("(Intercept)", "V1")) # following checks some confusing behaviour of predict.lm options(warn=2) # treat warnings as errors expect.err(try(predict(lm1, newdata=trees[3:5,1,drop=FALSE])), "'newdata' had 3 rows but variables found have 31 rows") expect.err(try(predict(lm1, newdata=trees[3:5,1,drop=TRUE])), "'data' must be a data.frame, environment, or list") # following checks messages when missing variables in newdata options(warn=2) # treat warnings as errors to check that we get a warning in stats::model.frame expect.err(try(predict(linmod.y1.x1, newdata=trees[3:5,1,drop=FALSE])), "(converted from warning) 'newdata' had 3 rows but variables found have 31 rows") expect.err(try(predict(lm1, newdata=trees[3:5,1,drop=FALSE])), "(converted from warning) 'newdata' had 3 rows but variables found have 31 rows") expect.err(try(predict(linmod.y1.x1, newdata=trees[3:5,1,drop=TRUE])), "(converted from warning) 'newdata' had 3 rows but variables found have 31 rows") # following checks predict.linmod error messages when missing variables # (it tries to give better error messages than predict.lm) options(warn=1) # print warnings as they occur to test stop() in linmod.R::process.newdata.formula expect.err(try(predict(linmod.y1.x1, newdata=trees[3:5,1,drop=FALSE])), "newdata has 3 rows but model.frame returned 31 rows (variable 'x1' may be missing from newdata)") expect.err(try(predict(linmod.y1.x1, newdata=trees[3:5,1,drop=TRUE])), "newdata has 3 rows but model.frame returned 31 rows (variable 'x1' may be missing from newdata)") options(warn=2) # back to treating warnings as errors # test old version of linmod.R (pre Sep 2020) # # expect.err(try(predict(linmod.y1.x1, newdata=trees[3:5,1,drop=FALSE])), # "variable 'x1' is missing from newdata") # expect.err(try(predict(lm1, newdata=trees[3:5,1,drop=FALSE])), # "(converted from warning) 'newdata' had 3 rows but variables found have 31 rows") # expect.err(try(predict(linmod.y1.x1, newdata=trees[3:5,1,drop=TRUE])), # "variable 'x1' is missing from newdata") linmod6.form <- linmod(y1~x1) check.lm(linmod6.form, linmod.y1.x1, check.newdata=FALSE) newdata <- trees[5:6,] colnames(newdata) <- c("Girth", "Height", "Volume999") # doesn't matter what we call the response stopifnot(identical(predict(linmod.form.Volume.tr, newdata=newdata), predict(linmod.form.Volume.tr, newdata=trees[5:6,]))) newdata <- trees[5:6,3:1] # reverse columns and their colnames colnames(newdata) <- c("Volume", "Height", "Girth") stopifnot(identical(predict(linmod.form.Volume.tr, newdata=newdata), predict(linmod.form.Volume.tr, newdata=trees[5:6,]))) newdata <- trees[5:6,2:1] # reverse columns and their colnames, delete response column colnames(newdata) <- c("Height", "Girth") stopifnot(identical(predict(linmod.form.Volume.tr, newdata=newdata), predict(linmod.form.Volume.tr, newdata=trees[5:6,]))) stopifnot(identical(predict(linmod.form.Volume.tr, newdata=as.matrix(trees[5:6,])), # allow matrix newdata predict(linmod.form.Volume.tr, newdata=trees[5:6,]))) newdata <- trees[5:6,] colnames(newdata) <- c("Girth99", "Height", "Volume") expect.err(try(predict(linmod.form.Volume.tr, newdata=newdata)), "object 'Girth' not found") colnames(newdata) <- c("Girth", "Height99", "Volume") expect.err(try(predict(linmod.form.Volume.tr, newdata=newdata)), "object 'Height' not found") cat0("==check integer input (sibsp is an integer)\n") library(earth) # for etitanic data data(etitanic) tit <- etitanic[seq(1, nrow(etitanic), by=60), ] # small set of data for tests (18 cases) tit$survived <- tit$survived != 0 # convert to logical rownames(tit) <- paste("pas", 1:nrow(tit), sep="") cat0(paste(colnames(tit), "=", sapply(tit, class), sep="", collapse=", "), "\n") linmod7.xy <- linmod(tit$age, tit$sibsp) lm7 <- lm.fit(cbind(1, tit$age), tit$sibsp) stopifnot(coef(linmod7.xy) == coef(lm7)) # coef names will differ linmod7.form <- linmod(sibsp~age, data=tit) lm7.form <- lm(sibsp~age, data=tit) check.lm(linmod7.form, lm7.form, newdata=tit[3:5,]) linmod8.xy <- linmod(tit$sibsp, tit$age) lm8 <- lm.fit(cbind(1, tit$sibsp), tit$age) stopifnot(coef(linmod8.xy) == coef(lm8)) # coef names will differ linmod8.form <- linmod(age~sibsp, data=tit) lm8.form <- lm(age~sibsp, data=tit) check.lm(linmod8.form, lm8.form, newdata=tit[3:5,]) # drop=FALSE so response is a data frame linmod1a.xy <- linmod(trees[,1:2], trees[, 3, drop=FALSE]) print(linmod1a.xy) print(summary(linmod1a.xy)) plotres(linmod1a.xy) # plot caption shows response name "Volume" cat0("==test model building with assorted non-numeric args\n") library(earth) # for etitanic data data(etitanic) etit <- etitanic[seq(1, nrow(etitanic), by=60), ] # small set of data for tests (18 cases) etit$survived <- etit$survived != 0 # convert to logical rownames(etit) <- paste("pas", 1:nrow(etit), sep="") cat0(paste(colnames(etit), "=", sapply(etit, class), sep="", collapse=", "), "\n") lm9 <- lm(survived~., data=etit) linmod9.form <- linmod(survived~., data=etit) check.lm(linmod9.form, lm9, newdata=etit[3:5,]) # change class of pclass to numeric etit.pclass.numeric <- etit etit.pclass.numeric$pclass <- as.numeric(etit$pclass) expect.err(try(predict(lm9, newdata=etit.pclass.numeric)), "(converted from warning) variable 'pclass' is not a factor") expect.err(try(predict(linmod9.form, newdata=etit.pclass.numeric)), "(converted from warning) variable 'pclass' is not a factor") # change class of age to factor etit.age.factor <- etit etit.age.factor$age <- etit$pclass expect.err(try(predict(lm9, newdata=etit.age.factor)), "variable 'age' was fitted with type \"numeric\" but type \"factor\" was supplied") expect.err(try(predict(linmod9.form, newdata=etit.age.factor)), "variable 'age' was fitted with type \"numeric\" but type \"factor\" was supplied") # predict for formula model ignores extra column(s) in newdata etit.extra.col <- etit etit.extra.col$extra <- etit$sibsp stopifnot(identical(predict(lm9, newdata=etit), predict(lm9, newdata=etit.extra.col))) stopifnot(identical(predict(linmod9.form, newdata=etit), predict(linmod9.form, newdata=etit.extra.col))) etit.extra.col$extra2 <- etit$sibsp stopifnot(identical(predict(lm9, newdata=etit), predict(lm9, newdata=etit.extra.col))) stopifnot(identical(predict(linmod9.form, newdata=etit), predict(linmod9.form, newdata=etit.extra.col))) # predict for formula model doesn't care if columns in different order etit.different.col.order <- etit[,ncol(etit):1] # reverse order of columns stopifnot(identical(predict(lm9, newdata=etit), predict(lm9, newdata=etit.different.col.order))) stopifnot(identical(predict(linmod9.form, newdata=etit), predict(linmod9.form, newdata=etit.different.col.order))) # linmod.default, non numeric x (factors in x) expect.err(try(linmod(etit[c(1,3,4,5,6)], etit[,"survived"])), "non-numeric column in 'x'") expect.err(try(linmod.fit(etit[c(1,3,4,5,6)], etit[,"survived"])), "'x' is not a matrix or could not be converted to a matrix") # lousy error message from lm.fit expect.err(try(lm.fit(etit[,c(1,3,4,5,6)], etit[,"survived"])), "INTEGER() can only be applied to a 'integer', not a 'NULL'") expect.err(try(linmod(data.matrix(cbind("(Intercept)"=1, etit[,c(1,3,4,5,6)])), etit[,"survived"])), "column name \"(Intercept)\" in 'x' is duplicated") linmod9a.xy <- linmod(data.matrix(etit[,c(1,3,4,5,6)]), etit[,"survived"]) lm9.fit <- lm.fit(data.matrix(cbind("(Intercept)"=1, etit[,c(1,3,4,5,6)])), etit[,"survived"]) stopifnot(coef(linmod9a.xy) == coef(lm9.fit)) stopifnot(names(coef(linmod9a.xy)) == names(coef(lm9.fit))) expect.err(try(predict(linmod9a.xy, newdata=etit.age.factor[,c(1,3,4,5,6)])), "non-numeric column in 'newdata'") expect.err(try(predict(linmod9a.xy, newdata=etit[,c(1,3,4,5)])), "ncol(newdata) is 4 but should be 5") expect.err(try(predict(linmod9a.xy, newdata=etit[,c(1,3,4,5,6,6)])), "ncol(newdata) is 6 but should be 5") # linmod.formula, logical response data.logical.response <- data.frame(etit[1:6,c("age","sibsp","parch")], response=c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE)) linmod9b.form <- linmod(response~., data=data.logical.response) print(linmod9b.form) lm9b.form <- lm(response~., data=data.logical.response) check.lm(linmod9b.form, lm9b.form, newdata=data.logical.response[2,,drop=FALSE]) # linmod.formula, factor response (not allowed) data.fac.response <- data.frame(etit[1:6,c("age","sibsp","parch")], response=factor(c("a", "a", "b", "a", "b", "b"))) expect.err(try(linmod(response~., data=data.fac.response)), "'y' is not numeric or logical") # lm.formula expect.err(try(lm(response~., data=data.fac.response)), "(converted from warning) using type = \"numeric\" with a factor response will be ignored") # linmod.formula, string response (not allowed) data.string.response <- data.frame(etit[1:6,c("age","sibsp","parch")], response=c("a", "a", "b", "a", "b", "b")) expect.err(try(linmod(response~., data=data.string.response)), "'y' is not numeric or logical") # lm.formula expect.err(try(lm(response~., data=data.string.response)), "(converted from warning) NAs introduced by coercion") # linmod.default, logical response linmod9b.xy <- linmod(etit[1:6,c("age","sibsp","parch")], c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE)) print(linmod9b.xy) # lm.fit, logical response (lousy error message from lm.fit) expect.err(try(lm.fit(etit[1:6,c("age","sibsp","parch")], c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE))), "INTEGER() can only be applied to a 'integer', not a 'NULL'") # linmod.default, factor response expect.err(try(linmod(etit[1:6,c("age","sibsp","parch")], factor(c("a", "a", "b", "a", "b", "b")))), "'y' is not numeric or logical") # linmod.default, string response expect.err(try(linmod(etit[1:6,c("age","sibsp","parch")], c("a", "a", "b", "a", "b", "b"))), "'y' is not numeric or logical") # lm.fit, string and factor responses (lousy error messages from lm.fit) expect.err(try(lm.fit(etit[1:6,c("age","sibsp","parch")], factor(c("a", "a", "b", "a", "b", "b")))), "INTEGER() can only be applied to a 'integer', not a 'NULL'") expect.err(try(lm.fit(etit[1:6,c("age","sibsp","parch")], c("a", "a", "b", "a", "b", "b"))), "INTEGER() can only be applied to a 'integer', not a 'NULL'") options(warn=2) # treat warnings as errors expect.err(try(lm(pclass~., data=etit)), "using type = \"numeric\" with a factor response will be ignored") expect.err(try(linmod(pclass~., data=etit)), "'y' is not numeric or logical") options(warn=1) # print warnings as they occur lm10 <- lm(pclass~., data=etit) # will give warnings options(warn=2) # treat warnings as errors linmod10.form <- linmod(as.numeric(pclass)~., data=etit) stopifnot(coef(linmod10.form) == coef(lm10)) stopifnot(names(coef(linmod10.form)) == names(coef(lm10))) # check.lm(linmod10.form, lm10) # fails because lm10 fitted is all NA expect.err(try(linmod(pclass~., data=etit)), "'y' is not numeric or logical") expect.err(try(linmod(etit[,-1], etit[,1])), "non-numeric column in 'x'") expect.err(try(linmod(1:10, paste(1:10))), "'y' is not numeric or logical") linmod10a.form <- linmod(survived~pclass, data=etit) lm10a <- lm(survived~pclass, data=etit) check.lm(linmod10a.form, lm10a, newdata=etit[3:5,]) expect.err(try(linmod(etit[,"pclass"], etit[,"age"])), "non-numeric column in 'x'") expect.err(try(linmod(paste(1:10), 1:10)), "non-numeric column in 'x'") lm11 <- lm(as.numeric(pclass)~., data=etit) linmod11.form <- linmod(as.numeric(pclass)~., data=etit) check.lm(linmod11.form, lm11, newdata=etit[3:5,]) # logical data (not numeric) bool.data <- data.frame(x=rep(c(TRUE, FALSE, TRUE), length.out=10), y=rep(c(TRUE, FALSE, FALSE), length.out=10)) lm12 <- lm(y~x, data=bool.data) linmod12.form <- linmod(y~x, data=bool.data) check.lm(linmod12.form, lm12, newdata=bool.data[3:5,1], check.newdata=FALSE) # needed because predict.lm gives invalid type (list) for variable 'x' linmod12.xy <- linmod(bool.data$x, bool.data$y) # hack: delete mismatching names so check.lm() doesn't fail names(lm12$coefficients) <- NULL # were "(Intercept)" "xTRUE" names(linmod12.xy$coefficients) <- NULL # were "(Intercept)" "V1" check.lm(linmod12.xy, lm12, newdata=bool.data[3:5,1], check.newdata=FALSE, # needed because predict.lm gives invalid 'envir' argument of type 'logical' check.casenames=FALSE) cat0("==check use of functions in arguments to linmod\n") identfunc <- function(x) x lm10 <- lm( sqrt(survived) ~ I(age^2) + as.numeric(sex), data=identfunc(etit)) linmod10 <- linmod(sqrt(survived) ~ I(age^2) + as.numeric(sex), data=identfunc(etit)) print(summary(lm10)) print(summary(linmod10)) check.lm(linmod10, lm10, newdata=etit[3:5,]) set.seed(2020) plotmo(lm10, pt.col="green", do.par=2) set.seed(2020) plotmo(linmod10, pt.col="green", do.par=0) par(org.par) cat0("==data.frame with strings\n") df.with.string <- data.frame(1:5, c(1,2,-1,4,5), c("a", "b", "a", "a", "b"), stringsAsFactors=FALSE) colnames(df.with.string) <- c("num1", "num2", "string") linmod30.form <- linmod(num1~num2, df.with.string) lm30 <- lm(num1~num2, df.with.string) check.lm(linmod30.form, lm30, check.newdata=FALSE) linmod31.form <- linmod(num1~., df.with.string) lm31 <- lm(num1~., df.with.string) check.lm(linmod31.form, lm31, check.newdata=FALSE) expect.err(try(linmod(string~., df.with.string)), "'y' is not numeric or logical") vec <- c(1,2,3,4,3) expect.err(try(linmod(df.with.string, vec)), "non-numeric column in 'x'") expect.err(try(linmod(etit$pclass, etit$survived)), "non-numeric column in 'x'") cat0("==x is singular\n") set.seed(1) x2 <- matrix(rnorm(6), nrow=2) y2 <- c(1,2) expect.err(try(linmod(y2~x2)), "'x' is singular (it has 4 columns but its rank is 2)") x3 <- matrix(1:10, ncol=2) y3 <- c(1,2,9,4,5) expect.err(try(linmod(y3~x3)), "'x' is singular (it has 3 columns but its rank is 2)") expect.err(try(linmod(trees[1,1:2], trees[1,3])), "'x' is singular (it has 3 columns but its rank is 1)") x2a <- matrix(1:6, nrow=3) y2a <- c(1,2,3) expect.err(try(linmod(y2a~x2a)), "'x' is singular (it has 3 columns but its rank is 2)") cat0("==perfect fit (residuals are zero)\n") set.seed(1) x2b <- matrix(rnorm(6), nrow=3) y2b <- c(1,2,3) data.x2b <- data.frame(x2b, y2b) colnames(data.x2b) <- c("x1", "x2", "y") linmod.x2b <- linmod(y~., data=data.x2b) print(summary(linmod.x2b)) # will have "Residual degrees-of-freedom is zero" comment lm.x2b <- lm(y~., data=data.x2b) print(summary(lm.x2b)) # will have "ALL 3 residuals are 0" comment check.lm(linmod.x2b, lm.x2b, newdata=data.x2b[1:2,]+1, check.sigma=FALSE) x2c <- 1:10 y2c <- 11:20 data.x2c <- data.frame(x2c, y2c) colnames(data.x2c) <- c("x", "y") linmod.x2c <- linmod(y~., data=data.x2c) print(summary(linmod.x2c)) lm.x2c <- lm(y~., data=data.x2c) options(warn=1) # print warnings as they occur print(summary(lm.x2c)) # will have "essentially perfect fit: summary may be unreliable" comment options(warn=2) # treat warnings as errors check.lm(linmod.x2c, lm.x2c, newdata=data.x2c[1:2,]+1, check.sigma=FALSE) par(mfrow=c(2,2)) # all plots on same page so can compare plot(linmod.x2b, main="linmod.x2b\nall residuals are zero") plot(lm.x2b, which=1, main="lm.x2b") plot(linmod.x2c, main="linmod.x2c") plot(lm.x2c, which=1, main="lm.x2c") par(org.par) cat0("==nrow(x) does not match length(y)\n") x4 <- matrix(1:10, ncol=2) y4 <- c(1,2,9,4) expect.err(try(linmod(x4, y4)), "nrow(x) is 5 but length(y) is 4") x5 <- matrix(1:10, ncol=2) y5 <- c(1,2,9,4,5,9) expect.err(try(linmod(x5, y5)), "nrow(x) is 5 but length(y) is 6") cat0("==y has multiple columns\n") vec <- c(1,2,3,4,3) y2 <- cbind(c(1,2,3,4,9), vec^2) expect.err(try(linmod(vec, y2)), "nrow(x) is 5 but length(y) is 10") expect.err(try(linmod(y2~vec)), "nrow(x) is 5 but length(y) is 10") cat0("==NA in x\n") x <- tr[,1:2] y <- tr[,3] x[2,2] <- NA expect.err(try(linmod(x, y)), "NA in 'x'") x <- tr[,1:2] y <- tr[,3] y[9] <- NA expect.err(try(linmod(x, y)), "NA in 'y'") # Following added Sep 2020 (prior to this, predict.linmod gave an incorrect error message) cat0("==test formulas that use functions on rhs variables, like Volume~sqrt(Girth)\n") linmod.sqrt1 <- linmod(Volume~sqrt(as.numeric(Girth)), data=tr) cat0("==print(summary(linmod.sqrt1))\n") print(summary(linmod.sqrt1)) lm.sqrt1 <- lm(Volume~sqrt(as.numeric(Girth)), data=tr) check.lm(linmod.sqrt1, lm.sqrt1) stopifnot(almost.equal(predict(linmod.sqrt1, newdata=data.frame(Girth=10, Height=80)), predict(lm.sqrt1, newdata=data.frame(Girth=10, Height=80)))) stopifnot(almost.equal(predict(linmod.sqrt1, newdata=as.matrix(tr[1:3,])), predict(lm.sqrt1, newdata=tr[1:3,]))) par(mfrow=c(2,2)) # all plots on same page so can compare plotmo(linmod.sqrt1, do.par=FALSE) plotmo(lm.sqrt1, do.par=FALSE) par(org.par) linmod.sqrt2 <- linmod(Volume~sqrt(Girth)+Height+Girth, data=tr) cat0("==print(summary(linmod.sqrt2))\n") print(summary(linmod.sqrt2)) lm.sqrt2 <- lm(Volume~sqrt(Girth)+Height+Girth, data=tr) check.lm(linmod.sqrt2, lm.sqrt2) stopifnot(almost.equal(predict(linmod.sqrt2, newdata=data.frame(Girth=10, Height=80)), predict(lm.sqrt2, newdata=data.frame(Girth=10, Height=80)))) stopifnot(almost.equal(predict(linmod.sqrt2, newdata=as.matrix(tr[1:3,])), predict(lm.sqrt2, newdata=tr[1:3,]))) par(mfrow=c(2,2)) # all plots on same page so can compare plotmo(linmod.sqrt2, do.par=FALSE) plotmo(lm.sqrt2, do.par=FALSE) par(org.par) lm.sqrt.as.numeric <- lm(survived~sqrt(age)+as.numeric(pclass), data=etit) linmod.sqrt.as.numeric <- linmod(survived~sqrt(age)+as.numeric(pclass), data=etit) check.lm(linmod.sqrt.as.numeric, lm.sqrt.as.numeric, newdata=etit[3:5,]) expect.err(try(predict(linmod.sqrt.as.numeric, newdata=data.frame(age=30))), # pclass missing "object 'pclass' not found") par(mfrow=c(2,2)) # all plots on same page so can compare plotmo(linmod.sqrt.as.numeric, do.par=FALSE) plotmo(lm.sqrt.as.numeric, do.par=FALSE) par(org.par) y.age <- etit[,"age"] x.pclass <- etit[,"pclass"] x.sex <- etit[,"sex"] linmod.y.age.sex.pclass <- linmod(y.age ~ as.numeric(x.pclass) + x.sex) lm.y.age.sex.pclass <- lm( y.age ~ as.numeric(x.pclass) + x.sex) stopifnot(identical(linmod.y.age.sex.pclass$coef, lm.y.age.sex.pclass$coef)) options(warn=1) # print warnings as they occur to test stop() in linmod.R::process.newdata.formula # TODO following says variable 'as.numeric(x.pclass)' may be missing # it should say variable 'x.pclass' may be missing expect.err(try(predict(linmod.y.age.sex.pclass, newdata=etit[3:5,1,drop=FALSE])), "newdata has 3 rows but model.frame returned 18 rows (variable 'as.numeric(x.pclass)' may be missing from newdata)") options(warn=2) # back to treating warnings as errors cat0("==misc tests with different kinds of data\n") data3 <- data.frame(s=c("a", "b", "a", "c", "a"), num=c(1,5,1,9,2), y=c(1,3,2,5,3), stringsAsFactors=F) stopifnot(sapply(data3, class) == c("character", "numeric", "numeric")) a40 <- linmod(y~., data=data3) print(summary(a40)) stopifnot(almost.equal(a40$coefficients, c(0, -4.5, -8.5, 1.5), max=0.001)) stopifnot(almost.equal(predict(a40, newdata=data3[2:3,]), c(3.0, 1.5), max=0.001)) data4 <- data.frame(s=c("a", "b", "a", "c", "a"), num=c(1,5,1,9,2), y=c(1,3,2,5,3), stringsAsFactors=T) stopifnot(sapply(data4, class) == c("factor", "numeric", "numeric")) expect.err(try(linmod(data4[,1:2], data4[,3])), "non-numeric column in 'x'") # following gives no error (and matches lm) even though col 1 of data3 is character not factor a41 <- linmod(y~., data=data4) print(summary(a41)) stopifnot(almost.equal(predict(a41, newdata=data3[2:3,]), c(3.0, 1.5), max=0.001)) data5 <- data.frame(s=c("a", "b", "c", "a", "a"), num=c(1,9,4,2,6), y=c(1,2,3,5,3), stringsAsFactors=F) stopifnot(almost.equal(predict(a41, newdata=data5[1:3,1:2]), c(1.5, 9.0, -2.5), max=0.001)) data6 <- data.frame(s=c("a", "b", "c", "a9", "a"), num=c(1,9,4,2,6), num2=c(1,9,4,2,7), y=c(1,2,3,5,3), stringsAsFactors=T) expect.err(try(predict(a41, newdata=data6[1:3,1])), "object 's' not found") expect.err(try(predict(a41, newdata=data6[1:3,c(1,1)])), "object 'num' not found") expect.err(try(predict(a41, newdata=data.frame(s=1, num=2, y=3))), "variable 's' is not a factor") expect.err(try(predict(a41, newdata=1:9)), "object 's' not found") expect.err(try(predict(a41, newdata=data.frame())), "'newdata' is empty") # perfect fit (residuals are all zero) linmod.data6 <- linmod(y~s+num, data=data6) print(summary(linmod.data6)) lm.data6 <- lm(y~s+num, data=data6) print(summary(lm.data6)) check.lm(linmod.data6, lm.data6, newdata=data6[2,,drop=FALSE], check.sigma=FALSE) expect.err(try(linmod(y~., data=data6)), "'x' is singular (it has 6 columns but its rank is 5)") tr.na <- trees tr.na[9,3] <- NA expect.err(try(linmod(Volume~.,data=tr.na)), "NA in 'y'") expect.err(try(linmod(tr.na[,1:2], tr.na[,3])), "NA in 'y'") tr.na <- trees tr.na[10,1] <- NA expect.err(try(linmod(Volume~.,data=tr.na)), "NA in 'x'") expect.err(try(linmod(tr.na[,1:2], tr.na[,3])), "NA in 'x'") a42 <- linmod(trees[,1:2], trees[, 3]) newdata1 <- data.frame(Girth=20) expect.err(try(predict(a42, newdata=newdata1)), "ncol(newdata) is 1 but should be 2") newdata3 <- data.frame(Girth=20, extra1=21, extra2=22) expect.err(try(predict(a42, newdata=newdata3)), "ncol(newdata) is 3 but should be 2") expect.err(try(predict(a42, newdata=data.frame())), "'newdata' is empty") newdata.with.NA <- data.frame(Girth=20, Height=NA) expect.err(try(predict(a42, newdata=newdata.with.NA)), "NA in 'newdata'") a43 <- linmod(Volume~.,data=trees) expect.err(try(predict(a43, newdata=newdata.with.NA)), "NA in 'newdata'") lm43 <- lm(Volume~.,data=trees) # message from predict.lm could be better expect.err(try(predict(lm43, newdata=newdata.with.NA)), "variable 'Height' was fitted with type \"numeric\" but type \"logical\" was supplied") y6 <- 1:5 x6 <- data.frame() options(warn=1) # print warnings as they occur expect.err(try(linmod(x6, y6)), "'x' is empty") options(warn=2) # treat warnings as errors y7 <- data.frame() x7 <- 1:5 expect.err(try(linmod(x7, y7)), "'y' is empty") # duplicated column names data7 <- matrix(1:25, ncol=5) colnames(data7) <- c("y", "x1", "x1", "x3", "x4") expect.err(try(linmod(data7[,-1], data7[,1])), "column name \"x1\" in 'x' is duplicated") colnames(data7) <- c("y", "x1", "x2", "x2", "x4") expect.err(try(linmod(data7[,-1], data7[,1])), "column name \"x2\" in 'x' is duplicated") colnames(data7) <- c("y", "x1", "x2", "x2", "x2") expect.err(try(linmod(data7[,-1], data7[,1])), "column name \"x2\" in 'x' is duplicated") # column name V2 will be created but it clashes with the existing column name colnames(data7) <- c("y", "V2", "", "V3", "V4") expect.err(try(linmod(data7[,-1], data7[,1])), "column name \"V2\" in 'x' is duplicated") # missing column names trees1 <- trees colnames(trees1) <- NULL cat0("a52\n") a52 <- linmod(trees1[,1:2], trees1[,3]) print(summary(a52)) trees1 <- trees colnames(trees1) <- c("", "Height", "Volume") # was Girth Height Volume cat0("linmod.form.Volume.trees1\n") linmod.form.Volume.trees1 <- linmod(trees1[,1:2], trees1[,3]) print(summary(linmod.form.Volume.trees1)) cat0("linmod.form.Volume.trees1.formula\n") expect.err(try(linmod(Volume~., data=trees1)), "attempt to use zero-length variable name") # very long names to test formatting in summary.linmod trees1 <- trees colnames(trees1) <- c("Girth.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name", "Height.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name", "Volume.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name") cat0("a55\n") a55 <- linmod(Volume.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name~ Girth.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name+ Height.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name, data=trees1) print(summary(a55)) # intercept-only model intonly.form <- linmod(Volume~1, data=trees) print(summary(intonly.form)) stopifnot(length(coef(intonly.form)) == 1) try(plotmo(intonly.form)) # Error in plotmo(intonly.form) : x is empty plotres(intonly.form) expect.err(try(plotmo(intonly.form)), "x is empty") expect.err(try(linmod(rep(1, length.out=nrow(trees)), trees$Volume)), "'x' is singular (it has 2 columns but its rank is 1)") # various tests for bad args expect.err(try(linmod(trees[,1:2])), "no 'y' argument") # test stop.if.dot.arg.used expect.err(try(linmod(Volume~., data=trees, nonesuch=99)), "unused argument (nonesuch = 99)") expect.err(try(linmod(trees[,1:2], trees[,3], nonesuch=linmod)), "unused argument (nonesuch = function (...)") expect.err(try(summary(linmod(trees[,1:2], trees[,3]), nonesuch=linmod)), "unused argument (nonesuch = function (...)") expect.err(try(print(linmod(trees[,1:2], trees[,3]), nonesuch=linmod)), "unused argument (nonesuch = function (...)") expect.err(try(predict(linmod.form.Volume.tr, nonesuch=99)), "unused argument (nonesuch = 99)") # check partial matching on type argument stopifnot(identical(predict(linmod.form.Volume.tr, type="r"), predict(linmod.form.Volume.tr))) stopifnot(identical(predict(linmod.form.Volume.tr, type="resp"), predict(linmod.form.Volume.tr))) expect.err(try(predict(linmod.form.Volume.tr, type="nonesuch")), "'arg' should be \"response\"") # test additional method functions (see linmod.methods.R) check.lm(linmod.form.Volume.tr, lm.Volume.tr, newdata=trees[3,1:2]) stopifnot(almost.equal(coef(linmod.form.Volume.tr), coef(lm.Volume.tr))) stopifnot(identical(names(coef(linmod.form.Volume.tr)), names(coef(lm.Volume.tr)))) stopifnot(almost.equal(fitted(linmod.form.Volume.tr), fitted(lm.Volume.tr))) stopifnot(identical(names(fitted(linmod.form.Volume.tr)), names(fitted(lm.Volume.tr)))) stopifnot(identical(na.action(linmod.form.Volume.tr), na.action(lm.Volume.tr))) stopifnot(almost.equal(residuals(linmod.form.Volume.tr), residuals(lm.Volume.tr))) stopifnot(identical(names(residuals(linmod.form.Volume.tr)), names(residuals(lm.Volume.tr)))) stopifnot(identical(names(case.names(linmod.form.Volume.tr)), names(case.names(lm.Volume.tr)))) stopifnot(identical(variable.names(linmod.form.Volume.tr), variable.names(lm.Volume.tr))) stopifnot(identical(nobs(linmod.form.Volume.tr), nobs(lm.Volume.tr))) stopifnot(identical(weights(linmod.form.Volume.tr), weights(lm.Volume.tr))) stopifnot(almost.equal(df.residual(linmod.form.Volume.tr), df.residual(lm.Volume.tr))) stopifnot(identical(names(df.residual(linmod.form.Volume.tr)), names(df.residual(lm.Volume.tr)))) stopifnot(almost.equal(deviance(linmod.form.Volume.tr), deviance(lm.Volume.tr))) stopifnot(identical(names(deviance(linmod.form.Volume.tr)), names(deviance(lm.Volume.tr)))) stopifnot(identical(weights(linmod.form.Volume.tr), weights(lm.Volume.tr))) stopifnot(identical(model.frame(linmod.form.Volume.tr), model.frame(lm.Volume.tr))) stopifnot(identical(model.matrix(linmod.form.Volume.tr), model.matrix(lm.Volume.tr))) stopifnot(identical(model.matrix(linmod.form.Volume.tr, data=tr[1:2,]), model.matrix(lm.Volume.tr, data=tr[1:2,]))) stopifnot(almost.equal(logLik(linmod.form.Volume.tr), logLik(lm.Volume.tr))) expect.err(try(logLik(linmod.form.Volume.tr, REML=TRUE)), "!REML is not TRUE") library(sandwich) # for estfun.lm stopifnot(almost.equal(estfun(linmod.form.Volume.tr), estfun(lm.Volume.tr))) linmod.form.Volume.tr.update <- update(linmod.form.Volume.tr, formula.=Volume~Height) lm.Volume.tr.update <- update(lm.Volume.tr, formula.=Volume~Height) check.lm(linmod.form.Volume.tr.update, lm.Volume.tr.update) check.lm(linmod.xy.Volume.tr, lm.Volume.tr, newdata=trees[3,1:2]) stopifnot(almost.equal(coef(linmod.xy.Volume.tr), coef(lm.Volume.tr))) stopifnot(identical(names(coef(linmod.xy.Volume.tr)), names(coef(lm.Volume.tr)))) stopifnot(almost.equal(fitted(linmod.xy.Volume.tr), fitted(lm.Volume.tr))) stopifnot(identical(names(fitted(linmod.xy.Volume.tr)), names(fitted(lm.Volume.tr)))) stopifnot(identical(na.action(linmod.xy.Volume.tr), na.action(lm.Volume.tr))) stopifnot(almost.equal(residuals(linmod.xy.Volume.tr), residuals(lm.Volume.tr))) stopifnot(identical(names(residuals(linmod.xy.Volume.tr)), names(residuals(lm.Volume.tr)))) stopifnot(identical(case.names(linmod.xy.Volume.tr), case.names(lm.Volume.tr))) stopifnot(identical(variable.names(linmod.xy.Volume.tr), variable.names(lm.Volume.tr))) stopifnot(identical(nobs(linmod.xy.Volume.tr), nobs(lm.Volume.tr))) stopifnot(identical(weights(linmod.xy.Volume.tr), weights(lm.Volume.tr))) stopifnot(almost.equal(df.residual(linmod.xy.Volume.tr), df.residual(lm.Volume.tr))) stopifnot(identical(names(df.residual(linmod.xy.Volume.tr)), names(df.residual(lm.Volume.tr)))) stopifnot(almost.equal(deviance(linmod.xy.Volume.tr), deviance(lm.Volume.tr))) stopifnot(identical(names(deviance(linmod.xy.Volume.tr)), names(deviance(lm.Volume.tr)))) stopifnot(identical(weights(linmod.xy.Volume.tr), weights(lm.Volume.tr))) expect.err(try(model.frame(linmod.xy.Volume.tr)), "model.frame cannot be used on linmod models built without a formula") expect.err(try(model.matrix(linmod.xy.Volume.tr)), "model.frame cannot be used on linmod models built without a formula") stopifnot(almost.equal(logLik(linmod.xy.Volume.tr), logLik(lm.Volume.tr))) par(mfrow=c(2,2)) plot(linmod.form.Volume.tr) plot(lm.Volume.tr, which=1, main="lm.Volume.tr") plot(linmod.xy.Volume.tr) plot(linmod.form.Volume.tr, xlim=c(0,80), ylim=c(-10,10), pch=20, main="linmod.form.Volume.tr: test plot args") par(org.par) cat0("==test one predictor model\n") linmod.onepred.form <- linmod(Volume~Girth, data=tr) # one predictor lm.onepred.form <- lm(Volume~Girth, data=tr) check.lm(linmod.onepred.form, lm.onepred.form, newdata=trees[3,1:2]) linmod.onepred.xy <- linmod(tr[,1,drop=FALSE], tr[,3]) # one predictor print(summary(linmod.onepred.xy)) check.lm(linmod.onepred.xy, lm.onepred.form, newdata=trees[3,1,drop=FALSE]) par(mfrow=c(2,2)) plot(linmod.onepred.form) plot(lm.onepred.form, which=1, main="lm.onepred.form") plot(linmod.onepred.xy) par(org.par) plotres(linmod.onepred.form) plotmo(linmod.onepred.form, pt.col=2) cat0("==test no intercept model\n") # no intercept models are only supported with the formula interface (not x,y interface) linmod.noint <- linmod(Volume~.-1, data=trees) # no intercept print(summary(linmod.noint)) lm.noint <- lm(Volume~.-1, data=trees) # no intercept check.lm(linmod.noint, lm.noint) linmod.noint.keep <- linmod(Volume~.-1, data=trees, keep=TRUE) print(summary(linmod.noint.keep)) check.lm(linmod.noint, lm.noint) stopifnot(class(linmod.noint.keep$data) == class(linmod.form.Volume.trees.keep$data)) stopifnot(all(dim(linmod.noint.keep$data) == dim(linmod.form.Volume.trees.keep$data))) stopifnot(all(linmod.noint.keep$data == linmod.form.Volume.trees.keep$data)) stopifnot(class(linmod.noint.keep$y) == class(linmod.form.Volume.trees.keep$y)) stopifnot(all(dim(linmod.noint.keep$data) == dim(linmod.form.Volume.trees.keep$data))) stopifnot(all(linmod.noint.keep$data == linmod.form.Volume.trees.keep$data)) # check method functions in no-intercept model stopifnot(almost.equal(coef(linmod.noint), coef(lm.noint))) stopifnot(identical(names(coef(linmod.noint)), names(coef(lm.noint)))) stopifnot(almost.equal(fitted(linmod.noint), fitted(lm.noint))) stopifnot(identical(names(fitted(linmod.noint)), names(fitted(lm.noint)))) stopifnot(identical(na.action(linmod.noint), na.action(lm.noint))) stopifnot(almost.equal(residuals(linmod.noint), residuals(lm.noint))) stopifnot(identical(names(residuals(linmod.noint)), names(residuals(lm.noint)))) stopifnot(identical(case.names(linmod.noint), case.names(lm.noint))) stopifnot(identical(variable.names(linmod.noint), variable.names(lm.noint))) stopifnot(identical(nobs(linmod.noint), nobs(lm.noint))) stopifnot(identical(weights(linmod.noint), weights(lm.noint))) stopifnot(almost.equal(df.residual(linmod.noint), df.residual(lm.noint))) stopifnot(identical(names(df.residual(linmod.noint)), names(df.residual(lm.noint)))) stopifnot(almost.equal(deviance(linmod.noint), deviance(lm.noint))) stopifnot(identical(names(deviance(linmod.noint)), names(deviance(lm.noint)))) stopifnot(identical(weights(linmod.noint), weights(lm.noint))) stopifnot(identical(model.frame(linmod.noint), model.frame(lm.noint))) stopifnot(identical(model.matrix(linmod.noint), model.matrix(lm.noint))) stopifnot(identical(model.matrix(linmod.noint, data=tr[1:2,]), model.matrix(lm.noint, data=tr[1:2,]))) stopifnot(almost.equal(logLik(linmod.noint), logLik(lm.noint))) stopifnot(almost.equal(estfun(linmod.noint), estfun(lm.noint))) # check error messages with bad newdata in no-intercept model expect.err(try(predict(linmod.noint, newdata=NA)), "object 'Girth' not found") expect.err(try(predict(linmod.noint, newdata=data.frame(Height=c(1,NA), Girth=c(3,4)))), "NA in 'newdata'") expect.err(try(predict(linmod.noint, newdata=trees[0,])), "'newdata' is empty") expect.err(try(predict(linmod.noint, newdata=trees[3:5,"Height"])), "object 'Girth' not found") # check that extra fields in predict newdata are ok with (formula) models without intercept stopifnot(almost.equal(predict(linmod.noint, newdata=data.frame(Girth=10, Height=80, extra=99)), predict(lm.noint, newdata=data.frame(Girth=10, Height=80, extra=99)))) par(mfrow=c(2,2)) plot(linmod.noint) plot(lm.noint, which=1, main="lm.noint") par(org.par) plotres(linmod.noint) plotmo(linmod.noint) cat0("==test one predictor no intercept model\n") # no intercept models are only supported with the formula interface (not x,y interface) linmod.onepred.noint <- linmod(Volume~Girth-1, data=trees) # one predictor, no intercept print(summary(linmod.onepred.noint)) lm.onepred.noint <- lm(Volume~Girth-1, data=trees) # one predictor, no intercept check.lm(linmod.onepred.noint, lm.onepred.noint) linmod.onepred.noint.keep <- linmod(Volume~.-1, data=trees, keep=TRUE) print(summary(linmod.onepred.noint.keep)) check.lm(linmod.onepred.noint, lm.onepred.noint) stopifnot(class(linmod.onepred.noint.keep$data) == class(linmod.form.Volume.trees.keep$data)) stopifnot(all(dim(linmod.onepred.noint.keep$data) == dim(linmod.form.Volume.trees.keep$data))) stopifnot(all(linmod.onepred.noint.keep$data == linmod.form.Volume.trees.keep$data)) stopifnot(class(linmod.onepred.noint.keep$y) == class(linmod.form.Volume.trees.keep$y)) stopifnot(all(dim(linmod.onepred.noint.keep$data) == dim(linmod.form.Volume.trees.keep$data))) stopifnot(all(linmod.onepred.noint.keep$data == linmod.form.Volume.trees.keep$data)) # check method functions in one predictor no-intercept model stopifnot(almost.equal(coef(linmod.onepred.noint), coef(lm.onepred.noint))) stopifnot(identical(names(coef(linmod.onepred.noint)), names(coef(lm.onepred.noint)))) stopifnot(almost.equal(fitted(linmod.onepred.noint), fitted(lm.onepred.noint))) stopifnot(identical(names(fitted(linmod.onepred.noint)), names(fitted(lm.onepred.noint)))) stopifnot(identical(na.action(linmod.onepred.noint), na.action(lm.onepred.noint))) stopifnot(almost.equal(residuals(linmod.onepred.noint), residuals(lm.onepred.noint))) stopifnot(identical(names(residuals(linmod.onepred.noint)), names(residuals(lm.onepred.noint)))) stopifnot(identical(case.names(linmod.onepred.noint), case.names(lm.onepred.noint))) stopifnot(identical(variable.names(linmod.onepred.noint), variable.names(lm.onepred.noint))) stopifnot(identical(nobs(linmod.onepred.noint), nobs(lm.onepred.noint))) stopifnot(identical(weights(linmod.onepred.noint), weights(lm.onepred.noint))) stopifnot(almost.equal(df.residual(linmod.onepred.noint), df.residual(lm.onepred.noint))) stopifnot(identical(names(df.residual(linmod.onepred.noint)), names(df.residual(lm.onepred.noint)))) stopifnot(almost.equal(deviance(linmod.onepred.noint), deviance(lm.onepred.noint))) stopifnot(identical(names(deviance(linmod.onepred.noint)), names(deviance(lm.onepred.noint)))) stopifnot(identical(weights(linmod.onepred.noint), weights(lm.onepred.noint))) stopifnot(identical(model.frame(linmod.onepred.noint), model.frame(lm.onepred.noint))) stopifnot(identical(model.matrix(linmod.onepred.noint), model.matrix(lm.onepred.noint))) stopifnot(identical(model.matrix(linmod.onepred.noint, data=tr[1:2,]), model.matrix(lm.onepred.noint, data=tr[1:2,]))) stopifnot(almost.equal(logLik(linmod.onepred.noint), logLik(lm.onepred.noint))) stopifnot(almost.equal(estfun(linmod.onepred.noint), estfun(lm.onepred.noint))) # check error messages with bad newdata in one predictor no-intercept model expect.err(try(predict(linmod.onepred.noint, newdata=99)), "object 'Girth' not found") expect.err(try(predict(linmod.onepred.noint, newdata=data.frame(Girth=NA))), "NA in 'newdata'") expect.err(try(predict(linmod.onepred.noint, newdata=trees[0,1])), "'newdata' is empty") expect.err(try(predict(linmod.onepred.noint, newdata=trees[3:5,"Height"])), "object 'Girth' not found") # check that extra fields in predict newdata are ok with (formula) models without intercept stopifnot(almost.equal(predict(linmod.onepred.noint, newdata=data.frame(Girth=10, extra=99)), predict(lm.onepred.noint, newdata=data.frame(Girth=10, extra=99)))) par(mfrow=c(2,2)) plot(linmod.onepred.noint) plot(lm.onepred.noint, which=1, main="lm.onepred.noint") par(org.par) plotres(linmod.onepred.noint) plotmo(linmod.onepred.noint) expect.err(try(linmod(Volume~nonesuch, data=trees)), "object 'nonesuch' not found") expect.err(try(linmod(Volume~0, data=trees)), "'x' is empty") # no predictor expect.err(try(linmod(Volume~-1, data=trees)), "'x' is empty") # no predictor, no intercept cat0("==check model with many variables\n") set.seed(2018) p <- 300 # number of variables n <- floor(1.1 * p) bigdat <- as.data.frame(matrix(rnorm(n * (p+1)), ncol=p+1)) colnames(bigdat) <- c("y", paste0("var", 1:p)) lm.bigdat <- lm(y~., data=bigdat) linmod.bigdat <- linmod(y~., data=bigdat) check.lm(linmod.form.Volume.tr, lm.Volume.tr) print(linmod.bigdat) print(summary(linmod.bigdat)) expect.err(try(predict(linmod.bigdat, newdata=bigdat[,1:(p-3)])), "object 'var297' not found") plot(linmod.bigdat) # plotmo(linmod.bigdat) # works, but commented out because slow(ish) # plotres(linmod.bigdat) # ditto cat0("==check use of matrix as data in linmod.form\n") # linmod.form allows a matrix, lm doesn't TODO is this inconsistency what we want? tr.mat <- as.matrix(tr) cat0("class(tr.mat)=", class(tr.mat), "\n") # class(tr.mat)=matrix expect.err(try(lm(Volume~., data=tr.mat)), "'data' must be a data.frame, not a matrix or an array") linmod.form.Volume.mat.tr <- linmod(Volume~., data=tr.mat) check.lm(linmod.form.Volume.mat.tr, linmod.form.Volume.tr) cat0("==print(summary(linmod.form.Volume.mat.tr))\n") print(summary(linmod.form.Volume.mat.tr)) plotres(linmod.form.Volume.mat.tr) tr.mat.no.colnames <- as.matrix(tr) colnames(tr.mat.no.colnames) <- NULL expect.err(try(linmod(Volume~., data=tr.mat.no.colnames)), "object 'Volume' not found") linmod.form.Volume.mat.tr.no.colnames <- linmod(V3~., data=tr.mat.no.colnames) check.lm(linmod.form.Volume.mat.tr.no.colnames, linmod.form.Volume.tr, check.coef.names=FALSE, check.newdata=FALSE) # no check.newdata else object 'V1' not found # Check what happens when we change the original data used to build the model. # Use plotres as an example function that must figure out residuals from predict(). pr <- function(model, main=deparse(substitute(model))) { plotres(model, which=3, main=main) # which=3 for just the residuals plot } cat0("==linmod.formula: change data used to build the model\n") trees1 <- trees linmod.trees1 <- linmod(Volume~., data=trees1) # delete the saved residuals and fitted.values so plotres has to use the saved # call etc. to get the x and y used to build the model, and rely on predict() linmod.trees1$residuals <- NULL linmod.trees1$fitted.values <- NULL par(mfrow=c(3,3)) pr(linmod.trees1) trees1 <- trees[, 3:1] # change column order in original data pr(linmod.trees1, "change col order") trees1 <- trees[1:3, ] # change number of rows in original data pr(linmod.trees1, "change nbr rows") # TODO wrong residuals! (lm has the same issue) cat("call$data now refers to the changed data:\n") # lm has the same problem if called with model=FALSE print(eval(linmod.trees1$call$data)) cat("model.frame now returns the changed data:\n") print(model.frame(linmod.trees1)) trees1 <- trees[nrow(tr):1, ] # change row order (but keep same nbr of rows) pr(linmod.trees1, "change row order") colnames(trees1) <- c("x1", "x2", "x3") # change column names in original data expect.err(try(pr(linmod.trees1, "change colnames")), "cannot get the original model predictors") trees1 <- "garbage" expect.err(try(pr(linmod.trees1, "trees1=\"garbage\"")), "cannot get the original model predictors") trees1 <- 1:1000 expect.err(try(pr(linmod.trees1, "trees1=1:1000")), "cannot get the original model predictors") trees1 <- NULL # original data no longer available expect.err(try(pr(linmod.trees1, "trees1=NULL")), "cannot get the original model predictors") remove(trees1) expect.err(try(pr(linmod.trees1, "remove(trees1)")), "cannot get the original model predictors") # similar to above, but don't delete the saved residuals and fitted.values trees1 <- trees linmod2.trees1 <- linmod(Volume~., data=trees1) trees1 <- trees[1:3, ] # change number of rows in original data expect.err(try(plotmo(linmod2.trees1)), "plotmo_y returned the wrong length (got 3 but expected 31)") par(org.par) cat0("==linmod.formula(keep=TRUE): change data used to build the model\n") par(mfrow=c(3,3)) trees1 <- trees linmod.trees1.keep <- linmod(Volume~., data=trees1, keep=TRUE) # delete the saved residuals and fitted.values so plotres has to use the saved # call etc. to get the x and y used to build the model, and rely on predict() linmod.trees1.keep$residuals <- NULL linmod.trees1.keep$fitted.values <- NULL pr(linmod.trees1.keep) trees1 <- trees[, 3:1] # change column order in original data pr(linmod.trees1.keep, "change col order") trees1 <- trees[1:3, ] # change number of rows in original data pr(linmod.trees1.keep, "change nbr rows") trees1 <- trees[nrow(tr):1, ] # change row order (but keep same nbr of rows) pr(linmod.trees1.keep, "change row order") colnames(trees1) <- c("x1", "x2", "x3") # change column names in original data pr(linmod.trees1.keep, "change colnames") trees1 <- NULL # original data no longer available pr(linmod.trees1.keep, "trees1=NULL") remove(trees1) pr(linmod.trees1.keep, "remove(trees1)") par(org.par) cat0("==linmod.default: change data used to build the model\n") trees1 <- trees x1 <- trees1[,1:2] y1 <- trees1[,3] linmod.xy <- linmod(x1, y1) # delete the saved residuals and fitted.values so plotres has to use the saved # call etc. to get the x1 and y1 used to build the model, and rely on predict() linmod.xy$residuals <- NULL linmod.xy$fitted.values <- NULL par(mfrow=c(3,3)) pr(linmod.xy) x1 <- trees1[,2:1] # change column order in original x1 pr(linmod.xy, "change col order") x1 <- trees1[1:3, 1:2] # change number of rows in original x1 expect.err(try(pr(linmod.xy, "change nbr rows")), "plotmo_y returned the wrong length (got 31 but expected 3)") # TODO different behaviour to linmod.trees1 cat("call$x1 now refers to the changed x1:\n") # lm has the same problem if called with model=FALSE print(eval(linmod.xy$call$x1)) x1 <- trees1[nrow(tr):1, 1:2] # change row order (but keep same nbr of rows) pr(linmod.xy, "change row order") x1 <- trees1[,1:2] colnames(x1) <- c("x1", "x2") # change column names in original x1 pr(linmod.xy, "change colnames") x1 <- "garbage" expect.err(try(pr(linmod.xy, "x1=\"garbage\"")), "cannot get the original model predictors") x1 <- 1:1000 expect.err(try(pr(linmod.xy, "x1=1:1000")), "ncol(newdata) is 1 but should be 2") x1 <- NULL # original x1 no longer available expect.err(try(pr(linmod.xy, "x1=NULL")), "cannot get the original model predictors") remove(x1) expect.err(try(pr(linmod.xy, "remove(x1)")), "cannot get the original model predictors") # similar to above, but don't delete the saved residuals and fitted.values trees1 <- trees x1 <- trees1[,1:2] y1 <- trees1[,3] linmod.xy <- linmod(x1, y1) x1 <- trees1[1:3, 1:2] # change number of rows in original x1 expect.err(try(plotmo(linmod2.x1)), "object 'linmod2.x1' not found") # TODO error message misleading? par(org.par) cat0("==linmod.default(keep=TRUE): change data used to build the model\n") par(mfrow=c(3,3)) trees1 <- trees x1 <- trees1[,1:2] linmod.xy <- linmod(x1, y1, keep=TRUE) # delete the saved residuals and fitted.values so plotres has to use the saved # call etc. to get the x1 and y1 used to build the model, and rely on predict() linmod.xy$residuals <- NULL linmod.xy$fitted.values <- NULL pr(linmod.xy.keep) x1 <- trees1[, 2:1] # change column order in original x1 pr(linmod.xy.keep, "change col order") x1 <- trees1[1:3, 1:2] # change number of rows in original x1 pr(linmod.xy.keep, "change nbr rows") x1 <- trees1[nrow(tr):1, 1:2] # change row order (but keep same nbr of rows) pr(linmod.xy.keep, "change row order") x1 <- trees1[,1:2] colnames(x1) <- c("x1", "x2") # change column names in original x1 pr(linmod.xy.keep, "change colnames") x1 <- NULL # original x1 no longer available pr(linmod.xy.keep, "x1=NULL") remove(x1) pr(linmod.xy.keep, "remove(x1)") par(org.par) cat("==test processing a model created in a function with local data\n") # pr <- function(model, main=deparse(substitute(model))) # { # plotmo(model, degree1=1, degree2=0, pt.col=2, do.par=FALSE, main=main) # } pr <- function(model, main=deparse(substitute(model))) { plotres(model, which=3, main=main) # which=3 for just the residuals plot } lm.form.func <- function(keep=FALSE) { local.tr <- trees[1:20,] lm(Volume~., data=local.tr, model=keep) } linmod.form.func <- function(keep=FALSE) { local.tr <- trees[1:20,] model <- linmod(Volume~., data=local.tr, keep=keep) # delete the saved residuals and fitted.values so plotres has to use the saved # call etc. to get the x and y used to build the model, and rely on predict() model$residuals <- NULL model$fitted.values <- NULL model } linmod.xy.func <- function(keep) { xx <- trees[1:20,1:2] yy <- trees[1:20,3] model <- linmod(xx, yy, keep=keep) # delete the saved residuals and fitted.values so plotres has to use the saved # call etc. to get the x and y used to build the model, and rely on predict() model$residuals <- NULL model$fitted.values <- NULL model } par(mfrow=c(3,2)) lm.form <- lm.form.func(keep=FALSE) pr(lm.form) lm.form.keep <- lm.form.func(keep=TRUE) pr(lm.form.keep) linmod.form <- linmod.form.func(keep=FALSE) pr(linmod.form) linmod.form.keep <- linmod.form.func(keep=TRUE) pr(linmod.form.keep) linmod.xy <- linmod.xy.func(keep=FALSE) expect.err(try(pr(linmod.xy)), "cannot get the original model predictors") linmod.xy.keep <- linmod.xy.func(keep=TRUE) pr(linmod.xy.keep) par(org.par) # test xlevels (predict with newdata using a string to represent a factor) data(iris) linmod.Sepal.Length <- linmod(Sepal.Length~Species,data=iris) lm.Sepal.Length <- lm(Sepal.Length~Species,data=iris) predict.linmod <- predict(linmod.Sepal.Length, newdata=data.frame(Species="setosa")) predict.lm <- predict(lm.Sepal.Length, newdata=data.frame(Species="setosa")) stopifnot(all.equal(predict.linmod, predict.lm)) source("test.epilog.R") plotmo/inst/slowtests/test.unusual.vars.bat0000755000176200001440000000173314563571565020754 0ustar liggesusers@rem test.unusual.vars.bat: test unusual variable names and formulas @rem this file was first created for plotmo 3.6.0 (Sep 2020) @echo test.unusual.vars.bat @"C:\PROGRA~1\R\R-4.3.2\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.unusual.vars.R @if %errorlevel% equ 0 goto good1: @echo R returned errorlevel %errorlevel%, see test.unusual.vars.Rout: @echo. @tail test.unusual.vars.Rout @echo test.unusual.vars.R @exit /B 1 :good1 mks.diff test.unusual.vars.Rout test.unusual.vars.Rout.save @if %errorlevel% equ 0 goto good2: @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.unusual.vars.save.ps @exit /B 1 :good2 @rem test.unusual.vars.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.unusual.vars.save.ps @if %errorlevel% equ 0 goto good3: @echo === Files are different === @exit /B 1 :good3 @rm -f test.unusual.vars.Rout @rm -f Rplots.ps @exit /B 0 plotmo/inst/slowtests/test.linmod.Rout.save0000644000176200001440000041752514563614021020700 0ustar liggesusers> # test.linmod.R: test example S3 model at http://www.milbo.org/doc/linmod.R > > source("test.prolog.R") > source("linmod.R") # linear model code (http://www.milbo.org/doc/linmod.R) > source("linmod.methods.R") # additional method functions for linmod > options(warn=1) # print warnings as they occur > > almost.equal <- function(x, y, max=1e-8) + { + stopifnot(max >= 0 && max < .01) + length(x) == length(y) && max(abs(x - y)) < max + } > # check that linmod model matches reference lm model in all essential details > check.lm <- function(fit, ref, newdata=trees[3:5,], + check.coef.names=TRUE, + check.casenames=TRUE, + check.newdata=TRUE, + check.sigma=TRUE) + { + check.names <- function(fit.names, ref.names) + { + if(check.casenames && + # lm always adds rownames even if "1", "2", "3": this seems + # wasteful and not particulary helpful, so linmod doesn't do + # this, hence the first !isTRUE(all.equal) below + !isTRUE(all.equal(ref.names, paste(1:length(ref.names)))) && + !isTRUE(all.equal(fit.names, ref.names))) { + print(fit.names) + print(ref.names) + stop(deparse(substitute(fit.names)), " != ", + deparse(substitute(ref.names))) + } + } + cat0("check ", deparse(substitute(fit)), " vs ", + deparse(substitute(ref)), "\n") + + stopifnot(coef(fit) == coef(ref)) + if(check.coef.names) + stopifnot(identical(names(coef(fit)), names(coef(ref)))) + + stopifnot(identical(dim(fit$coefficients), dim(ref$coefficients))) + stopifnot(length(fit$coefficients) == length(ref$coefficients)) + stopifnot(almost.equal(fit$coefficients, ref$coefficients)) + + stopifnot(identical(dim(fit$residuals), dim(ref$residuals))) + stopifnot(length(fit$residuals) == length(ref$residuals)) + stopifnot(almost.equal(fit$residuals, ref$residuals)) + + stopifnot(identical(dim(fit$fitted.values), dim(ref$fitted.values))) + stopifnot(length(fit$fitted.values) == length(ref$fitted.values)) + stopifnot(almost.equal(fit$fitted.values, ref$fitted.values)) + + stopifnot(identical(fit$rank, ref$rank)) + + if(!is.null(fit$vcov) && !is.null(ref$vcov)) { + stopifnot(identical(dim(fit$vcov), dim(ref$vcov))) + stopifnot(length(fit$vcov) == length(ref$vcov)) + stopifnot(almost.equal(fit$vcov, ref$vcov)) + } + if(check.sigma) { + ref.sigma <- ref$sigma + if(is.null(ref.sigma)) # in lm models, sigma is only available from summary() + ref.sigma <- summary(ref)$sigma + stopifnot(almost.equal(fit$sigma, ref.sigma)) + } + stopifnot(almost.equal(fit$df.residual, ref$df.residual)) + + stopifnot(almost.equal(fitted(fit), fitted(ref))) + check.names(names(fitted(fit)), names(fitted(ref))) + + stopifnot(almost.equal(residuals(fit), residuals(ref))) + check.names(names(residuals(fit)), names(residuals(ref))) + + stopifnot(almost.equal(predict(fit), predict(ref))) + check.names(names(predict(fit)), names(predict(ref))) + if(check.newdata) { + stopifnot(almost.equal(predict(fit, newdata=newdata), + predict(ref, newdata=newdata))) + check.names(names(predict(fit, newdata=newdata)), + names(predict(ref, newdata=newdata))) + } + } > tr <- trees # trees data but with rownames > rownames(tr) <- paste("tree", 1:nrow(trees), sep="") > > linmod.form.Volume.tr <- linmod(Volume~., data=tr) > cat0("==print(summary(linmod.form.Volume.tr))\n") ==print(summary(linmod.form.Volume.tr)) > print(summary(linmod.form.Volume.tr)) Call: linmod.formula(formula = Volume ~ ., data = tr) Estimate StdErr t.value p.value (Intercept) -57.9876589 8.6382259 -6.712913 2.749507e-07 Girth 4.7081605 0.2642646 17.816084 8.223304e-17 Height 0.3392512 0.1301512 2.606594 1.449097e-02 > lm.Volume.tr <- lm(Volume~., data=tr) > check.lm(linmod.form.Volume.tr, lm.Volume.tr) check linmod.form.Volume.tr vs lm.Volume.tr > stopifnot(almost.equal(predict(linmod.form.Volume.tr, newdata=data.frame(Girth=10, Height=80)), + 16.234045, max=1e-5)) > stopifnot(almost.equal(predict(linmod.form.Volume.tr, newdata=as.matrix(tr[1:3,])), + c(4.8376597, 4.5538516, 4.8169813), max=1e-5)) > # character new data (instead of numeric) > newdata.allchar <- as.data.frame(matrix("blank", ncol=3, nrow=3)) > colnames(newdata.allchar) <- colnames(trees) > expect.err(try(predict(lm.Volume.tr, newdata=newdata.allchar)), + "variables 'Girth', 'Height' were specified with different types from the fit") Error : variables 'Girth', 'Height' were specified with different types from the fit Got expected error from try(predict(lm.Volume.tr, newdata = newdata.allchar)) > expect.err(try(predict(linmod.form.Volume.tr, newdata=newdata.allchar)), + "variables 'Girth', 'Height' were specified with different types from the fit") Error : variables 'Girth', 'Height' were specified with different types from the fit Got expected error from try(predict(linmod.form.Volume.tr, newdata = newdata.allchar)) > > linmod.xy.Volume.tr <- linmod(tr[,1:2], tr[,3,drop=FALSE]) # x=data.frame y=data.frame > cat0("==print(summary(linmod.xy.Volume.tr))\n") ==print(summary(linmod.xy.Volume.tr)) > print(summary(linmod.xy.Volume.tr)) Call: linmod.default(x = tr[, 1:2], y = tr[, 3, drop = FALSE]) Estimate StdErr t.value p.value (Intercept) -57.9876589 8.6382259 -6.712913 2.749507e-07 Girth 4.7081605 0.2642646 17.816084 8.223304e-17 Height 0.3392512 0.1301512 2.606594 1.449097e-02 > newdata.2col <- trees[3:5,1:2] > check.lm(linmod.xy.Volume.tr, lm.Volume.tr, newdata=newdata.2col) check linmod.xy.Volume.tr vs lm.Volume.tr > stopifnot(almost.equal(predict(linmod.xy.Volume.tr, newdata=data.frame(Girth=10, Height=80)), + 16.234045, max=1e-5)) > stopifnot(almost.equal(predict(linmod.xy.Volume.tr, newdata=tr[1:3,1:2]), + c(4.8376597, 4.5538516, 4.8169813), max=1e-5)) > > linmod50.xy.Volume.tr <- linmod(as.matrix(tr[,1:2]), as.matrix(tr[,3,drop=FALSE])) # x=matrix y=matrix > check.lm(linmod50.xy.Volume.tr, lm.Volume.tr, newdata=newdata.2col) check linmod50.xy.Volume.tr vs lm.Volume.tr > linmod51.xy.Volume.tr <- linmod(tr[,1:2], tr[,3]) # x=data.frame y=vector > check.lm(linmod51.xy.Volume.tr, lm.Volume.tr, newdata=newdata.2col) check linmod51.xy.Volume.tr vs lm.Volume.tr > linmod52.xy.Volume.tr <- linmod(as.matrix(tr[,1:2]), tr[,3]) # x=matrix y=vector > check.lm(linmod52.xy.Volume.tr, lm.Volume.tr, newdata=newdata.2col) check linmod52.xy.Volume.tr vs lm.Volume.tr > > # newdata can be a vector > stopifnot(almost.equal(predict(linmod.xy.Volume.tr, newdata=c(8.3, 70)), + 4.8376597, max=1e-5)) > stopifnot(almost.equal(predict(linmod.xy.Volume.tr, + newdata=c(8.3, 8.6, 70, 65)), # 4 element vector, byrow=FALSE + c(4.8376597, 4.5538516), max=1e-5)) > options(warn=1) # print warnings as they occur > # expect Warning: data length [3] is not a sub-multiple or multiple of the number of rows [2] > stopifnot(almost.equal(predict(linmod.xy.Volume.tr, newdata=c(8.3, 9, 70)), # 3 element vector + c(4.8376597, -12.7984291), max=1e-5)) Warning in matrix(newdata, ncol = length(object$coefficients) - 1) : data length [3] is not a sub-multiple or multiple of the number of rows [2] > options(warn=2) # treat warnings as errors > > stopifnot(almost.equal(predict(linmod.xy.Volume.tr, newdata=as.matrix(data.frame(Girth=10, Height=80))), + 16.234045, max=1e-5)) > # column names in newdata are ignored for linmod.default models > stopifnot(almost.equal(predict(linmod.xy.Volume.tr, newdata=data.frame(name1.not.in.orig.data=10, name2.not.in.orig.datax2=80)), + 16.234045, max=1e-5)) > # note name reversed below but names still ignored, same predict result as c(Girth=10, Height=80) > stopifnot(almost.equal(predict(linmod.xy.Volume.tr, newdata=data.frame(Height=10, Girth=80)), + 16.234045, max=1e-5)) > > cat0("==print.default(linmod.form.Volume.tr)\n") ==print.default(linmod.form.Volume.tr) > print.default(linmod.form.Volume.tr) $coefficients (Intercept) Girth Height -57.9876589 4.7081605 0.3392512 $residuals tree1 tree2 tree3 tree4 tree5 tree6 5.46234035 5.74614837 5.38301873 0.52588477 -1.06900844 -1.31832696 tree7 tree8 tree9 tree10 tree11 tree12 -0.59268807 -1.04594918 1.18697860 -0.28758128 2.18459773 -0.46846462 tree13 tree14 tree15 tree16 tree17 tree18 -0.06846462 0.79384587 -4.85410969 -5.65220290 2.21603352 -6.40648192 tree19 tree20 tree21 tree22 tree23 tree24 -4.90097760 -3.79703501 0.11181561 -4.30831896 0.91474029 -3.46899800 tree25 tree26 tree27 tree28 tree29 tree30 -2.27770232 4.45713224 3.47624891 4.87148717 -2.39932888 -2.89932888 tree31 8.48469518 $rank [1] 3 $fitted.values tree1 tree2 tree3 tree4 tree5 tree6 tree7 tree8 4.837660 4.553852 4.816981 15.874115 19.869008 21.018327 16.192688 19.245949 tree9 tree10 tree11 tree12 tree13 tree14 tree15 tree16 21.413021 20.187581 22.015402 21.468465 21.468465 20.506154 23.954110 27.852203 tree17 tree18 tree19 tree20 tree21 tree22 tree23 tree24 31.583966 33.806482 30.600978 28.697035 34.388184 36.008319 35.385260 41.768998 tree25 tree26 tree27 tree28 tree29 tree30 tree31 44.877702 50.942868 52.223751 53.428513 53.899329 53.899329 68.515305 $vcov (Intercept) Girth Height (Intercept) 74.6189461 0.43217138 -1.05076889 Girth 0.4321714 0.06983578 -0.01786030 Height -1.0507689 -0.01786030 0.01693933 $sigma [1] 3.881832 $df.residual [1] 28 $call linmod.formula(formula = Volume ~ ., data = tr) $terms Volume ~ Girth + Height attr(,"variables") list(Volume, Girth, Height) attr(,"factors") Girth Height Volume 0 0 Girth 1 0 Height 0 1 attr(,"term.labels") [1] "Girth" "Height" attr(,"order") [1] 1 1 attr(,"intercept") [1] 1 attr(,"response") [1] 1 attr(,".Environment") attr(,"predvars") list(Volume, Girth, Height) attr(,"dataClasses") Volume Girth Height "numeric" "numeric" "numeric" $xlevels named list() attr(,"class") [1] "linmod" > > cat0("==check single x variable\n") ==check single x variable > linmod1a.form <- linmod(Volume~Height, data=tr) > cat0("==print(summary(linmod1a.form))\n") ==print(summary(linmod1a.form)) > print(summary(linmod1a.form)) Call: linmod.formula(formula = Volume ~ Height, data = tr) Estimate StdErr t.value p.value (Intercept) -87.12361 29.2731221 -2.976232 0.0058346689 Height 1.54335 0.3838693 4.020509 0.0003783823 > lma.tr <- lm(Volume~Height, data=tr) > check.lm(linmod1a.form, lma.tr) check linmod1a.form vs lma.tr > > stopifnot(almost.equal(predict(linmod1a.form, newdata=data.frame(Height=80)), + 36.34437, max=1e-5)) > stopifnot(almost.equal(predict(linmod1a.form, newdata=data.frame(Girth=99, Height=80)), + 36.34437, max=1e-5)) > stopifnot(almost.equal(predict(linmod1a.form, newdata=as.matrix(tr[1:3,])), + c(20.91087, 13.19412, 10.10742), max=1e-5)) > > linmod1a.xy <- linmod(tr[,2,drop=FALSE], tr[,3]) > cat0("==print(summary(linmod1a.xy))\n") ==print(summary(linmod1a.xy)) > print(summary(linmod1a.xy)) Call: linmod.default(x = tr[, 2, drop = FALSE], y = tr[, 3]) Estimate StdErr t.value p.value (Intercept) -87.12361 29.2731221 -2.976232 0.0058346689 Height 1.54335 0.3838693 4.020509 0.0003783823 > check.lm(linmod1a.xy, lma.tr, newdata=trees[3:5,2,drop=FALSE]) check linmod1a.xy vs lma.tr > check.lm(linmod1a.xy, lma.tr, newdata=trees[3:5,2,drop=TRUE], + check.newdata=FALSE) # needed because predict.lm gives 'data' must be a data.frame, environment, or list check linmod1a.xy vs lma.tr > stopifnot(almost.equal(predict(linmod1a.xy, newdata=trees[3:5,2,drop=FALSE]), + predict(linmod1a.xy, newdata=trees[3:5,2,drop=TRUE]))) > stopifnot(almost.equal(predict(linmod1a.xy, newdata=data.frame(Height=80)), + 36.34437, max=1e-5)) > stopifnot(almost.equal(predict(linmod1a.xy, newdata=tr[1:3,2]), + c(20.91087, 13.19412, 10.10742), max=1e-5)) > stopifnot(almost.equal(predict(linmod1a.xy, newdata=as.matrix(data.frame(Height=80))), + 36.34437, max=1e-5)) > > # check that extra fields in predict newdata are ok with formula models > stopifnot(almost.equal(predict(linmod.form.Volume.tr, newdata=data.frame(Girth=10, Height=80, extra=99)), + predict(lm.Volume.tr, newdata=data.frame(Girth=10, Height=80)))) > stopifnot(almost.equal(predict(linmod.form.Volume.tr, newdata=data.frame(Girth=10, Height=80, extra=99)), + predict(lm.Volume.tr, newdata=data.frame(Girth=10, Height=80, extra=99)))) > # check that extra fields in predict newdata are not ok with x,y models > expect.err(try(predict(linmod.xy.Volume.tr, newdata=data.frame(Girth=10, Height=80, extra=99))), + "ncol(newdata) is 3 but should be 2") Error in predict.linmod(linmod.xy.Volume.tr, newdata = data.frame(Girth = 10, : ncol(newdata) is 3 but should be 2 Got expected error from try(predict(linmod.xy.Volume.tr, newdata = data.frame(Girth = 10, Height = 80, extra = 99))) > > # missing variables in newdata > expect.err(try(predict(linmod.form.Volume.tr, newdata=data.frame(Girth=10))), + "object 'Height' not found") Error in eval(predvars, data, env) : object 'Height' not found Got expected error from try(predict(linmod.form.Volume.tr, newdata = data.frame(Girth = 10))) > expect.err(try(predict(linmod.form.Volume.tr, newdata=c(8.3, 70))), + "object 'Girth' not found") Error in eval(predvars, data, env) : object 'Girth' not found Got expected error from try(predict(linmod.form.Volume.tr, newdata = c(8.3, 70))) > expect.err(try(predict(lm.Volume.tr, newdata=data.frame(Girth=10))), + "object 'Height' not found") Error in eval(predvars, data, env) : object 'Height' not found Got expected error from try(predict(lm.Volume.tr, newdata = data.frame(Girth = 10))) > expect.err(try(predict(linmod.xy.Volume.tr, newdata=data.frame(Girth=10))), + "ncol(newdata) is 1 but should be 2") Error in predict.linmod(linmod.xy.Volume.tr, newdata = data.frame(Girth = 10)) : ncol(newdata) is 1 but should be 2 Got expected error from try(predict(linmod.xy.Volume.tr, newdata = data.frame(Girth = 10))) > > # check that rownames got propagated > stopifnot(names(linmod.form.Volume.tr$residuals)[1] == "tree1") > stopifnot(names(linmod.form.Volume.tr$fitted.values)[3] == "tree3") > stopifnot(names(linmod.xy.Volume.tr$residuals)[1] == "tree1") > stopifnot(names(linmod.xy.Volume.tr$fitted.values)[3] == "tree3") > stopifnot(!is.null(names(linmod.xy.Volume.tr$residuals))) > stopifnot(!is.null(names(linmod.xy.Volume.tr$fitted.values))) > cat0("==print.default(linmod.xy.Volume.tr)\n") ==print.default(linmod.xy.Volume.tr) > print.default(linmod.xy.Volume.tr) $coefficients (Intercept) Girth Height -57.9876589 4.7081605 0.3392512 $residuals tree1 tree2 tree3 tree4 tree5 tree6 5.46234035 5.74614837 5.38301873 0.52588477 -1.06900844 -1.31832696 tree7 tree8 tree9 tree10 tree11 tree12 -0.59268807 -1.04594918 1.18697860 -0.28758128 2.18459773 -0.46846462 tree13 tree14 tree15 tree16 tree17 tree18 -0.06846462 0.79384587 -4.85410969 -5.65220290 2.21603352 -6.40648192 tree19 tree20 tree21 tree22 tree23 tree24 -4.90097760 -3.79703501 0.11181561 -4.30831896 0.91474029 -3.46899800 tree25 tree26 tree27 tree28 tree29 tree30 -2.27770232 4.45713224 3.47624891 4.87148717 -2.39932888 -2.89932888 tree31 8.48469518 $rank [1] 3 $fitted.values tree1 tree2 tree3 tree4 tree5 tree6 tree7 tree8 4.837660 4.553852 4.816981 15.874115 19.869008 21.018327 16.192688 19.245949 tree9 tree10 tree11 tree12 tree13 tree14 tree15 tree16 21.413021 20.187581 22.015402 21.468465 21.468465 20.506154 23.954110 27.852203 tree17 tree18 tree19 tree20 tree21 tree22 tree23 tree24 31.583966 33.806482 30.600978 28.697035 34.388184 36.008319 35.385260 41.768998 tree25 tree26 tree27 tree28 tree29 tree30 tree31 44.877702 50.942868 52.223751 53.428513 53.899329 53.899329 68.515305 $vcov (Intercept) Girth Height (Intercept) 74.6189461 0.43217138 -1.05076889 Girth 0.4321714 0.06983578 -0.01786030 Height -1.0507689 -0.01786030 0.01693933 $sigma [1] 3.881832 $df.residual [1] 28 $call linmod.default(x = tr[, 1:2], y = tr[, 3, drop = FALSE]) attr(,"class") [1] "linmod" > > # check that we don't artificially add rownames when no original rownames > linmod1a.xy <- linmod(trees[,1:2], trees[,3]) > stopifnot(is.null(names(linmod1a.xy$residuals))) > stopifnot(is.null(names(linmod1a.xy$fitted.values))) > > cat0("==example plots\n") ==example plots > > library(plotmo) Loading required package: Formula Loading required package: plotrix > data(trees) > > linmod.form.Volume.trees <- linmod(Volume~., data=trees) > print(linmod.form.Volume.trees) Call: linmod.formula(formula = Volume ~ ., data = trees) (Intercept) Girth Height -57.9876589 4.7081605 0.3392512 > print(summary(linmod.form.Volume.trees)) Call: linmod.formula(formula = Volume ~ ., data = trees) Estimate StdErr t.value p.value (Intercept) -57.9876589 8.6382259 -6.712913 2.749507e-07 Girth 4.7081605 0.2642646 17.816084 8.223304e-17 Height 0.3392512 0.1301512 2.606594 1.449097e-02 > > linmod1.xy <- linmod(trees[,1:2], trees[,3]) > print(linmod1.xy) Call: linmod.default(x = trees[, 1:2], y = trees[, 3]) (Intercept) Girth Height -57.9876589 4.7081605 0.3392512 > print(summary(linmod1.xy)) Call: linmod.default(x = trees[, 1:2], y = trees[, 3]) Estimate StdErr t.value p.value (Intercept) -57.9876589 8.6382259 -6.712913 2.749507e-07 Girth 4.7081605 0.2642646 17.816084 8.223304e-17 Height 0.3392512 0.1301512 2.606594 1.449097e-02 > > plotmo(linmod.form.Volume.trees) plotmo grid: Girth Height 12.9 76 > plotmo(linmod1.xy) plotmo grid: Girth Height 12.9 76 > > plotres(linmod.form.Volume.trees) > plotres(linmod1.xy) > > cat0("==test keep arg\n") ==test keep arg > > trees1 <- trees > linmod.form.Volume.trees.keep <- linmod(Volume~., data=trees1, keep=TRUE) > print(summary(linmod.form.Volume.trees.keep)) Call: linmod.formula(formula = Volume ~ ., data = trees1, keep = TRUE) Estimate StdErr t.value p.value (Intercept) -57.9876589 8.6382259 -6.712913 2.749507e-07 Girth 4.7081605 0.2642646 17.816084 8.223304e-17 Height 0.3392512 0.1301512 2.606594 1.449097e-02 > print(head(linmod.form.Volume.trees.keep$data)) Girth Height Volume 1 8.3 70 10.3 2 8.6 65 10.3 3 8.8 63 10.2 4 10.5 72 16.4 5 10.7 81 18.8 6 10.8 83 19.7 > stopifnot(dim(linmod.form.Volume.trees.keep$data) == c(nrow(trees1), ncol(trees1))) > trees1 <- NULL # destroy orginal data so plotmo has to use keep data > plotmo(linmod.form.Volume.trees.keep, pt.col=3) plotmo grid: Girth Height 12.9 76 > plotres(linmod.form.Volume.trees.keep) > > linmod.xy.keep <- linmod(trees[,1:2], trees[,3], keep=TRUE) > print(summary(linmod.xy.keep)) Call: linmod.default(x = trees[, 1:2], y = trees[, 3], keep = TRUE) Estimate StdErr t.value p.value (Intercept) -57.9876589 8.6382259 -6.712913 2.749507e-07 Girth 4.7081605 0.2642646 17.816084 8.223304e-17 Height 0.3392512 0.1301512 2.606594 1.449097e-02 > print(head(linmod.xy.keep$x)) Girth Height [1,] 8.3 70 [2,] 8.6 65 [3,] 8.8 63 [4,] 10.5 72 [5,] 10.7 81 [6,] 10.8 83 > stopifnot(dim(linmod.xy.keep$x) == c(nrow(trees), 2)) > stopifnot(class(linmod.xy.keep$x)[1] == "matrix") > print(head(linmod.xy.keep$y)) trees[,3] [1,] 10.3 [2,] 10.3 [3,] 10.2 [4,] 16.4 [5,] 18.8 [6,] 19.7 > stopifnot(dim(linmod.xy.keep$y) == c(nrow(trees), 1)) > stopifnot(class(linmod.xy.keep$y)[1] == "matrix") > linmod.xy.keep$call <- NULL # trick to force use of x and y in plotmo > plotmo(linmod.xy.keep, pt.col=3) plotmo grid: Girth Height 12.9 76 > plotres(linmod.xy.keep) > > check.lm(linmod.form.Volume.trees.keep, linmod.xy.keep, check.casenames=FALSE, check.newdata=FALSE) check linmod.form.Volume.trees.keep vs linmod.xy.keep > > cat0("==test keep arg with vector x\n") ==test keep arg with vector x > > n <- 20 > linmod.vecx.form.keep <- linmod(Volume~Height, data=trees[1:n,], keep=TRUE) > print(summary(linmod.vecx.form.keep)) Call: linmod.formula(formula = Volume ~ Height, data = trees[1:n, ], keep = TRUE) Estimate StdErr t.value p.value (Intercept) -19.3368332 11.9072601 -1.623953 0.121767815 Height 0.5318092 0.1597269 3.329491 0.003730259 > print(head(linmod.vecx.form.keep$data)) Girth Height Volume 1 8.3 70 10.3 2 8.6 65 10.3 3 8.8 63 10.2 4 10.5 72 16.4 5 10.7 81 18.8 6 10.8 83 19.7 > stopifnot(dim(linmod.vecx.form.keep$data) == c(n, ncol(trees))) > stopifnot(class(linmod.vecx.form.keep$data) == class(trees)) > plotmo(linmod.vecx.form.keep, pt.col=3) > plotres(linmod.vecx.form.keep) > > linmod.vecx.xy.keep <- linmod(trees[1:n,2], trees[1:n,3], keep=TRUE) > print(summary(linmod.vecx.xy.keep)) Call: linmod.default(x = trees[1:n, 2], y = trees[1:n, 3], keep = TRUE) Estimate StdErr t.value p.value (Intercept) -19.3368332 11.9072601 -1.623953 0.121767815 V1 0.5318092 0.1597269 3.329491 0.003730259 > print(head(linmod.vecx.xy.keep$x)) [,1] [1,] 70 [2,] 65 [3,] 63 [4,] 72 [5,] 81 [6,] 83 > stopifnot(dim(linmod.vecx.xy.keep$x) == c(n, 1)) > stopifnot(class(linmod.vecx.xy.keep$x)[1] == "matrix") > print(head(linmod.vecx.xy.keep$y)) trees[1:n,3] [1,] 10.3 [2,] 10.3 [3,] 10.2 [4,] 16.4 [5,] 18.8 [6,] 19.7 > stopifnot(dim(linmod.vecx.xy.keep$y) == c(n, 1)) > stopifnot(class(linmod.vecx.xy.keep$y)[1] == "matrix") > linmod.vecx.xy.keep$call <- NULL # trick to force use of x and y in plotmo > plotmo(linmod.vecx.xy.keep, pt.col=3) > plotres(linmod.vecx.xy.keep) > > check.lm(linmod.vecx.form.keep, linmod.vecx.xy.keep, newdata=trees[3:5,2,drop=FALSE], + check.coef.names=FALSE, check.casenames=FALSE) check linmod.vecx.form.keep vs linmod.vecx.xy.keep > > cat0("==test model building with assorted numeric args\n") ==test model building with assorted numeric args > > x <- tr[,1:2] > y <- tr[,3] > cat0("class(x)=", class(x), " class(y)=", class(y), "\n") # class(x)=data.frame class(y)=numeric class(x)=data.frame class(y)=numeric > linmod2.xy <- linmod(x, y) > check.lm(linmod2.xy, lm.Volume.tr, newdata=newdata.2col) check linmod2.xy vs lm.Volume.tr > > # check consistency with lm > expect.err(try(linmod(y~x)), "invalid type (list) for variable 'x'") Error in model.frame.default(formula = formula, data = data, na.action = na.pass) : invalid type (list) for variable 'x' Got expected error from try(linmod(y ~ x)) > expect.err(try(lm(y~x)), "invalid type (list) for variable 'x'") Error in model.frame.default(formula = y ~ x, drop.unused.levels = TRUE) : invalid type (list) for variable 'x' Got expected error from try(lm(y ~ x)) > > linmod3.xy <- linmod(as.matrix(x), as.matrix(y)) > check.lm(linmod3.xy, lm.Volume.tr, newdata=newdata.2col) check linmod3.xy vs lm.Volume.tr > > linmod4.form <- linmod(y ~ as.matrix(x)) > lm4 <- lm(y ~ as.matrix(x)) > check.lm(linmod4.form, lm4, check.newdata=FALSE) check linmod4.form vs lm4 > stopifnot(coef(linmod4.form) == coef(lm.Volume.tr), + gsub("as.matrix(x)", "", names(coef(linmod4.form)), fixed=TRUE) == names(coef(lm.Volume.tr))) > > xm <- as.matrix(x) > cat0("class(xm)=", class(xm), " class(y)=", class(y), "\n") # class(xm)=matrix class(y)=numeric class(xm)=matrixarray class(y)=numeric > linmod5.form <- linmod(y ~ xm) > lm5 <- lm(y ~ xm) > check.lm(linmod5.form, lm5, check.newdata=FALSE) check linmod5.form vs lm5 > stopifnot(coef(linmod5.form) == coef(lm.Volume.tr), + gsub("xm", "", names(coef(linmod5.form)), fixed=TRUE) == names(coef(lm.Volume.tr))) > > cat0("==test correct use of global x1 and y1, and of predict error handling\n") ==test correct use of global x1 and y1, and of predict error handling > x1 <- tr[,1] > y1 <- tr[,3] > cat0("class(x1)=", class(x1), " class(y1)=", class(y1), "\n") # class(x1)=numeric class(y1)=numeric class(x1)=numeric class(y1)=numeric > linmod.y1.x1 <- linmod(y1~x1) > lm1 <- lm(y1~x1) > linmod6.xy <- linmod(x1, y1) > > newdata.x1 <- trees[3:5,1,drop=FALSE] > colnames(newdata.x1) <- "x1" > stopifnot(almost.equal(predict(linmod.y1.x1, newdata=newdata.x1), + c(7.63607739644657, 16.24803331528098, 17.26120459984973))) > > check.lm(linmod6.xy, linmod.y1.x1, newdata=x1[3:5], + check.newdata=FALSE, # TODO needed because linmod.y1.x1 ignores newdata(!) + check.coef.names=FALSE, check.casenames=FALSE) check linmod6.xy vs linmod.y1.x1 > print(predict(linmod6.xy, newdata=x1[3:5])) [1] 7.636077 16.248033 17.261205 > stopifnot(almost.equal(predict(linmod6.xy, newdata=x1[3]), 7.63607739644657)) > > stopifnot(coef(linmod6.xy) == coef(linmod.y1.x1)) # names(coef(linmod.y1.x1) are "(Intercept)" "x1" > stopifnot(names(coef(linmod6.xy)) == c("(Intercept)", "V1")) > > # following checks some confusing behaviour of predict.lm > options(warn=2) # treat warnings as errors > expect.err(try(predict(lm1, newdata=trees[3:5,1,drop=FALSE])), + "'newdata' had 3 rows but variables found have 31 rows") Error : (converted from warning) 'newdata' had 3 rows but variables found have 31 rows Got expected error from try(predict(lm1, newdata = trees[3:5, 1, drop = FALSE])) > expect.err(try(predict(lm1, newdata=trees[3:5,1,drop=TRUE])), + "'data' must be a data.frame, environment, or list") Error in model.frame.default(Terms, newdata, na.action = na.action, xlev = object$xlevels) : 'data' must be a data.frame, environment, or list Got expected error from try(predict(lm1, newdata = trees[3:5, 1, drop = TRUE])) > > # following checks messages when missing variables in newdata > > options(warn=2) # treat warnings as errors to check that we get a warning in stats::model.frame > expect.err(try(predict(linmod.y1.x1, newdata=trees[3:5,1,drop=FALSE])), + "(converted from warning) 'newdata' had 3 rows but variables found have 31 rows") Error : (converted from warning) 'newdata' had 3 rows but variables found have 31 rows Got expected error from try(predict(linmod.y1.x1, newdata = trees[3:5, 1, drop = FALSE])) > expect.err(try(predict(lm1, newdata=trees[3:5,1,drop=FALSE])), + "(converted from warning) 'newdata' had 3 rows but variables found have 31 rows") Error : (converted from warning) 'newdata' had 3 rows but variables found have 31 rows Got expected error from try(predict(lm1, newdata = trees[3:5, 1, drop = FALSE])) > expect.err(try(predict(linmod.y1.x1, newdata=trees[3:5,1,drop=TRUE])), + "(converted from warning) 'newdata' had 3 rows but variables found have 31 rows") Error : (converted from warning) 'newdata' had 3 rows but variables found have 31 rows Got expected error from try(predict(linmod.y1.x1, newdata = trees[3:5, 1, drop = TRUE])) > > # following checks predict.linmod error messages when missing variables > # (it tries to give better error messages than predict.lm) > > options(warn=1) # print warnings as they occur to test stop() in linmod.R::process.newdata.formula > expect.err(try(predict(linmod.y1.x1, newdata=trees[3:5,1,drop=FALSE])), + "newdata has 3 rows but model.frame returned 31 rows (variable 'x1' may be missing from newdata)") Warning: 'newdata' had 3 rows but variables found have 31 rows Error in process.newdata.formula(object, newdata) : newdata has 3 rows but model.frame returned 31 rows (variable 'x1' may be missing from newdata) Got expected error from try(predict(linmod.y1.x1, newdata = trees[3:5, 1, drop = FALSE])) > expect.err(try(predict(linmod.y1.x1, newdata=trees[3:5,1,drop=TRUE])), + "newdata has 3 rows but model.frame returned 31 rows (variable 'x1' may be missing from newdata)") Warning: 'newdata' had 3 rows but variables found have 31 rows Error in process.newdata.formula(object, newdata) : newdata has 3 rows but model.frame returned 31 rows (variable 'x1' may be missing from newdata) Got expected error from try(predict(linmod.y1.x1, newdata = trees[3:5, 1, drop = TRUE])) > options(warn=2) # back to treating warnings as errors > > # test old version of linmod.R (pre Sep 2020) > # > # expect.err(try(predict(linmod.y1.x1, newdata=trees[3:5,1,drop=FALSE])), > # "variable 'x1' is missing from newdata") > # expect.err(try(predict(lm1, newdata=trees[3:5,1,drop=FALSE])), > # "(converted from warning) 'newdata' had 3 rows but variables found have 31 rows") > # expect.err(try(predict(linmod.y1.x1, newdata=trees[3:5,1,drop=TRUE])), > # "variable 'x1' is missing from newdata") > > linmod6.form <- linmod(y1~x1) > check.lm(linmod6.form, linmod.y1.x1, check.newdata=FALSE) check linmod6.form vs linmod.y1.x1 > > newdata <- trees[5:6,] > colnames(newdata) <- c("Girth", "Height", "Volume999") # doesn't matter what we call the response > stopifnot(identical(predict(linmod.form.Volume.tr, newdata=newdata), + predict(linmod.form.Volume.tr, newdata=trees[5:6,]))) > newdata <- trees[5:6,3:1] # reverse columns and their colnames > colnames(newdata) <- c("Volume", "Height", "Girth") > stopifnot(identical(predict(linmod.form.Volume.tr, newdata=newdata), + predict(linmod.form.Volume.tr, newdata=trees[5:6,]))) > newdata <- trees[5:6,2:1] # reverse columns and their colnames, delete response column > colnames(newdata) <- c("Height", "Girth") > stopifnot(identical(predict(linmod.form.Volume.tr, newdata=newdata), + predict(linmod.form.Volume.tr, newdata=trees[5:6,]))) > stopifnot(identical(predict(linmod.form.Volume.tr, newdata=as.matrix(trees[5:6,])), # allow matrix newdata + predict(linmod.form.Volume.tr, newdata=trees[5:6,]))) > newdata <- trees[5:6,] > colnames(newdata) <- c("Girth99", "Height", "Volume") > expect.err(try(predict(linmod.form.Volume.tr, newdata=newdata)), + "object 'Girth' not found") Error in eval(predvars, data, env) : object 'Girth' not found Got expected error from try(predict(linmod.form.Volume.tr, newdata = newdata)) > colnames(newdata) <- c("Girth", "Height99", "Volume") > expect.err(try(predict(linmod.form.Volume.tr, newdata=newdata)), + "object 'Height' not found") Error in eval(predvars, data, env) : object 'Height' not found Got expected error from try(predict(linmod.form.Volume.tr, newdata = newdata)) > > cat0("==check integer input (sibsp is an integer)\n") ==check integer input (sibsp is an integer) > > library(earth) # for etitanic data > data(etitanic) > tit <- etitanic[seq(1, nrow(etitanic), by=60), ] # small set of data for tests (18 cases) > tit$survived <- tit$survived != 0 # convert to logical > rownames(tit) <- paste("pas", 1:nrow(tit), sep="") > cat0(paste(colnames(tit), "=", sapply(tit, class), sep="", collapse=", "), "\n") pclass=factor, survived=logical, sex=factor, age=numeric, sibsp=integer, parch=integer > > linmod7.xy <- linmod(tit$age, tit$sibsp) > lm7 <- lm.fit(cbind(1, tit$age), tit$sibsp) > stopifnot(coef(linmod7.xy) == coef(lm7)) # coef names will differ > > linmod7.form <- linmod(sibsp~age, data=tit) > lm7.form <- lm(sibsp~age, data=tit) > check.lm(linmod7.form, lm7.form, newdata=tit[3:5,]) check linmod7.form vs lm7.form > > linmod8.xy <- linmod(tit$sibsp, tit$age) > lm8 <- lm.fit(cbind(1, tit$sibsp), tit$age) > stopifnot(coef(linmod8.xy) == coef(lm8)) # coef names will differ > > linmod8.form <- linmod(age~sibsp, data=tit) > lm8.form <- lm(age~sibsp, data=tit) > check.lm(linmod8.form, lm8.form, newdata=tit[3:5,]) check linmod8.form vs lm8.form > > # drop=FALSE so response is a data frame > linmod1a.xy <- linmod(trees[,1:2], trees[, 3, drop=FALSE]) > print(linmod1a.xy) Call: linmod.default(x = trees[, 1:2], y = trees[, 3, drop = FALSE]) (Intercept) Girth Height -57.9876589 4.7081605 0.3392512 > print(summary(linmod1a.xy)) Call: linmod.default(x = trees[, 1:2], y = trees[, 3, drop = FALSE]) Estimate StdErr t.value p.value (Intercept) -57.9876589 8.6382259 -6.712913 2.749507e-07 Girth 4.7081605 0.2642646 17.816084 8.223304e-17 Height 0.3392512 0.1301512 2.606594 1.449097e-02 > plotres(linmod1a.xy) # plot caption shows response name "Volume" > > cat0("==test model building with assorted non-numeric args\n") ==test model building with assorted non-numeric args > > library(earth) # for etitanic data > data(etitanic) > etit <- etitanic[seq(1, nrow(etitanic), by=60), ] # small set of data for tests (18 cases) > etit$survived <- etit$survived != 0 # convert to logical > rownames(etit) <- paste("pas", 1:nrow(etit), sep="") > cat0(paste(colnames(etit), "=", sapply(etit, class), sep="", collapse=", "), "\n") pclass=factor, survived=logical, sex=factor, age=numeric, sibsp=integer, parch=integer > > lm9 <- lm(survived~., data=etit) > linmod9.form <- linmod(survived~., data=etit) > check.lm(linmod9.form, lm9, newdata=etit[3:5,]) check linmod9.form vs lm9 > > # change class of pclass to numeric > etit.pclass.numeric <- etit > etit.pclass.numeric$pclass <- as.numeric(etit$pclass) > expect.err(try(predict(lm9, newdata=etit.pclass.numeric)), + "(converted from warning) variable 'pclass' is not a factor") Error in model.frame.default(Terms, newdata, na.action = na.action, xlev = object$xlevels) : (converted from warning) variable 'pclass' is not a factor Got expected error from try(predict(lm9, newdata = etit.pclass.numeric)) > expect.err(try(predict(linmod9.form, newdata=etit.pclass.numeric)), + "(converted from warning) variable 'pclass' is not a factor") Error in model.frame.default(terms, newdata, na.action = na.pass, xlev = object$xlevels) : (converted from warning) variable 'pclass' is not a factor Got expected error from try(predict(linmod9.form, newdata = etit.pclass.numeric)) > > # change class of age to factor > etit.age.factor <- etit > etit.age.factor$age <- etit$pclass > expect.err(try(predict(lm9, newdata=etit.age.factor)), + "variable 'age' was fitted with type \"numeric\" but type \"factor\" was supplied") Error : variable 'age' was fitted with type "numeric" but type "factor" was supplied Got expected error from try(predict(lm9, newdata = etit.age.factor)) > expect.err(try(predict(linmod9.form, newdata=etit.age.factor)), + "variable 'age' was fitted with type \"numeric\" but type \"factor\" was supplied") Error : variable 'age' was fitted with type "numeric" but type "factor" was supplied Got expected error from try(predict(linmod9.form, newdata = etit.age.factor)) > > # predict for formula model ignores extra column(s) in newdata > etit.extra.col <- etit > etit.extra.col$extra <- etit$sibsp > stopifnot(identical(predict(lm9, newdata=etit), predict(lm9, newdata=etit.extra.col))) > stopifnot(identical(predict(linmod9.form, newdata=etit), predict(linmod9.form, newdata=etit.extra.col))) > etit.extra.col$extra2 <- etit$sibsp > stopifnot(identical(predict(lm9, newdata=etit), predict(lm9, newdata=etit.extra.col))) > stopifnot(identical(predict(linmod9.form, newdata=etit), predict(linmod9.form, newdata=etit.extra.col))) > > # predict for formula model doesn't care if columns in different order > etit.different.col.order <- etit[,ncol(etit):1] # reverse order of columns > stopifnot(identical(predict(lm9, newdata=etit), predict(lm9, newdata=etit.different.col.order))) > stopifnot(identical(predict(linmod9.form, newdata=etit), predict(linmod9.form, newdata=etit.different.col.order))) > > # linmod.default, non numeric x (factors in x) > expect.err(try(linmod(etit[c(1,3,4,5,6)], etit[,"survived"])), + "non-numeric column in 'x'") Error in check.linmod.x(x) : non-numeric column in 'x' Got expected error from try(linmod(etit[c(1, 3, 4, 5, 6)], etit[, "survived"])) > expect.err(try(linmod.fit(etit[c(1,3,4,5,6)], etit[,"survived"])), + "'x' is not a matrix or could not be converted to a matrix") Error in check.linmod.x(x) : 'x' is not a matrix or could not be converted to a matrix Got expected error from try(linmod.fit(etit[c(1, 3, 4, 5, 6)], etit[, "survived"])) > # lousy error message from lm.fit > expect.err(try(lm.fit(etit[,c(1,3,4,5,6)], etit[,"survived"])), + "INTEGER() can only be applied to a 'integer', not a 'NULL'") Error in lm.fit(etit[, c(1, 3, 4, 5, 6)], etit[, "survived"]) : INTEGER() can only be applied to a 'integer', not a 'NULL' Got expected error from try(lm.fit(etit[, c(1, 3, 4, 5, 6)], etit[, "survived"])) > > expect.err(try(linmod(data.matrix(cbind("(Intercept)"=1, etit[,c(1,3,4,5,6)])), etit[,"survived"])), + "column name \"(Intercept)\" in 'x' is duplicated") Error in check.linmod.x(x) : column name "(Intercept)" in 'x' is duplicated Got expected error from try(linmod(data.matrix(cbind(`(Intercept)` = 1, etit[, c(1, 3, 4, 5, 6)])), etit[, "survived"])) > linmod9a.xy <- linmod(data.matrix(etit[,c(1,3,4,5,6)]), etit[,"survived"]) > lm9.fit <- lm.fit(data.matrix(cbind("(Intercept)"=1, etit[,c(1,3,4,5,6)])), etit[,"survived"]) > stopifnot(coef(linmod9a.xy) == coef(lm9.fit)) > stopifnot(names(coef(linmod9a.xy)) == names(coef(lm9.fit))) > expect.err(try(predict(linmod9a.xy, newdata=etit.age.factor[,c(1,3,4,5,6)])), "non-numeric column in 'newdata'") Error in predict.linmod(linmod9a.xy, newdata = etit.age.factor[, c(1, : non-numeric column in 'newdata' (after processing) Got expected error from try(predict(linmod9a.xy, newdata = etit.age.factor[, c(1, 3, 4, 5, 6)])) > expect.err(try(predict(linmod9a.xy, newdata=etit[,c(1,3,4,5)])), "ncol(newdata) is 4 but should be 5") Error in predict.linmod(linmod9a.xy, newdata = etit[, c(1, 3, 4, 5)]) : ncol(newdata) is 4 but should be 5 Got expected error from try(predict(linmod9a.xy, newdata = etit[, c(1, 3, 4, 5)])) > expect.err(try(predict(linmod9a.xy, newdata=etit[,c(1,3,4,5,6,6)])), "ncol(newdata) is 6 but should be 5") Error in predict.linmod(linmod9a.xy, newdata = etit[, c(1, 3, 4, 5, 6, : ncol(newdata) is 6 but should be 5 Got expected error from try(predict(linmod9a.xy, newdata = etit[, c(1, 3, 4, 5, 6, 6)])) > > # linmod.formula, logical response > data.logical.response <- data.frame(etit[1:6,c("age","sibsp","parch")], response=c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE)) > linmod9b.form <- linmod(response~., data=data.logical.response) > print(linmod9b.form) Call: linmod.formula(formula = response ~ ., data = data.logical.response) (Intercept) age sibsp parch 1.102508872 -0.007261985 -0.182883049 -0.569470942 > lm9b.form <- lm(response~., data=data.logical.response) > check.lm(linmod9b.form, lm9b.form, newdata=data.logical.response[2,,drop=FALSE]) check linmod9b.form vs lm9b.form > > # linmod.formula, factor response (not allowed) > data.fac.response <- data.frame(etit[1:6,c("age","sibsp","parch")], response=factor(c("a", "a", "b", "a", "b", "b"))) > expect.err(try(linmod(response~., data=data.fac.response)), "'y' is not numeric or logical") Error in check.linmod.y(x, y) : 'y' is not numeric or logical Got expected error from try(linmod(response ~ ., data = data.fac.response)) > # lm.formula > expect.err(try(lm(response~., data=data.fac.response)), + "(converted from warning) using type = \"numeric\" with a factor response will be ignored") Error in model.response(mf, "numeric") : (converted from warning) using type = "numeric" with a factor response will be ignored Got expected error from try(lm(response ~ ., data = data.fac.response)) > > # linmod.formula, string response (not allowed) > data.string.response <- data.frame(etit[1:6,c("age","sibsp","parch")], response=c("a", "a", "b", "a", "b", "b")) > expect.err(try(linmod(response~., data=data.string.response)), "'y' is not numeric or logical") Error in check.linmod.y(x, y) : 'y' is not numeric or logical Got expected error from try(linmod(response ~ ., data = data.string.response)) > # lm.formula > expect.err(try(lm(response~., data=data.string.response)), + "(converted from warning) NAs introduced by coercion") Error in storage.mode(v) <- "double" : (converted from warning) NAs introduced by coercion Got expected error from try(lm(response ~ ., data = data.string.response)) > > # linmod.default, logical response > linmod9b.xy <- linmod(etit[1:6,c("age","sibsp","parch")], c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE)) > print(linmod9b.xy) Call: linmod.default(x = etit[1:6, c("age", "sibsp", "parch")], y = c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE)) (Intercept) age sibsp parch 1.102508872 -0.007261985 -0.182883049 -0.569470942 > # lm.fit, logical response (lousy error message from lm.fit) > expect.err(try(lm.fit(etit[1:6,c("age","sibsp","parch")], c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE))), + "INTEGER() can only be applied to a 'integer', not a 'NULL'") Error in lm.fit(etit[1:6, c("age", "sibsp", "parch")], c(TRUE, TRUE, FALSE, : INTEGER() can only be applied to a 'integer', not a 'NULL' Got expected error from try(lm.fit(etit[1:6, c("age", "sibsp", "parch")], c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE))) > # linmod.default, factor response > expect.err(try(linmod(etit[1:6,c("age","sibsp","parch")], factor(c("a", + "a", "b", "a", "b", "b")))), "'y' is not numeric or logical") Error in check.linmod.y(x, y) : 'y' is not numeric or logical Got expected error from try(linmod(etit[1:6, c("age", "sibsp", "parch")], factor(c("a", "a", "b", "a", "b", "b")))) > # linmod.default, string response > expect.err(try(linmod(etit[1:6,c("age","sibsp","parch")], c("a", + "a", "b", "a", "b", "b"))), "'y' is not numeric or logical") Error in check.linmod.y(x, y) : 'y' is not numeric or logical Got expected error from try(linmod(etit[1:6, c("age", "sibsp", "parch")], c("a", "a", "b", "a", "b", "b"))) > # lm.fit, string and factor responses (lousy error messages from lm.fit) > expect.err(try(lm.fit(etit[1:6,c("age","sibsp","parch")], factor(c("a", + "a", "b", "a", "b", "b")))), "INTEGER() can only be applied to a 'integer', not a 'NULL'") Error in lm.fit(etit[1:6, c("age", "sibsp", "parch")], factor(c("a", "a", : INTEGER() can only be applied to a 'integer', not a 'NULL' Got expected error from try(lm.fit(etit[1:6, c("age", "sibsp", "parch")], factor(c("a", "a", "b", "a", "b", "b")))) > expect.err(try(lm.fit(etit[1:6,c("age","sibsp","parch")], c("a", + "a", "b", "a", "b", "b"))), "INTEGER() can only be applied to a 'integer', not a 'NULL'") Error in lm.fit(etit[1:6, c("age", "sibsp", "parch")], c("a", "a", "b", : INTEGER() can only be applied to a 'integer', not a 'NULL' Got expected error from try(lm.fit(etit[1:6, c("age", "sibsp", "parch")], c("a", "a", "b", "a", "b", "b"))) > > options(warn=2) # treat warnings as errors > expect.err(try(lm(pclass~., data=etit)), "using type = \"numeric\" with a factor response will be ignored") Error in model.response(mf, "numeric") : (converted from warning) using type = "numeric" with a factor response will be ignored Got expected error from try(lm(pclass ~ ., data = etit)) > expect.err(try(linmod(pclass~., data=etit)), "'y' is not numeric or logical") Error in check.linmod.y(x, y) : 'y' is not numeric or logical Got expected error from try(linmod(pclass ~ ., data = etit)) > > options(warn=1) # print warnings as they occur > lm10 <- lm(pclass~., data=etit) # will give warnings Warning in model.response(mf, "numeric") : using type = "numeric" with a factor response will be ignored Warning in Ops.factor(y, z$residuals) : '-' not meaningful for factors > options(warn=2) # treat warnings as errors > linmod10.form <- linmod(as.numeric(pclass)~., data=etit) > stopifnot(coef(linmod10.form) == coef(lm10)) > stopifnot(names(coef(linmod10.form)) == names(coef(lm10))) > # check.lm(linmod10.form, lm10) # fails because lm10 fitted is all NA > > expect.err(try(linmod(pclass~., data=etit)), "'y' is not numeric or logical") Error in check.linmod.y(x, y) : 'y' is not numeric or logical Got expected error from try(linmod(pclass ~ ., data = etit)) > expect.err(try(linmod(etit[,-1], etit[,1])), "non-numeric column in 'x'") Error in check.linmod.x(x) : non-numeric column in 'x' Got expected error from try(linmod(etit[, -1], etit[, 1])) > expect.err(try(linmod(1:10, paste(1:10))), "'y' is not numeric or logical") Error in check.linmod.y(x, y) : 'y' is not numeric or logical Got expected error from try(linmod(1:10, paste(1:10))) > > linmod10a.form <- linmod(survived~pclass, data=etit) > lm10a <- lm(survived~pclass, data=etit) > check.lm(linmod10a.form, lm10a, newdata=etit[3:5,]) check linmod10a.form vs lm10a > > expect.err(try(linmod(etit[,"pclass"], etit[,"age"])), "non-numeric column in 'x'") Error in check.linmod.x(x) : non-numeric column in 'x' Got expected error from try(linmod(etit[, "pclass"], etit[, "age"])) > > expect.err(try(linmod(paste(1:10), 1:10)), "non-numeric column in 'x'") Error in check.linmod.x(x) : non-numeric column in 'x' Got expected error from try(linmod(paste(1:10), 1:10)) > > lm11 <- lm(as.numeric(pclass)~., data=etit) > linmod11.form <- linmod(as.numeric(pclass)~., data=etit) > check.lm(linmod11.form, lm11, newdata=etit[3:5,]) check linmod11.form vs lm11 > > # logical data (not numeric) > bool.data <- data.frame(x=rep(c(TRUE, FALSE, TRUE), length.out=10), + y=rep(c(TRUE, FALSE, FALSE), length.out=10)) > lm12 <- lm(y~x, data=bool.data) > linmod12.form <- linmod(y~x, data=bool.data) > check.lm(linmod12.form, lm12, newdata=bool.data[3:5,1], + check.newdata=FALSE) # needed because predict.lm gives invalid type (list) for variable 'x' check linmod12.form vs lm12 > linmod12.xy <- linmod(bool.data$x, bool.data$y) > # hack: delete mismatching names so check.lm() doesn't fail > names(lm12$coefficients) <- NULL # were "(Intercept)" "xTRUE" > names(linmod12.xy$coefficients) <- NULL # were "(Intercept)" "V1" > check.lm(linmod12.xy, lm12, newdata=bool.data[3:5,1], + check.newdata=FALSE, # needed because predict.lm gives invalid 'envir' argument of type 'logical' + check.casenames=FALSE) check linmod12.xy vs lm12 > > cat0("==check use of functions in arguments to linmod\n") ==check use of functions in arguments to linmod > > identfunc <- function(x) x > lm10 <- lm( sqrt(survived) ~ I(age^2) + as.numeric(sex), data=identfunc(etit)) > linmod10 <- linmod(sqrt(survived) ~ I(age^2) + as.numeric(sex), data=identfunc(etit)) > print(summary(lm10)) Call: lm(formula = sqrt(survived) ~ I(age^2) + as.numeric(sex), data = identfunc(etit)) Residuals: Min 1Q Median 3Q Max -0.6959 -0.2665 -0.2302 0.3427 0.8261 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 1.101e+00 4.223e-01 2.608 0.0198 * I(age^2) -5.389e-05 1.190e-04 -0.453 0.6571 as.numeric(sex) -3.881e-01 2.508e-01 -1.547 0.1426 --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 0.4855 on 15 degrees of freedom Multiple R-squared: 0.1736, Adjusted R-squared: 0.06346 F-statistic: 1.576 on 2 and 15 DF, p-value: 0.2392 > print(summary(linmod10)) Call: linmod.formula(formula = sqrt(survived) ~ I(age^2) + as.numeric(sex), data = identfunc(etit)) Estimate StdErr t.value p.value (Intercept) 1.101499e+00 0.4223245953 2.6081808 0.01977424 I(age^2) -5.389047e-05 0.0001189838 -0.4529226 0.65708686 as.numeric(sex) -3.880912e-01 0.2507927081 -1.5474582 0.14258876 > check.lm(linmod10, lm10, newdata=etit[3:5,]) check linmod10 vs lm10 > set.seed(2020) > plotmo(lm10, pt.col="green", do.par=2) plotmo grid: age sex 32.5 male > set.seed(2020) > plotmo(linmod10, pt.col="green", do.par=0) plotmo grid: age sex 32.5 male > par(org.par) > > cat0("==data.frame with strings\n") ==data.frame with strings > > df.with.string <- + data.frame(1:5, + c(1,2,-1,4,5), + c("a", "b", "a", "a", "b"), + stringsAsFactors=FALSE) > colnames(df.with.string) <- c("num1", "num2", "string") > > linmod30.form <- linmod(num1~num2, df.with.string) > lm30 <- lm(num1~num2, df.with.string) > check.lm(linmod30.form, lm30, check.newdata=FALSE) check linmod30.form vs lm30 > > linmod31.form <- linmod(num1~., df.with.string) > lm31 <- lm(num1~., df.with.string) > check.lm(linmod31.form, lm31, check.newdata=FALSE) check linmod31.form vs lm31 > > expect.err(try(linmod(string~., df.with.string)), "'y' is not numeric or logical") Error in check.linmod.y(x, y) : 'y' is not numeric or logical Got expected error from try(linmod(string ~ ., df.with.string)) > > vec <- c(1,2,3,4,3) > expect.err(try(linmod(df.with.string, vec)), "non-numeric column in 'x'") Error in check.linmod.x(x) : non-numeric column in 'x' Got expected error from try(linmod(df.with.string, vec)) > expect.err(try(linmod(etit$pclass, etit$survived)), "non-numeric column in 'x'") Error in check.linmod.x(x) : non-numeric column in 'x' Got expected error from try(linmod(etit$pclass, etit$survived)) > > cat0("==x is singular\n") ==x is singular > > set.seed(1) > x2 <- matrix(rnorm(6), nrow=2) > y2 <- c(1,2) > expect.err(try(linmod(y2~x2)), "'x' is singular (it has 4 columns but its rank is 2)") Error in do.linmod.fit(x, y) : 'x' is singular (it has 4 columns but its rank is 2) colnames(x): (Intercept) x21 x22 x23 Got expected error from try(linmod(y2 ~ x2)) > > x3 <- matrix(1:10, ncol=2) > y3 <- c(1,2,9,4,5) > expect.err(try(linmod(y3~x3)), "'x' is singular (it has 3 columns but its rank is 2)") Error in do.linmod.fit(x, y) : 'x' is singular (it has 3 columns but its rank is 2) colnames(x): (Intercept) x31 x32 Got expected error from try(linmod(y3 ~ x3)) > > expect.err(try(linmod(trees[1,1:2], trees[1,3])), "'x' is singular (it has 3 columns but its rank is 1)") Error in do.linmod.fit(x, y) : 'x' is singular (it has 3 columns but its rank is 1) colnames(x): (Intercept) Girth Height Got expected error from try(linmod(trees[1, 1:2], trees[1, 3])) > > x2a <- matrix(1:6, nrow=3) > y2a <- c(1,2,3) > expect.err(try(linmod(y2a~x2a)), "'x' is singular (it has 3 columns but its rank is 2)") Error in do.linmod.fit(x, y) : 'x' is singular (it has 3 columns but its rank is 2) colnames(x): (Intercept) x2a1 x2a2 Got expected error from try(linmod(y2a ~ x2a)) > > cat0("==perfect fit (residuals are zero)\n") ==perfect fit (residuals are zero) > > set.seed(1) > x2b <- matrix(rnorm(6), nrow=3) > y2b <- c(1,2,3) > data.x2b <- data.frame(x2b, y2b) > colnames(data.x2b) <- c("x1", "x2", "y") > linmod.x2b <- linmod(y~., data=data.x2b) > print(summary(linmod.x2b)) # will have "Residual degrees-of-freedom is zero" comment Call: linmod.formula(formula = y ~ ., data = data.x2b) Estimate StdErr t.value p.value (Intercept) 2.28088400 Inf 0 0 x1 -0.05211945 Inf 0 0 x2 -0.82338760 Inf 0 0 > lm.x2b <- lm(y~., data=data.x2b) > print(summary(lm.x2b)) # will have "ALL 3 residuals are 0" comment Call: lm(formula = y ~ ., data = data.x2b) Residuals: ALL 3 residuals are 0: no residual degrees of freedom! Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 2.28088 NaN NaN NaN x1 -0.05212 NaN NaN NaN x2 -0.82339 NaN NaN NaN Residual standard error: NaN on 0 degrees of freedom Multiple R-squared: 1, Adjusted R-squared: NaN F-statistic: NaN on 2 and 0 DF, p-value: NA > check.lm(linmod.x2b, lm.x2b, newdata=data.x2b[1:2,]+1, check.sigma=FALSE) check linmod.x2b vs lm.x2b > > x2c <- 1:10 > y2c <- 11:20 > data.x2c <- data.frame(x2c, y2c) > colnames(data.x2c) <- c("x", "y") > linmod.x2c <- linmod(y~., data=data.x2c) > print(summary(linmod.x2c)) Call: linmod.formula(formula = y ~ ., data = data.x2c) Estimate StdErr t.value p.value (Intercept) 10 0 Inf 0 x 1 0 Inf 0 > lm.x2c <- lm(y~., data=data.x2c) > options(warn=1) # print warnings as they occur > print(summary(lm.x2c)) # will have "essentially perfect fit: summary may be unreliable" comment Warning in summary.lm(lm.x2c) : essentially perfect fit: summary may be unreliable Call: lm(formula = y ~ ., data = data.x2c) Residuals: Min 1Q Median 3Q Max -3.635e-15 -3.541e-16 3.225e-16 9.411e-16 1.721e-15 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 1.000e+01 1.100e-15 9.088e+15 <2e-16 *** x 1.000e+00 1.773e-16 5.639e+15 <2e-16 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 1.611e-15 on 8 degrees of freedom Multiple R-squared: 1, Adjusted R-squared: 1 F-statistic: 3.18e+31 on 1 and 8 DF, p-value: < 2.2e-16 > options(warn=2) # treat warnings as errors > check.lm(linmod.x2c, lm.x2c, newdata=data.x2c[1:2,]+1, check.sigma=FALSE) check linmod.x2c vs lm.x2c > > par(mfrow=c(2,2)) # all plots on same page so can compare > plot(linmod.x2b, main="linmod.x2b\nall residuals are zero") > plot(lm.x2b, which=1, main="lm.x2b") > plot(linmod.x2c, main="linmod.x2c") > plot(lm.x2c, which=1, main="lm.x2c") > par(org.par) > > cat0("==nrow(x) does not match length(y)\n") ==nrow(x) does not match length(y) > > x4 <- matrix(1:10, ncol=2) > y4 <- c(1,2,9,4) > expect.err(try(linmod(x4, y4)), "nrow(x) is 5 but length(y) is 4") Error in check.linmod.y(x, y) : nrow(x) is 5 but length(y) is 4 Got expected error from try(linmod(x4, y4)) > > x5 <- matrix(1:10, ncol=2) > y5 <- c(1,2,9,4,5,9) > expect.err(try(linmod(x5, y5)), "nrow(x) is 5 but length(y) is 6") Error in check.linmod.y(x, y) : nrow(x) is 5 but length(y) is 6 Got expected error from try(linmod(x5, y5)) > > cat0("==y has multiple columns\n") ==y has multiple columns > > vec <- c(1,2,3,4,3) > y2 <- cbind(c(1,2,3,4,9), vec^2) > expect.err(try(linmod(vec, y2)), "nrow(x) is 5 but length(y) is 10") Error in check.linmod.y(x, y) : nrow(x) is 5 but length(y) is 10 Got expected error from try(linmod(vec, y2)) > expect.err(try(linmod(y2~vec)), "nrow(x) is 5 but length(y) is 10") Error in check.linmod.y(x, y) : nrow(x) is 5 but length(y) is 10 Got expected error from try(linmod(y2 ~ vec)) > > cat0("==NA in x\n") ==NA in x > > x <- tr[,1:2] > y <- tr[,3] > x[2,2] <- NA > expect.err(try(linmod(x, y)), "NA in 'x'") Error in check.linmod.x(x) : NA in 'x' Got expected error from try(linmod(x, y)) > > x <- tr[,1:2] > y <- tr[,3] > y[9] <- NA > expect.err(try(linmod(x, y)), "NA in 'y'") Error in check.linmod.y(x, y) : NA in 'y' Got expected error from try(linmod(x, y)) > > # Following added Sep 2020 (prior to this, predict.linmod gave an incorrect error message) > cat0("==test formulas that use functions on rhs variables, like Volume~sqrt(Girth)\n") ==test formulas that use functions on rhs variables, like Volume~sqrt(Girth) > > linmod.sqrt1 <- linmod(Volume~sqrt(as.numeric(Girth)), data=tr) > cat0("==print(summary(linmod.sqrt1))\n") ==print(summary(linmod.sqrt1)) > print(summary(linmod.sqrt1)) Call: linmod.formula(formula = Volume ~ sqrt(as.numeric(Girth)), data = tr) Estimate StdErr t.value p.value (Intercept) -103.40058 7.706018 -13.41816 5.733634e-14 sqrt(as.numeric(Girth)) 36.94188 2.117135 17.44900 6.396229e-17 > lm.sqrt1 <- lm(Volume~sqrt(as.numeric(Girth)), data=tr) > check.lm(linmod.sqrt1, lm.sqrt1) check linmod.sqrt1 vs lm.sqrt1 > stopifnot(almost.equal(predict(linmod.sqrt1, newdata=data.frame(Girth=10, Height=80)), + predict(lm.sqrt1, newdata=data.frame(Girth=10, Height=80)))) > stopifnot(almost.equal(predict(linmod.sqrt1, newdata=as.matrix(tr[1:3,])), + predict(lm.sqrt1, newdata=tr[1:3,]))) > par(mfrow=c(2,2)) # all plots on same page so can compare > plotmo(linmod.sqrt1, do.par=FALSE) > plotmo(lm.sqrt1, do.par=FALSE) > par(org.par) > > linmod.sqrt2 <- linmod(Volume~sqrt(Girth)+Height+Girth, data=tr) > cat0("==print(summary(linmod.sqrt2))\n") ==print(summary(linmod.sqrt2)) > print(summary(linmod.sqrt2)) Call: linmod.formula(formula = Volume ~ sqrt(Girth) + Height + Girth, data = tr) Estimate StdErr t.value p.value (Intercept) 132.4266671 33.03008713 4.009274 4.318421e-04 sqrt(Girth) -106.5505058 18.19173301 -5.857084 3.085730e-06 Height 0.4030722 0.08863082 4.547765 1.026574e-04 Girth 19.0489443 2.45495604 7.759383 2.410443e-08 > lm.sqrt2 <- lm(Volume~sqrt(Girth)+Height+Girth, data=tr) > check.lm(linmod.sqrt2, lm.sqrt2) check linmod.sqrt2 vs lm.sqrt2 > stopifnot(almost.equal(predict(linmod.sqrt2, newdata=data.frame(Girth=10, Height=80)), + predict(lm.sqrt2, newdata=data.frame(Girth=10, Height=80)))) > stopifnot(almost.equal(predict(linmod.sqrt2, newdata=as.matrix(tr[1:3,])), + predict(lm.sqrt2, newdata=tr[1:3,]))) > par(mfrow=c(2,2)) # all plots on same page so can compare > plotmo(linmod.sqrt2, do.par=FALSE) plotmo grid: Girth Height 12.9 76 > plotmo(lm.sqrt2, do.par=FALSE) plotmo grid: Girth Height 12.9 76 > par(org.par) > > lm.sqrt.as.numeric <- lm(survived~sqrt(age)+as.numeric(pclass), data=etit) > linmod.sqrt.as.numeric <- linmod(survived~sqrt(age)+as.numeric(pclass), data=etit) > check.lm(linmod.sqrt.as.numeric, lm.sqrt.as.numeric, newdata=etit[3:5,]) check linmod.sqrt.as.numeric vs lm.sqrt.as.numeric > expect.err(try(predict(linmod.sqrt.as.numeric, newdata=data.frame(age=30))), # pclass missing + "object 'pclass' not found") Error in eval(predvars, data, env) : object 'pclass' not found Got expected error from try(predict(linmod.sqrt.as.numeric, newdata = data.frame(age = 30))) > par(mfrow=c(2,2)) # all plots on same page so can compare > plotmo(linmod.sqrt.as.numeric, do.par=FALSE) plotmo grid: age pclass 32.5 3rd > plotmo(lm.sqrt.as.numeric, do.par=FALSE) plotmo grid: age pclass 32.5 3rd > par(org.par) > > y.age <- etit[,"age"] > x.pclass <- etit[,"pclass"] > x.sex <- etit[,"sex"] > linmod.y.age.sex.pclass <- linmod(y.age ~ as.numeric(x.pclass) + x.sex) > lm.y.age.sex.pclass <- lm( y.age ~ as.numeric(x.pclass) + x.sex) > stopifnot(identical(linmod.y.age.sex.pclass$coef, lm.y.age.sex.pclass$coef)) > options(warn=1) # print warnings as they occur to test stop() in linmod.R::process.newdata.formula > # TODO following says variable 'as.numeric(x.pclass)' may be missing > # it should say variable 'x.pclass' may be missing > expect.err(try(predict(linmod.y.age.sex.pclass, newdata=etit[3:5,1,drop=FALSE])), + "newdata has 3 rows but model.frame returned 18 rows (variable 'as.numeric(x.pclass)' may be missing from newdata)") Warning: 'newdata' had 3 rows but variables found have 18 rows Error in process.newdata.formula(object, newdata) : newdata has 3 rows but model.frame returned 18 rows (variable 'as.numeric(x.pclass)' may be missing from newdata) Got expected error from try(predict(linmod.y.age.sex.pclass, newdata = etit[3:5, 1, drop = FALSE])) > options(warn=2) # back to treating warnings as errors > > cat0("==misc tests with different kinds of data\n") ==misc tests with different kinds of data > > data3 <- data.frame(s=c("a", "b", "a", "c", "a"), num=c(1,5,1,9,2), y=c(1,3,2,5,3), stringsAsFactors=F) > stopifnot(sapply(data3, class) == c("character", "numeric", "numeric")) > a40 <- linmod(y~., data=data3) > print(summary(a40)) Call: linmod.formula(formula = y ~ ., data = data3) Estimate StdErr t.value p.value (Intercept) -1.390219e-15 1.2247449 -1.135109e-15 1.0000000 sb -4.500000e+00 3.2787193 -1.372487e+00 0.4008582 sc -8.500000e+00 6.6895441 -1.270640e+00 0.4244770 num 1.500000e+00 0.8660254 1.732051e+00 0.3333333 > stopifnot(almost.equal(a40$coefficients, c(0, -4.5, -8.5, 1.5), max=0.001)) > stopifnot(almost.equal(predict(a40, newdata=data3[2:3,]), + c(3.0, 1.5), max=0.001)) > > data4 <- data.frame(s=c("a", "b", "a", "c", "a"), num=c(1,5,1,9,2), y=c(1,3,2,5,3), stringsAsFactors=T) > stopifnot(sapply(data4, class) == c("factor", "numeric", "numeric")) > expect.err(try(linmod(data4[,1:2], data4[,3])), "non-numeric column in 'x'") Error in check.linmod.x(x) : non-numeric column in 'x' Got expected error from try(linmod(data4[, 1:2], data4[, 3])) > > # following gives no error (and matches lm) even though col 1 of data3 is character not factor > a41 <- linmod(y~., data=data4) > print(summary(a41)) Call: linmod.formula(formula = y ~ ., data = data4) Estimate StdErr t.value p.value (Intercept) -1.390219e-15 1.2247449 -1.135109e-15 1.0000000 sb -4.500000e+00 3.2787193 -1.372487e+00 0.4008582 sc -8.500000e+00 6.6895441 -1.270640e+00 0.4244770 num 1.500000e+00 0.8660254 1.732051e+00 0.3333333 > stopifnot(almost.equal(predict(a41, newdata=data3[2:3,]), + c(3.0, 1.5), max=0.001)) > > data5 <- data.frame(s=c("a", "b", "c", "a", "a"), num=c(1,9,4,2,6), y=c(1,2,3,5,3), stringsAsFactors=F) > stopifnot(almost.equal(predict(a41, newdata=data5[1:3,1:2]), + c(1.5, 9.0, -2.5), max=0.001)) > > data6 <- data.frame(s=c("a", "b", "c", "a9", "a"), + num=c(1,9,4,2,6), + num2=c(1,9,4,2,7), + y=c(1,2,3,5,3), stringsAsFactors=T) > expect.err(try(predict(a41, newdata=data6[1:3,1])), "object 's' not found") Error in eval(predvars, data, env) : object 's' not found Got expected error from try(predict(a41, newdata = data6[1:3, 1])) > expect.err(try(predict(a41, newdata=data6[1:3,c(1,1)])), "object 'num' not found") Error in eval(predvars, data, env) : object 'num' not found Got expected error from try(predict(a41, newdata = data6[1:3, c(1, 1)])) > > expect.err(try(predict(a41, newdata=data.frame(s=1, num=2, y=3))), "variable 's' is not a factor") Error in model.frame.default(terms, newdata, na.action = na.pass, xlev = object$xlevels) : (converted from warning) variable 's' is not a factor Got expected error from try(predict(a41, newdata = data.frame(s = 1, num = 2, y = 3))) > > expect.err(try(predict(a41, newdata=1:9)), + "object 's' not found") Error in eval(predvars, data, env) : object 's' not found Got expected error from try(predict(a41, newdata = 1:9)) > > expect.err(try(predict(a41, newdata=data.frame())), "'newdata' is empty") Error in predict.linmod(a41, newdata = data.frame()) : 'newdata' is empty Got expected error from try(predict(a41, newdata = data.frame())) > > # perfect fit (residuals are all zero) > linmod.data6 <- linmod(y~s+num, data=data6) > print(summary(linmod.data6)) Call: linmod.formula(formula = y ~ s + num, data = data6) Estimate StdErr t.value p.value (Intercept) 0.6 Inf 0 0 sa9 3.6 Inf 0 0 sb -2.2 Inf 0 0 sc 0.8 Inf 0 0 num 0.4 Inf 0 0 > lm.data6 <- lm(y~s+num, data=data6) > print(summary(lm.data6)) Call: lm(formula = y ~ s + num, data = data6) Residuals: ALL 5 residuals are 0: no residual degrees of freedom! Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 0.6 NaN NaN NaN sa9 3.6 NaN NaN NaN sb -2.2 NaN NaN NaN sc 0.8 NaN NaN NaN num 0.4 NaN NaN NaN Residual standard error: NaN on 0 degrees of freedom Multiple R-squared: 1, Adjusted R-squared: NaN F-statistic: NaN on 4 and 0 DF, p-value: NA > check.lm(linmod.data6, lm.data6, newdata=data6[2,,drop=FALSE], check.sigma=FALSE) check linmod.data6 vs lm.data6 > > expect.err(try(linmod(y~., data=data6)), "'x' is singular (it has 6 columns but its rank is 5)") Error in do.linmod.fit(x, y) : 'x' is singular (it has 6 columns but its rank is 5) colnames(x): (Intercept) sa9 sb sc num num2 Got expected error from try(linmod(y ~ ., data = data6)) > > tr.na <- trees > tr.na[9,3] <- NA > expect.err(try(linmod(Volume~.,data=tr.na)), "NA in 'y'") Error in check.linmod.y(x, y) : NA in 'y' Got expected error from try(linmod(Volume ~ ., data = tr.na)) > expect.err(try(linmod(tr.na[,1:2], tr.na[,3])), "NA in 'y'") Error in check.linmod.y(x, y) : NA in 'y' Got expected error from try(linmod(tr.na[, 1:2], tr.na[, 3])) > > tr.na <- trees > tr.na[10,1] <- NA > expect.err(try(linmod(Volume~.,data=tr.na)), "NA in 'x'") Error in check.linmod.x(x) : NA in 'x' Got expected error from try(linmod(Volume ~ ., data = tr.na)) > expect.err(try(linmod(tr.na[,1:2], tr.na[,3])), "NA in 'x'") Error in check.linmod.x(x) : NA in 'x' Got expected error from try(linmod(tr.na[, 1:2], tr.na[, 3])) > > a42 <- linmod(trees[,1:2], trees[, 3]) > newdata1 <- data.frame(Girth=20) > expect.err(try(predict(a42, newdata=newdata1)), "ncol(newdata) is 1 but should be 2") Error in predict.linmod(a42, newdata = newdata1) : ncol(newdata) is 1 but should be 2 Got expected error from try(predict(a42, newdata = newdata1)) > newdata3 <- data.frame(Girth=20, extra1=21, extra2=22) > expect.err(try(predict(a42, newdata=newdata3)), "ncol(newdata) is 3 but should be 2") Error in predict.linmod(a42, newdata = newdata3) : ncol(newdata) is 3 but should be 2 Got expected error from try(predict(a42, newdata = newdata3)) > expect.err(try(predict(a42, newdata=data.frame())), "'newdata' is empty") Error in predict.linmod(a42, newdata = data.frame()) : 'newdata' is empty Got expected error from try(predict(a42, newdata = data.frame())) > newdata.with.NA <- data.frame(Girth=20, Height=NA) > expect.err(try(predict(a42, newdata=newdata.with.NA)), "NA in 'newdata'") Error in predict.linmod(a42, newdata = newdata.with.NA) : NA in 'newdata' Got expected error from try(predict(a42, newdata = newdata.with.NA)) > > a43 <- linmod(Volume~.,data=trees) > expect.err(try(predict(a43, newdata=newdata.with.NA)), "NA in 'newdata'") Error in process.newdata.formula(object, newdata) : NA in 'newdata' Got expected error from try(predict(a43, newdata = newdata.with.NA)) > lm43 <- lm(Volume~.,data=trees) > # message from predict.lm could be better > expect.err(try(predict(lm43, newdata=newdata.with.NA)), + "variable 'Height' was fitted with type \"numeric\" but type \"logical\" was supplied") Error : variable 'Height' was fitted with type "numeric" but type "logical" was supplied Got expected error from try(predict(lm43, newdata = newdata.with.NA)) > > y6 <- 1:5 > x6 <- data.frame() > options(warn=1) # print warnings as they occur > expect.err(try(linmod(x6, y6)), "'x' is empty") Warning in cbind(`(Intercept)` = 1, xmat) : number of rows of result is not a multiple of vector length (arg 1) Error in check.linmod.x(x) : 'x' is empty Got expected error from try(linmod(x6, y6)) > options(warn=2) # treat warnings as errors > > y7 <- data.frame() > x7 <- 1:5 > expect.err(try(linmod(x7, y7)), "'y' is empty") Error in check.linmod.y(x, y) : 'y' is empty Got expected error from try(linmod(x7, y7)) > > # duplicated column names > data7 <- matrix(1:25, ncol=5) > colnames(data7) <- c("y", "x1", "x1", "x3", "x4") > expect.err(try(linmod(data7[,-1], data7[,1])), "column name \"x1\" in 'x' is duplicated") Error in check.linmod.x(x) : column name "x1" in 'x' is duplicated Got expected error from try(linmod(data7[, -1], data7[, 1])) > > colnames(data7) <- c("y", "x1", "x2", "x2", "x4") > expect.err(try(linmod(data7[,-1], data7[,1])), "column name \"x2\" in 'x' is duplicated") Error in check.linmod.x(x) : column name "x2" in 'x' is duplicated Got expected error from try(linmod(data7[, -1], data7[, 1])) > > colnames(data7) <- c("y", "x1", "x2", "x2", "x2") > expect.err(try(linmod(data7[,-1], data7[,1])), "column name \"x2\" in 'x' is duplicated") Error in check.linmod.x(x) : column name "x2" in 'x' is duplicated Got expected error from try(linmod(data7[, -1], data7[, 1])) > > # column name V2 will be created but it clashes with the existing column name > colnames(data7) <- c("y", "V2", "", "V3", "V4") > expect.err(try(linmod(data7[,-1], data7[,1])), "column name \"V2\" in 'x' is duplicated") Error in check.linmod.x(x) : column name "V2" in 'x' is duplicated Got expected error from try(linmod(data7[, -1], data7[, 1])) > > # missing column names > trees1 <- trees > colnames(trees1) <- NULL > cat0("a52\n") a52 > a52 <- linmod(trees1[,1:2], trees1[,3]) > print(summary(a52)) Call: linmod.default(x = trees1[, 1:2], y = trees1[, 3]) Estimate StdErr t.value p.value (Intercept) -57.9876589 8.6382259 -6.712913 2.749507e-07 V1 4.7081605 0.2642646 17.816084 8.223304e-17 V2 0.3392512 0.1301512 2.606594 1.449097e-02 > > trees1 <- trees > colnames(trees1) <- c("", "Height", "Volume") # was Girth Height Volume > cat0("linmod.form.Volume.trees1\n") linmod.form.Volume.trees1 > linmod.form.Volume.trees1 <- linmod(trees1[,1:2], trees1[,3]) > print(summary(linmod.form.Volume.trees1)) Call: linmod.default(x = trees1[, 1:2], y = trees1[, 3]) Estimate StdErr t.value p.value (Intercept) -57.9876589 8.6382259 -6.712913 2.749507e-07 V1 4.7081605 0.2642646 17.816084 8.223304e-17 Height 0.3392512 0.1301512 2.606594 1.449097e-02 > cat0("linmod.form.Volume.trees1.formula\n") linmod.form.Volume.trees1.formula > expect.err(try(linmod(Volume~., data=trees1)), "attempt to use zero-length variable name") Error in terms.formula(formula, data = data) : attempt to use zero-length variable name Got expected error from try(linmod(Volume ~ ., data = trees1)) > > # very long names to test formatting in summary.linmod > trees1 <- trees > colnames(trees1) <- c("Girth.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name", + "Height.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name", + "Volume.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name") > cat0("a55\n") a55 > a55 <- linmod(Volume.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name~ + Girth.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name+ + Height.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name, + data=trees1) > print(summary(a55)) Call: linmod.formula(formula = Volume.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name ~ Girth.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name + Height.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name, data = trees1) Estimate (Intercept) -57.9876589 Girth.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name 4.7081605 Height.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name 0.3392512 StdErr (Intercept) 8.6382259 Girth.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name 0.2642646 Height.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name 0.1301512 t.value (Intercept) -6.712913 Girth.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name 17.816084 Height.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name 2.606594 p.value (Intercept) 2.749507e-07 Girth.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name 8.223304e-17 Height.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name 1.449097e-02 > > # intercept-only model > intonly.form <- linmod(Volume~1, data=trees) > print(summary(intonly.form)) Call: linmod.formula(formula = Volume ~ 1, data = trees) Estimate StdErr t.value p.value (Intercept) 30.17097 2.952324 10.21939 2.753323e-11 > stopifnot(length(coef(intonly.form)) == 1) > try(plotmo(intonly.form)) # Error in plotmo(intonly.form) : x is empty Error in plotmo(intonly.form) : x is empty > plotres(intonly.form) > expect.err(try(plotmo(intonly.form)), "x is empty") Error in plotmo(intonly.form) : x is empty Got expected error from try(plotmo(intonly.form)) > expect.err(try(linmod(rep(1, length.out=nrow(trees)), trees$Volume)), + "'x' is singular (it has 2 columns but its rank is 1)") Error in do.linmod.fit(x, y) : 'x' is singular (it has 2 columns but its rank is 1) colnames(x): (Intercept) V1 Got expected error from try(linmod(rep(1, length.out = nrow(trees)), trees$Volume)) > > # various tests for bad args > expect.err(try(linmod(trees[,1:2])), "no 'y' argument") Error in as.matrix(y) : no 'y' argument Got expected error from try(linmod(trees[, 1:2])) > > # test stop.if.dot.arg.used > expect.err(try(linmod(Volume~., data=trees, nonesuch=99)), + "unused argument (nonesuch = 99)") Error in stop.if.dot.arg.used(...) : unused argument (nonesuch = 99) Got expected error from try(linmod(Volume ~ ., data = trees, nonesuch = 99)) > expect.err(try(linmod(trees[,1:2], trees[,3], nonesuch=linmod)), + "unused argument (nonesuch = function (...)") Error in stop.if.dot.arg.used(...) : unused argument (nonesuch = function (...) UseMethod("linmod")) Got expected error from try(linmod(trees[, 1:2], trees[, 3], nonesuch = linmod)) > expect.err(try(summary(linmod(trees[,1:2], trees[,3]), nonesuch=linmod)), + "unused argument (nonesuch = function (...)") Error in stop.if.dot.arg.used(...) : unused argument (nonesuch = function (...) UseMethod("linmod")) Got expected error from try(summary(linmod(trees[, 1:2], trees[, 3]), nonesuch = linmod)) > expect.err(try(print(linmod(trees[,1:2], trees[,3]), nonesuch=linmod)), + "unused argument (nonesuch = function (...)") Error in stop.if.dot.arg.used(...) : unused argument (nonesuch = function (...) UseMethod("linmod")) Got expected error from try(print(linmod(trees[, 1:2], trees[, 3]), nonesuch = linmod)) > expect.err(try(predict(linmod.form.Volume.tr, nonesuch=99)), + "unused argument (nonesuch = 99)") Error in stop.if.dot.arg.used(...) : unused argument (nonesuch = 99) Got expected error from try(predict(linmod.form.Volume.tr, nonesuch = 99)) > > # check partial matching on type argument > stopifnot(identical(predict(linmod.form.Volume.tr, type="r"), predict(linmod.form.Volume.tr))) > stopifnot(identical(predict(linmod.form.Volume.tr, type="resp"), predict(linmod.form.Volume.tr))) > expect.err(try(predict(linmod.form.Volume.tr, type="nonesuch")), "'arg' should be \"response\"") Error in match.arg(type, "response") : 'arg' should be "response" Got expected error from try(predict(linmod.form.Volume.tr, type = "nonesuch")) > > # test additional method functions (see linmod.methods.R) > > check.lm(linmod.form.Volume.tr, lm.Volume.tr, newdata=trees[3,1:2]) check linmod.form.Volume.tr vs lm.Volume.tr > stopifnot(almost.equal(coef(linmod.form.Volume.tr), coef(lm.Volume.tr))) > stopifnot(identical(names(coef(linmod.form.Volume.tr)), names(coef(lm.Volume.tr)))) > stopifnot(almost.equal(fitted(linmod.form.Volume.tr), fitted(lm.Volume.tr))) > stopifnot(identical(names(fitted(linmod.form.Volume.tr)), names(fitted(lm.Volume.tr)))) > stopifnot(identical(na.action(linmod.form.Volume.tr), na.action(lm.Volume.tr))) > stopifnot(almost.equal(residuals(linmod.form.Volume.tr), residuals(lm.Volume.tr))) > stopifnot(identical(names(residuals(linmod.form.Volume.tr)), names(residuals(lm.Volume.tr)))) > stopifnot(identical(names(case.names(linmod.form.Volume.tr)), names(case.names(lm.Volume.tr)))) > stopifnot(identical(variable.names(linmod.form.Volume.tr), variable.names(lm.Volume.tr))) > stopifnot(identical(nobs(linmod.form.Volume.tr), nobs(lm.Volume.tr))) > stopifnot(identical(weights(linmod.form.Volume.tr), weights(lm.Volume.tr))) > stopifnot(almost.equal(df.residual(linmod.form.Volume.tr), df.residual(lm.Volume.tr))) > stopifnot(identical(names(df.residual(linmod.form.Volume.tr)), names(df.residual(lm.Volume.tr)))) > stopifnot(almost.equal(deviance(linmod.form.Volume.tr), deviance(lm.Volume.tr))) > stopifnot(identical(names(deviance(linmod.form.Volume.tr)), names(deviance(lm.Volume.tr)))) > stopifnot(identical(weights(linmod.form.Volume.tr), weights(lm.Volume.tr))) > stopifnot(identical(model.frame(linmod.form.Volume.tr), model.frame(lm.Volume.tr))) > stopifnot(identical(model.matrix(linmod.form.Volume.tr), model.matrix(lm.Volume.tr))) > stopifnot(identical(model.matrix(linmod.form.Volume.tr, data=tr[1:2,]), + model.matrix(lm.Volume.tr, data=tr[1:2,]))) > stopifnot(almost.equal(logLik(linmod.form.Volume.tr), logLik(lm.Volume.tr))) > expect.err(try(logLik(linmod.form.Volume.tr, REML=TRUE)), "!REML is not TRUE") Error in logLik.linmod(linmod.form.Volume.tr, REML = TRUE) : !REML is not TRUE Got expected error from try(logLik(linmod.form.Volume.tr, REML = TRUE)) > library(sandwich) # for estfun.lm > stopifnot(almost.equal(estfun(linmod.form.Volume.tr), estfun(lm.Volume.tr))) > > linmod.form.Volume.tr.update <- update(linmod.form.Volume.tr, formula.=Volume~Height) > lm.Volume.tr.update <- update(lm.Volume.tr, formula.=Volume~Height) > check.lm(linmod.form.Volume.tr.update, lm.Volume.tr.update) check linmod.form.Volume.tr.update vs lm.Volume.tr.update > > check.lm(linmod.xy.Volume.tr, lm.Volume.tr, newdata=trees[3,1:2]) check linmod.xy.Volume.tr vs lm.Volume.tr > stopifnot(almost.equal(coef(linmod.xy.Volume.tr), coef(lm.Volume.tr))) > stopifnot(identical(names(coef(linmod.xy.Volume.tr)), names(coef(lm.Volume.tr)))) > stopifnot(almost.equal(fitted(linmod.xy.Volume.tr), fitted(lm.Volume.tr))) > stopifnot(identical(names(fitted(linmod.xy.Volume.tr)), names(fitted(lm.Volume.tr)))) > stopifnot(identical(na.action(linmod.xy.Volume.tr), na.action(lm.Volume.tr))) > stopifnot(almost.equal(residuals(linmod.xy.Volume.tr), residuals(lm.Volume.tr))) > stopifnot(identical(names(residuals(linmod.xy.Volume.tr)), names(residuals(lm.Volume.tr)))) > stopifnot(identical(case.names(linmod.xy.Volume.tr), case.names(lm.Volume.tr))) > stopifnot(identical(variable.names(linmod.xy.Volume.tr), variable.names(lm.Volume.tr))) > stopifnot(identical(nobs(linmod.xy.Volume.tr), nobs(lm.Volume.tr))) > stopifnot(identical(weights(linmod.xy.Volume.tr), weights(lm.Volume.tr))) > stopifnot(almost.equal(df.residual(linmod.xy.Volume.tr), df.residual(lm.Volume.tr))) > stopifnot(identical(names(df.residual(linmod.xy.Volume.tr)), names(df.residual(lm.Volume.tr)))) > stopifnot(almost.equal(deviance(linmod.xy.Volume.tr), deviance(lm.Volume.tr))) > stopifnot(identical(names(deviance(linmod.xy.Volume.tr)), names(deviance(lm.Volume.tr)))) > stopifnot(identical(weights(linmod.xy.Volume.tr), weights(lm.Volume.tr))) > expect.err(try(model.frame(linmod.xy.Volume.tr)), "model.frame cannot be used on linmod models built without a formula") Error in model.frame.linmod(linmod.xy.Volume.tr) : model.frame cannot be used on linmod models built without a formula Got expected error from try(model.frame(linmod.xy.Volume.tr)) > expect.err(try(model.matrix(linmod.xy.Volume.tr)), + "model.frame cannot be used on linmod models built without a formula") Error in model.frame.linmod(object) : model.frame cannot be used on linmod models built without a formula Got expected error from try(model.matrix(linmod.xy.Volume.tr)) > stopifnot(almost.equal(logLik(linmod.xy.Volume.tr), logLik(lm.Volume.tr))) > > par(mfrow=c(2,2)) > plot(linmod.form.Volume.tr) > plot(lm.Volume.tr, which=1, main="lm.Volume.tr") > plot(linmod.xy.Volume.tr) > plot(linmod.form.Volume.tr, xlim=c(0,80), ylim=c(-10,10), pch=20, main="linmod.form.Volume.tr: test plot args") > par(org.par) > > cat0("==test one predictor model\n") ==test one predictor model > > linmod.onepred.form <- linmod(Volume~Girth, data=tr) # one predictor > lm.onepred.form <- lm(Volume~Girth, data=tr) > check.lm(linmod.onepred.form, lm.onepred.form, newdata=trees[3,1:2]) check linmod.onepred.form vs lm.onepred.form > linmod.onepred.xy <- linmod(tr[,1,drop=FALSE], tr[,3]) # one predictor > print(summary(linmod.onepred.xy)) Call: linmod.default(x = tr[, 1, drop = FALSE], y = tr[, 3]) Estimate StdErr t.value p.value (Intercept) -36.943459 3.365145 -10.97827 7.621449e-12 Girth 5.065856 0.247377 20.47829 8.644334e-19 > check.lm(linmod.onepred.xy, lm.onepred.form, newdata=trees[3,1,drop=FALSE]) check linmod.onepred.xy vs lm.onepred.form > > par(mfrow=c(2,2)) > plot(linmod.onepred.form) > plot(lm.onepred.form, which=1, main="lm.onepred.form") > plot(linmod.onepred.xy) > par(org.par) > plotres(linmod.onepred.form) > plotmo(linmod.onepred.form, pt.col=2) > > cat0("==test no intercept model\n") ==test no intercept model > # no intercept models are only supported with the formula interface (not x,y interface) > > linmod.noint <- linmod(Volume~.-1, data=trees) # no intercept > print(summary(linmod.noint)) Call: linmod.formula(formula = Volume ~ . - 1, data = trees) Estimate StdErr t.value p.value Girth 5.0440083 0.4118733 12.246506 5.519859e-13 Height -0.4773192 0.0734721 -6.496605 4.118004e-07 > lm.noint <- lm(Volume~.-1, data=trees) # no intercept > check.lm(linmod.noint, lm.noint) check linmod.noint vs lm.noint > linmod.noint.keep <- linmod(Volume~.-1, data=trees, keep=TRUE) > print(summary(linmod.noint.keep)) Call: linmod.formula(formula = Volume ~ . - 1, data = trees, keep = TRUE) Estimate StdErr t.value p.value Girth 5.0440083 0.4118733 12.246506 5.519859e-13 Height -0.4773192 0.0734721 -6.496605 4.118004e-07 > > check.lm(linmod.noint, lm.noint) check linmod.noint vs lm.noint > stopifnot(class(linmod.noint.keep$data) == class(linmod.form.Volume.trees.keep$data)) > stopifnot(all(dim(linmod.noint.keep$data) == dim(linmod.form.Volume.trees.keep$data))) > stopifnot(all(linmod.noint.keep$data == linmod.form.Volume.trees.keep$data)) > stopifnot(class(linmod.noint.keep$y) == class(linmod.form.Volume.trees.keep$y)) > stopifnot(all(dim(linmod.noint.keep$data) == dim(linmod.form.Volume.trees.keep$data))) > stopifnot(all(linmod.noint.keep$data == linmod.form.Volume.trees.keep$data)) > > # check method functions in no-intercept model > stopifnot(almost.equal(coef(linmod.noint), coef(lm.noint))) > stopifnot(identical(names(coef(linmod.noint)), names(coef(lm.noint)))) > stopifnot(almost.equal(fitted(linmod.noint), fitted(lm.noint))) > stopifnot(identical(names(fitted(linmod.noint)), names(fitted(lm.noint)))) > stopifnot(identical(na.action(linmod.noint), na.action(lm.noint))) > stopifnot(almost.equal(residuals(linmod.noint), residuals(lm.noint))) > stopifnot(identical(names(residuals(linmod.noint)), names(residuals(lm.noint)))) > stopifnot(identical(case.names(linmod.noint), case.names(lm.noint))) > stopifnot(identical(variable.names(linmod.noint), variable.names(lm.noint))) > stopifnot(identical(nobs(linmod.noint), nobs(lm.noint))) > stopifnot(identical(weights(linmod.noint), weights(lm.noint))) > stopifnot(almost.equal(df.residual(linmod.noint), df.residual(lm.noint))) > stopifnot(identical(names(df.residual(linmod.noint)), names(df.residual(lm.noint)))) > stopifnot(almost.equal(deviance(linmod.noint), deviance(lm.noint))) > stopifnot(identical(names(deviance(linmod.noint)), names(deviance(lm.noint)))) > stopifnot(identical(weights(linmod.noint), weights(lm.noint))) > stopifnot(identical(model.frame(linmod.noint), model.frame(lm.noint))) > stopifnot(identical(model.matrix(linmod.noint), model.matrix(lm.noint))) > stopifnot(identical(model.matrix(linmod.noint, data=tr[1:2,]), + model.matrix(lm.noint, data=tr[1:2,]))) > stopifnot(almost.equal(logLik(linmod.noint), logLik(lm.noint))) > stopifnot(almost.equal(estfun(linmod.noint), estfun(lm.noint))) > > # check error messages with bad newdata in no-intercept model > expect.err(try(predict(linmod.noint, newdata=NA)), + "object 'Girth' not found") Error in eval(predvars, data, env) : object 'Girth' not found Got expected error from try(predict(linmod.noint, newdata = NA)) > expect.err(try(predict(linmod.noint, newdata=data.frame(Height=c(1,NA), Girth=c(3,4)))), + "NA in 'newdata'") Error in process.newdata.formula(object, newdata) : NA in 'newdata' Got expected error from try(predict(linmod.noint, newdata = data.frame(Height = c(1, NA), Girth = c(3, 4)))) > expect.err(try(predict(linmod.noint, newdata=trees[0,])), "'newdata' is empty") Error in predict.linmod(linmod.noint, newdata = trees[0, ]) : 'newdata' is empty Got expected error from try(predict(linmod.noint, newdata = trees[0, ])) > expect.err(try(predict(linmod.noint, newdata=trees[3:5,"Height"])), "object 'Girth' not found") Error in eval(predvars, data, env) : object 'Girth' not found Got expected error from try(predict(linmod.noint, newdata = trees[3:5, "Height"])) > # check that extra fields in predict newdata are ok with (formula) models without intercept > stopifnot(almost.equal(predict(linmod.noint, newdata=data.frame(Girth=10, Height=80, extra=99)), + predict(lm.noint, newdata=data.frame(Girth=10, Height=80, extra=99)))) > > par(mfrow=c(2,2)) > plot(linmod.noint) > plot(lm.noint, which=1, main="lm.noint") > par(org.par) > > plotres(linmod.noint) > plotmo(linmod.noint) plotmo grid: Girth Height 12.9 76 > > cat0("==test one predictor no intercept model\n") ==test one predictor no intercept model > # no intercept models are only supported with the formula interface (not x,y interface) > > linmod.onepred.noint <- linmod(Volume~Girth-1, data=trees) # one predictor, no intercept > print(summary(linmod.onepred.noint)) Call: linmod.formula(formula = Volume ~ Girth - 1, data = trees) Estimate StdErr t.value p.value Girth 2.420943 0.1253311 19.31637 1.7813e-18 > lm.onepred.noint <- lm(Volume~Girth-1, data=trees) # one predictor, no intercept > check.lm(linmod.onepred.noint, lm.onepred.noint) check linmod.onepred.noint vs lm.onepred.noint > linmod.onepred.noint.keep <- linmod(Volume~.-1, data=trees, keep=TRUE) > print(summary(linmod.onepred.noint.keep)) Call: linmod.formula(formula = Volume ~ . - 1, data = trees, keep = TRUE) Estimate StdErr t.value p.value Girth 5.0440083 0.4118733 12.246506 5.519859e-13 Height -0.4773192 0.0734721 -6.496605 4.118004e-07 > > check.lm(linmod.onepred.noint, lm.onepred.noint) check linmod.onepred.noint vs lm.onepred.noint > stopifnot(class(linmod.onepred.noint.keep$data) == class(linmod.form.Volume.trees.keep$data)) > stopifnot(all(dim(linmod.onepred.noint.keep$data) == dim(linmod.form.Volume.trees.keep$data))) > stopifnot(all(linmod.onepred.noint.keep$data == linmod.form.Volume.trees.keep$data)) > stopifnot(class(linmod.onepred.noint.keep$y) == class(linmod.form.Volume.trees.keep$y)) > stopifnot(all(dim(linmod.onepred.noint.keep$data) == dim(linmod.form.Volume.trees.keep$data))) > stopifnot(all(linmod.onepred.noint.keep$data == linmod.form.Volume.trees.keep$data)) > > # check method functions in one predictor no-intercept model > stopifnot(almost.equal(coef(linmod.onepred.noint), coef(lm.onepred.noint))) > stopifnot(identical(names(coef(linmod.onepred.noint)), names(coef(lm.onepred.noint)))) > stopifnot(almost.equal(fitted(linmod.onepred.noint), fitted(lm.onepred.noint))) > stopifnot(identical(names(fitted(linmod.onepred.noint)), names(fitted(lm.onepred.noint)))) > stopifnot(identical(na.action(linmod.onepred.noint), na.action(lm.onepred.noint))) > stopifnot(almost.equal(residuals(linmod.onepred.noint), residuals(lm.onepred.noint))) > stopifnot(identical(names(residuals(linmod.onepred.noint)), names(residuals(lm.onepred.noint)))) > stopifnot(identical(case.names(linmod.onepred.noint), case.names(lm.onepred.noint))) > stopifnot(identical(variable.names(linmod.onepred.noint), variable.names(lm.onepred.noint))) > stopifnot(identical(nobs(linmod.onepred.noint), nobs(lm.onepred.noint))) > stopifnot(identical(weights(linmod.onepred.noint), weights(lm.onepred.noint))) > stopifnot(almost.equal(df.residual(linmod.onepred.noint), df.residual(lm.onepred.noint))) > stopifnot(identical(names(df.residual(linmod.onepred.noint)), names(df.residual(lm.onepred.noint)))) > stopifnot(almost.equal(deviance(linmod.onepred.noint), deviance(lm.onepred.noint))) > stopifnot(identical(names(deviance(linmod.onepred.noint)), names(deviance(lm.onepred.noint)))) > stopifnot(identical(weights(linmod.onepred.noint), weights(lm.onepred.noint))) > stopifnot(identical(model.frame(linmod.onepred.noint), model.frame(lm.onepred.noint))) > stopifnot(identical(model.matrix(linmod.onepred.noint), model.matrix(lm.onepred.noint))) > stopifnot(identical(model.matrix(linmod.onepred.noint, data=tr[1:2,]), + model.matrix(lm.onepred.noint, data=tr[1:2,]))) > stopifnot(almost.equal(logLik(linmod.onepred.noint), logLik(lm.onepred.noint))) > stopifnot(almost.equal(estfun(linmod.onepred.noint), estfun(lm.onepred.noint))) > > # check error messages with bad newdata in one predictor no-intercept model > expect.err(try(predict(linmod.onepred.noint, newdata=99)), "object 'Girth' not found") Error in eval(predvars, data, env) : object 'Girth' not found Got expected error from try(predict(linmod.onepred.noint, newdata = 99)) > expect.err(try(predict(linmod.onepred.noint, newdata=data.frame(Girth=NA))), "NA in 'newdata'") Error in process.newdata.formula(object, newdata) : NA in 'newdata' Got expected error from try(predict(linmod.onepred.noint, newdata = data.frame(Girth = NA))) > expect.err(try(predict(linmod.onepred.noint, newdata=trees[0,1])), "'newdata' is empty") Error in predict.linmod(linmod.onepred.noint, newdata = trees[0, 1]) : 'newdata' is empty Got expected error from try(predict(linmod.onepred.noint, newdata = trees[0, 1])) > expect.err(try(predict(linmod.onepred.noint, newdata=trees[3:5,"Height"])), "object 'Girth' not found") Error in eval(predvars, data, env) : object 'Girth' not found Got expected error from try(predict(linmod.onepred.noint, newdata = trees[3:5, "Height"])) > # check that extra fields in predict newdata are ok with (formula) models without intercept > stopifnot(almost.equal(predict(linmod.onepred.noint, newdata=data.frame(Girth=10, extra=99)), + predict(lm.onepred.noint, newdata=data.frame(Girth=10, extra=99)))) > > par(mfrow=c(2,2)) > plot(linmod.onepred.noint) > plot(lm.onepred.noint, which=1, main="lm.onepred.noint") > par(org.par) > > plotres(linmod.onepred.noint) > plotmo(linmod.onepred.noint) > > expect.err(try(linmod(Volume~nonesuch, data=trees)), "object 'nonesuch' not found") Error in eval(predvars, data, env) : object 'nonesuch' not found Got expected error from try(linmod(Volume ~ nonesuch, data = trees)) > expect.err(try(linmod(Volume~0, data=trees)), "'x' is empty") # no predictor Error in check.linmod.x(x) : 'x' is empty Got expected error from try(linmod(Volume ~ 0, data = trees)) > expect.err(try(linmod(Volume~-1, data=trees)), "'x' is empty") # no predictor, no intercept Error in check.linmod.x(x) : 'x' is empty Got expected error from try(linmod(Volume ~ -1, data = trees)) > > cat0("==check model with many variables\n") ==check model with many variables > > set.seed(2018) > p <- 300 # number of variables > n <- floor(1.1 * p) > bigdat <- as.data.frame(matrix(rnorm(n * (p+1)), ncol=p+1)) > colnames(bigdat) <- c("y", paste0("var", 1:p)) > lm.bigdat <- lm(y~., data=bigdat) > linmod.bigdat <- linmod(y~., data=bigdat) > check.lm(linmod.form.Volume.tr, lm.Volume.tr) check linmod.form.Volume.tr vs lm.Volume.tr > print(linmod.bigdat) Call: linmod.formula(formula = y ~ ., data = bigdat) (Intercept) var1 var2 var3 var4 -0.0074874141 -0.0156168166 -0.0323375299 -0.0680410620 -0.1784176655 var5 var6 var7 var8 var9 0.0970839766 -0.2420079781 0.0068052116 0.0605142551 0.1563114625 var10 var11 var12 var13 var14 -0.0705547201 0.0661388031 0.0753290388 -0.0595687675 -0.1972523829 var15 var16 var17 var18 var19 -0.0928371617 0.1400015667 0.0349750202 0.0990295749 -0.0806465990 var20 var21 var22 var23 var24 -0.0005353688 -0.1384821496 -0.0405121324 -0.0181462061 -0.2133498970 var25 var26 var27 var28 var29 -0.0186244683 -0.2593737746 -0.0589964475 -0.0537252842 -0.0594401821 var30 var31 var32 var33 var34 0.0934989343 0.0244371962 0.1403544230 0.2619465745 0.0159354057 var35 var36 var37 var38 var39 -0.0210109954 -0.0328618036 -0.1371912460 -0.0649163643 0.0595217563 var40 var41 var42 var43 var44 -0.0682175594 -0.1103821881 -0.0508841621 -0.1392364303 -0.0103981103 var45 var46 var47 var48 var49 -0.1196682294 -0.1534327142 -0.0754141872 0.1426175022 0.0011406008 var50 var51 var52 var53 var54 0.0379811394 0.0320275730 -0.0532598495 -0.1410085314 0.1519143039 var55 var56 var57 var58 var59 -0.0228233810 0.3170130760 -0.1044797851 -0.0035954154 0.1479556565 var60 var61 var62 var63 var64 0.0122428193 -0.0253431378 -0.0180440355 -0.1794590898 0.0131447015 var65 var66 var67 var68 var69 -0.1720319639 0.1526605311 0.0771868987 -0.2418787630 0.0447156252 var70 var71 var72 var73 var74 -0.1105368627 0.0567936200 0.0424605198 -0.0881098654 0.0092876782 var75 var76 var77 var78 var79 -0.0716540798 -0.1255361536 -0.0071680571 -0.1208344391 -0.0735928839 var80 var81 var82 var83 var84 0.2324224976 -0.1849522151 0.0694052039 0.1390729406 -0.0617270270 var85 var86 var87 var88 var89 0.0850926211 0.1221016487 0.0233354163 0.0075718550 -0.0032554103 var90 var91 var92 var93 var94 0.1209443561 0.2292860177 0.1347583831 0.0781827877 -0.1541547464 var95 var96 var97 var98 var99 0.1337171223 -0.1163422961 -0.0966724692 -0.2182129213 -0.1204830968 var100 var101 var102 var103 var104 -0.0619465323 -0.1113710701 0.0594579753 0.0955361014 -0.0519687498 var105 var106 var107 var108 var109 -0.0346599073 0.2181197633 0.0332996851 -0.0969131172 0.1736014017 var110 var111 var112 var113 var114 -0.1714974837 -0.0056002152 0.1393566962 -0.0972988693 0.0475762687 var115 var116 var117 var118 var119 0.2364360899 -0.0985131354 -0.0894394214 -0.2355018204 0.0025381197 var120 var121 var122 var123 var124 -0.1427340796 -0.0565016310 -0.0455466677 0.1579742783 0.1290270638 var125 var126 var127 var128 var129 0.0735269010 -0.0074354274 -0.0202350963 0.0921409434 0.0578351619 var130 var131 var132 var133 var134 0.0457446540 -0.0497481279 -0.0716169797 -0.0834890066 0.0078486400 var135 var136 var137 var138 var139 0.0569885547 -0.0880888941 0.0931535379 0.0029921816 0.0215558011 var140 var141 var142 var143 var144 0.0379439385 0.1288009147 -0.0627699322 0.1471235930 0.0418985129 var145 var146 var147 var148 var149 0.1581333558 0.2109672906 -0.1305882685 0.1715603371 -0.0674028658 var150 var151 var152 var153 var154 -0.1809329622 -0.0618254790 -0.0644645613 -0.0185217288 0.0963509748 var155 var156 var157 var158 var159 0.0669555139 0.1341679917 0.0014091507 0.1912096659 0.1049270995 var160 var161 var162 var163 var164 0.1407325985 -0.0149350788 -0.1567496204 0.0881458138 -0.0429862791 var165 var166 var167 var168 var169 0.0080105136 -0.0374778798 0.1385838635 -0.0734288141 -0.1266495195 var170 var171 var172 var173 var174 0.0071467393 -0.0255859731 0.1516581037 -0.2106472762 -0.0308347530 var175 var176 var177 var178 var179 0.0076295054 0.1793572809 0.1064141211 0.0906223259 0.0435110825 var180 var181 var182 var183 var184 -0.1264325305 -0.0968032660 0.1430811907 0.0307419406 -0.0319429988 var185 var186 var187 var188 var189 0.0461719964 -0.2385322379 0.0850810205 0.3949689631 0.1245166753 var190 var191 var192 var193 var194 0.1720563316 0.2144640136 0.0501975420 0.1174708714 -0.1943912402 var195 var196 var197 var198 var199 0.0202300723 0.0210580247 0.0726236855 0.1064539412 -0.0767767634 var200 var201 var202 var203 var204 -0.0624521254 0.0028300645 -0.1715330103 0.2115665862 0.0338181429 var205 var206 var207 var208 var209 0.0167958834 -0.0590878112 -0.1653100651 -0.0740487318 -0.0043391023 var210 var211 var212 var213 var214 0.3393487726 0.2223498489 0.0213281741 0.2230110595 -0.1228075434 var215 var216 var217 var218 var219 -0.0104634410 0.0326754989 -0.4439139348 -0.1087432871 -0.0107897918 var220 var221 var222 var223 var224 -0.0296175151 0.1091241015 0.0909297736 -0.3485310127 0.0832890933 var225 var226 var227 var228 var229 -0.0042697108 0.0593458113 -0.0182956931 0.0572344159 -0.1231669279 var230 var231 var232 var233 var234 0.0492497234 -0.2862525037 0.1834105207 0.2081280243 0.1641204059 var235 var236 var237 var238 var239 0.2472694582 0.0683823801 0.1891842675 -0.0489319878 0.1490499844 var240 var241 var242 var243 var244 -0.0095798604 0.0721964545 -0.0126839937 -0.2221525719 -0.0829084901 var245 var246 var247 var248 var249 -0.0318090335 -0.0425994225 0.0033944363 0.0984076551 -0.2148911884 var250 var251 var252 var253 var254 -0.1875432344 -0.1735721485 0.2886948591 0.1467087046 -0.0834815473 var255 var256 var257 var258 var259 -0.0635576566 -0.0346030600 -0.1224921370 -0.2423169128 -0.0021922047 var260 var261 var262 var263 var264 -0.0818789537 -0.0707600938 -0.3301726263 -0.2602526557 -0.1427837485 var265 var266 var267 var268 var269 -0.1315034492 0.1292166855 0.0265412839 0.1111883441 0.1302021867 var270 var271 var272 var273 var274 -0.0923837589 -0.0680064479 -0.1776069310 -0.0374118346 0.0877037245 var275 var276 var277 var278 var279 -0.0016240717 0.1670149940 0.1542172653 -0.0108006893 0.1334885400 var280 var281 var282 var283 var284 0.1637485211 0.0649039066 -0.0277897733 0.1978208690 0.0984930229 var285 var286 var287 var288 var289 -0.1113854013 0.0770616839 -0.0634971052 0.1652137421 -0.0984475187 var290 var291 var292 var293 var294 0.1166070472 -0.0682754836 0.1016526112 -0.2976518291 -0.1119627963 var295 var296 var297 var298 var299 0.2734232937 -0.1054927068 -0.2151298321 0.0208265210 0.0882009038 var300 0.1604547308 > print(summary(linmod.bigdat)) Call: linmod.formula(formula = y ~ ., data = bigdat) Estimate StdErr t.value p.value (Intercept) -0.0074874141 0.1800205 -0.041592015 0.9671090 var1 -0.0156168166 0.2371393 -0.065855031 0.9479451 var2 -0.0323375299 0.2074053 -0.155914683 0.8771805 var3 -0.0680410620 0.2135121 -0.318675467 0.7522565 var4 -0.1784176655 0.2765676 -0.645114193 0.5239245 var5 0.0970839766 0.2705479 0.358842112 0.7223126 var6 -0.2420079781 0.2227204 -1.086599878 0.2861632 var7 0.0068052116 0.2638035 0.025796522 0.9795963 var8 0.0605142551 0.2672763 0.226410883 0.8224702 var9 0.1563114625 0.2173700 0.719103064 0.4778324 var10 -0.0705547201 0.2298045 -0.307020683 0.7610215 var11 0.0661388031 0.2511706 0.263322181 0.7941642 var12 0.0753290388 0.2012531 0.374300073 0.7109041 var13 -0.0595687675 0.3550150 -0.167792238 0.8679114 var14 -0.1972523829 0.2246975 -0.877857612 0.3872362 var15 -0.0928371617 0.2113127 -0.439335409 0.6636749 var16 0.1400015667 0.2435983 0.574723062 0.5699107 var17 0.0349750202 0.1917603 0.182389223 0.8565463 var18 0.0990295749 0.2216047 0.446874974 0.6582850 var19 -0.0806465990 0.1909595 -0.422323087 0.6759040 var20 -0.0005353688 0.2338494 -0.002289374 0.9981890 var21 -0.1384821496 0.2015467 -0.687097048 0.4974799 var22 -0.0405121324 0.2477545 -0.163517220 0.8712455 var23 -0.0181462061 0.2375000 -0.076405072 0.9396215 var24 -0.2133498970 0.2363631 -0.902636318 0.3741555 var25 -0.0186244683 0.2254941 -0.082594047 0.9347418 var26 -0.2593737746 0.2564927 -1.011232508 0.3202685 var27 -0.0589964475 0.2340174 -0.252102832 0.8027398 var28 -0.0537252842 0.2245610 -0.239245826 0.8125978 var29 -0.0594401821 0.2027951 -0.293104596 0.7715294 var30 0.0934989343 0.2367895 0.394860933 0.6958348 var31 0.0244371962 0.3424643 0.071356924 0.9436035 var32 0.1403544230 0.2135245 0.657322481 0.5161571 var33 0.2619465745 0.2640503 0.992032890 0.3293872 var34 0.0159354057 0.2044152 0.077956052 0.9383984 var35 -0.0210109954 0.2844938 -0.073853956 0.9416337 var36 -0.0328618036 0.2399793 -0.136936018 0.8920276 var37 -0.1371912460 0.2537454 -0.540664966 0.5928674 var38 -0.0649163643 0.1799295 -0.360787712 0.7208731 var39 0.0595217563 0.2022310 0.294325542 0.7706057 var40 -0.0682175594 0.2554638 -0.267034184 0.7913327 var41 -0.1103821881 0.2331126 -0.473514393 0.6393915 var42 -0.0508841621 0.2752612 -0.184857767 0.8546273 var43 -0.1392364303 0.2495550 -0.557938843 0.5811682 var44 -0.0103981103 0.2209398 -0.047063086 0.9627856 var45 -0.1196682294 0.3048932 -0.392492323 0.6975645 var46 -0.1534327142 0.2572114 -0.596523861 0.5554538 var47 -0.0754141872 0.2600154 -0.290037393 0.7738514 var48 0.1426175022 0.2254117 0.632697751 0.5318886 var49 0.0011406008 0.2120596 0.005378679 0.9957453 var50 0.0379811394 0.2310918 0.164355174 0.8705918 var51 0.0320275730 0.2767792 0.115715247 0.9086758 var52 -0.0532598495 0.2458433 -0.216641439 0.8300046 var53 -0.1410085314 0.1977205 -0.713171114 0.4814399 var54 0.1519143039 0.2314816 0.656269545 0.5168246 var55 -0.0228233810 0.2350910 -0.097083173 0.9233282 var56 0.3170130760 0.3614265 0.877116184 0.3876321 var57 -0.1044797851 0.2183847 -0.478420881 0.6359379 var58 -0.0035954154 0.2751337 -0.013067882 0.9896631 var59 0.1479556565 0.2123298 0.696820184 0.4914637 var60 0.0122428193 0.2293630 0.053377487 0.9577972 var61 -0.0253431378 0.2313604 -0.109539665 0.9135290 var62 -0.0180440355 0.1981508 -0.091062144 0.9280693 var63 -0.1794590898 0.1901054 -0.943998047 0.3529695 var64 0.0131447015 0.2083418 0.063092011 0.9501261 var65 -0.1720319639 0.2428857 -0.708283494 0.4844239 var66 0.1526605311 0.2147799 0.710776774 0.4829003 var67 0.0771868987 0.3130362 0.246575008 0.8069742 var68 -0.2418787630 0.2493599 -0.969998540 0.3400684 var69 0.0447156252 0.2115566 0.211364798 0.8340810 var70 -0.1105368627 0.1705161 -0.648248782 0.5219242 var71 0.0567936200 0.2117084 0.268263375 0.7903957 var72 0.0424605198 0.2223151 0.190992539 0.8498623 var73 -0.0881098654 0.2502169 -0.352133982 0.7272839 var74 0.0092876782 0.1725946 0.053812095 0.9574539 var75 -0.0716540798 0.2042502 -0.350815262 0.7282627 var76 -0.1255361536 0.2032681 -0.617588945 0.5416660 var77 -0.0071680571 0.2245031 -0.031928539 0.9747478 var78 -0.1208344391 0.2171811 -0.556376521 0.5822217 var79 -0.0735928839 0.2758883 -0.266748816 0.7915503 var80 0.2324224976 0.2178554 1.066865690 0.2948340 var81 -0.1849522151 0.2494518 -0.741434562 0.4643923 var82 0.0694052039 0.2244402 0.309236945 0.7593522 var83 0.1390729406 0.2408728 0.577370810 0.5681449 var84 -0.0617270270 0.2172721 -0.284100080 0.7783524 var85 0.0850926211 0.2263187 0.375985799 0.7096640 var86 0.1221016487 0.2563207 0.476362843 0.6373855 var87 0.0233354163 0.1872097 0.124648512 0.9016619 var88 0.0075718550 0.1673231 0.045252884 0.9642159 var89 -0.0032554103 0.1788632 -0.018200555 0.9856035 var90 0.1209443561 0.2560722 0.472305640 0.6402436 var91 0.2292860177 0.1858306 1.233844321 0.2271674 var92 0.1347583831 0.2565987 0.525171749 0.6034562 var93 0.0781827877 0.2780298 0.281202951 0.7805515 var94 -0.1541547464 0.2788393 -0.552844434 0.5846067 var95 0.1337171223 0.2598042 0.514684249 0.6106743 var96 -0.1163422961 0.2154543 -0.539986000 0.5933295 var97 -0.0966724692 0.1949970 -0.495763812 0.6237974 var98 -0.2182129213 0.2123535 -1.027592541 0.3126367 var99 -0.1204830968 0.2005145 -0.600869627 0.5525946 var100 -0.0619465323 0.1976115 -0.313476390 0.7561624 var101 -0.1113710701 0.2468408 -0.451185779 0.6552116 var102 0.0594579753 0.2864292 0.207583470 0.8370051 var103 0.0955361014 0.2438856 0.391725115 0.6981251 var104 -0.0519687498 0.1991270 -0.260982906 0.7959502 var105 -0.0346599073 0.2657151 -0.130440121 0.8971189 var106 0.2181197633 0.2335975 0.933741705 0.3581471 var107 0.0332996851 0.2262542 0.147178175 0.8840098 var108 -0.0969131172 0.2404953 -0.402973070 0.6899235 var109 0.1736014017 0.2382727 0.728582793 0.4720999 var110 -0.1714974837 0.2789115 -0.614881303 0.5434281 var111 -0.0056002152 0.2405138 -0.023284378 0.9815829 var112 0.1393566962 0.2713318 0.513602510 0.6114211 var113 -0.0972988693 0.2237430 -0.434868813 0.6668767 var114 0.0475762687 0.2010286 0.236664132 0.8145811 var115 0.2364360899 0.1812356 1.304578743 0.2022950 var116 -0.0985131354 0.1918563 -0.513473612 0.6115102 var117 -0.0894394214 0.2173996 -0.411405563 0.6837999 var118 -0.2355018204 0.2043250 -1.152584287 0.2584937 var119 0.0025381197 0.2468950 0.010280159 0.9918682 var120 -0.1427340796 0.2098195 -0.680270750 0.5017283 var121 -0.0565016310 0.2247369 -0.251412320 0.8032684 var122 -0.0455466677 0.2003293 -0.227358982 0.8217399 var123 0.1579742783 0.2883202 0.547912675 0.5879449 var124 0.1290270638 0.2496442 0.516843926 0.6091846 var125 0.0735269010 0.2161412 0.340180001 0.7361728 var126 -0.0074354274 0.2214263 -0.033579687 0.9734424 var127 -0.0202350963 0.2301697 -0.087913801 0.9305495 var128 0.0921409434 0.1946116 0.473460579 0.6394294 var129 0.0578351619 0.1972534 0.293202402 0.7714554 var130 0.0457446540 0.1811477 0.252526816 0.8024152 var131 -0.0497481279 0.2395549 -0.207669049 0.8369389 var132 -0.0716169797 0.2264069 -0.316319726 0.7540255 var133 -0.0834890066 0.2330487 -0.358247063 0.7227531 var134 0.0078486400 0.2177636 0.036042020 0.9714958 var135 0.0569885547 0.2341690 0.243365105 0.8094359 var136 -0.0880888941 0.2153686 -0.409014568 0.6855340 var137 0.0931535379 0.2469843 0.377163735 0.7087980 var138 0.0029921816 0.2751486 0.010874785 0.9913978 var139 0.0215558011 0.2147867 0.100359093 0.9207499 var140 0.0379439385 0.2406773 0.157654833 0.8758214 var141 0.1288009147 0.2085225 0.617683396 0.5416046 var142 -0.0627699322 0.2098144 -0.299168892 0.7669448 var143 0.1471235930 0.2412491 0.609841087 0.5467163 var144 0.0418985129 0.2434882 0.172076181 0.8645729 var145 0.1581333558 0.2214480 0.714088092 0.4808812 var146 0.2109672906 0.2233900 0.944389874 0.3527727 var147 -0.1305882685 0.2529765 -0.516207076 0.6096237 var148 0.1715603371 0.2701917 0.634957851 0.5304342 var149 -0.0674028658 0.2036219 -0.331019746 0.7430096 var150 -0.1809329622 0.2498705 -0.724106996 0.4748015 var151 -0.0618254790 0.2176185 -0.284100247 0.7783522 var152 -0.0644645613 0.2754214 -0.234057917 0.8165845 var153 -0.0185217288 0.2208211 -0.083876614 0.9337309 var154 0.0963509748 0.2313142 0.416537290 0.6800839 var155 0.0669555139 0.1933443 0.346302031 0.7316158 var156 0.1341679917 0.2524602 0.531442178 0.5991599 var157 0.0014091507 0.2640273 0.005337141 0.9957781 var158 0.1912096659 0.1695380 1.127827842 0.2686376 var159 0.1049270995 0.2414864 0.434505156 0.6671377 var160 0.1407325985 0.2455352 0.573166587 0.5709501 var161 -0.0149350788 0.2301044 -0.064905660 0.9486945 var162 -0.1567496204 0.2009329 -0.780109241 0.4416476 var163 0.0881458138 0.1865732 0.472446196 0.6401445 var164 -0.0429862791 0.1842946 -0.233247688 0.8172076 var165 0.0080105136 0.2145006 0.037344952 0.9704659 var166 -0.0374778798 0.2318411 -0.161653296 0.8726999 var167 0.1385838635 0.2867304 0.483324640 0.6324945 var168 -0.0734288141 0.3050426 -0.240716561 0.8114685 var169 -0.1266495195 0.2501795 -0.506234633 0.6165190 var170 0.0071467393 0.2711878 0.026353468 0.9791559 var171 -0.0255859731 0.1960230 -0.130525331 0.8970520 var172 0.1516581037 0.2794876 0.542629017 0.5915315 var173 -0.2106472762 0.2586949 -0.814269164 0.4221271 var174 -0.0308347530 0.1917615 -0.160797399 0.8733679 var175 0.0076295054 0.3046328 0.025044924 0.9801907 var176 0.1793572809 0.2037214 0.880404570 0.3858783 var177 0.1064141211 0.2557243 0.416128313 0.6803797 var178 0.0906223259 0.1983712 0.456832105 0.6511953 var179 0.0435110825 0.2579405 0.168686498 0.8672143 var180 -0.1264325305 0.2161180 -0.585016152 0.5630615 var181 -0.0968032660 0.2302398 -0.420445421 0.6772593 var182 0.1430811907 0.2453891 0.583078722 0.5643475 var183 0.0307419406 0.2604510 0.118033506 0.9068549 var184 -0.0319429988 0.2463878 -0.129645214 0.8977422 var185 0.0461719964 0.2008406 0.229893732 0.8197882 var186 -0.2385322379 0.2385500 -0.999925395 0.3256175 var187 0.0850810205 0.2238337 0.380108258 0.7066348 var188 0.3949689631 0.2554732 1.546028733 0.1329419 var189 0.1245166753 0.2747638 0.453177206 0.6537938 var190 0.1720563316 0.1879732 0.915323611 0.3675705 var191 0.2144640136 0.2413709 0.888524686 0.3815695 var192 0.0501975420 0.2506340 0.200282260 0.8426578 var193 0.1174708714 0.1746616 0.672562616 0.5065496 var194 -0.1943912402 0.3087673 -0.629571991 0.5339036 var195 0.0202300723 0.1915222 0.105627803 0.9166049 var196 0.0210580247 0.2176811 0.096737972 0.9235999 var197 0.0726236855 0.2177147 0.333572658 0.7411020 var198 0.1064539412 0.2261034 0.470819639 0.6412918 var199 -0.0767767634 0.2594113 -0.295965345 0.7693656 var200 -0.0624521254 0.2431441 -0.256852333 0.7991064 var201 0.0028300645 0.2063768 0.013713095 0.9891528 var202 -0.1715330103 0.2434880 -0.704482359 0.4867518 var203 0.2115665862 0.2486851 0.850740856 0.4018833 var204 0.0338181429 0.2280774 0.148274859 0.8831521 var205 0.0167958834 0.2489778 0.067459374 0.9466790 var206 -0.0590878112 0.1959422 -0.301557386 0.7651414 var207 -0.1653100651 0.2678547 -0.617163149 0.5419429 var208 -0.0740487318 0.2976417 -0.248784829 0.8052807 var209 -0.0043391023 0.2286282 -0.018978862 0.9849879 var210 0.3393487726 0.2358674 1.438726974 0.1609341 var211 0.2223498489 0.2661974 0.835281675 0.4103882 var212 0.0213281741 0.2315918 0.092093805 0.9272568 var213 0.2230110595 0.2581936 0.863735666 0.3948210 var214 -0.1228075434 0.2065047 -0.594696099 0.5566586 var215 -0.0104634410 0.2454306 -0.042632989 0.9662863 var216 0.0326754989 0.1978876 0.165121515 0.8699940 var217 -0.4439139348 0.3244134 -1.368358977 0.1817084 var218 -0.1087432871 0.2499652 -0.435033655 0.6667585 var219 -0.0107897918 0.2111081 -0.051110265 0.9595881 var220 -0.0296175151 0.2005449 -0.147685200 0.8836133 var221 0.1091241015 0.2479581 0.440090806 0.6631341 var222 0.0909297736 0.2382558 0.381647734 0.7055049 var223 -0.3485310127 0.2994113 -1.164054343 0.2538897 var224 0.0832890933 0.2243884 0.371182680 0.7131995 var225 -0.0042697108 0.3003295 -0.014216755 0.9887544 var226 0.0593458113 0.2310813 0.256817880 0.7991327 var227 -0.0182956931 0.1938017 -0.094404189 0.9254374 var228 0.0572344159 0.2343684 0.244207074 0.8087900 var229 -0.1231669279 0.2605563 -0.472707582 0.6399602 var230 0.0492497234 0.2111087 0.233290802 0.8171745 var231 -0.2862525037 0.1914503 -1.495179287 0.1456712 var232 0.1834105207 0.1939787 0.945519089 0.3522060 var233 0.2081280243 0.1632040 1.275263095 0.2123381 var234 0.1641204059 0.2272942 0.722061495 0.4760391 var235 0.2472694582 0.1902445 1.299745561 0.2039253 var236 0.0683823801 0.2231440 0.306449594 0.7614518 var237 0.1891842675 0.2214505 0.854295987 0.3999433 var238 -0.0489319878 0.2340164 -0.209096383 0.8358349 var239 0.1490499844 0.2429465 0.613509393 0.5443221 var240 -0.0095798604 0.2533123 -0.037818383 0.9700916 var241 0.0721964545 0.1969929 0.366492592 0.7166580 var242 -0.0126839937 0.2087745 -0.060754522 0.9519715 var243 -0.2221525719 0.1983111 -1.120222514 0.2718109 var244 -0.0829084901 0.2055738 -0.403302790 0.6896837 var245 -0.0318090335 0.2292748 -0.138737596 0.8906165 var246 -0.0425994225 0.2283779 -0.186530377 0.8533276 var247 0.0033944363 0.2129927 0.015936864 0.9873939 var248 0.0984076551 0.2343675 0.419886173 0.6776632 var249 -0.2148911884 0.2120962 -1.013177766 0.3193544 var250 -0.1875432344 0.2503294 -0.749185930 0.4597794 var251 -0.1735721485 0.2906428 -0.597200849 0.5550079 var252 0.2886948591 0.2512542 1.149015262 0.2599386 var253 0.1467087046 0.2485217 0.590325564 0.5595449 var254 -0.0834815473 0.2384597 -0.350086644 0.7288036 var255 -0.0635576566 0.2733631 -0.232502667 0.8177807 var256 -0.0346030600 0.3391339 -0.102033634 0.9194322 var257 -0.1224921370 0.1991311 -0.615133252 0.5432640 var258 -0.2423169128 0.2163175 -1.120191176 0.2718240 var259 -0.0021922047 0.2169919 -0.010102701 0.9920085 var260 -0.0818789537 0.2213754 -0.369864799 0.7141707 var261 -0.0707600938 0.2111357 -0.335140308 0.7399315 var262 -0.3301726263 0.2521985 -1.309177801 0.2007530 var263 -0.2602526557 0.2351244 -1.106872336 0.2774464 var264 -0.1427837485 0.2547866 -0.560405290 0.5795071 var265 -0.1315034492 0.2038109 -0.645222811 0.5238552 var266 0.1292166855 0.1857550 0.695629819 0.4921980 var267 0.0265412839 0.2291648 0.115817440 0.9085955 var268 0.1111883441 0.2630197 0.422737718 0.6756049 var269 0.1302021867 0.2400981 0.542287436 0.5917637 var270 -0.0923837589 0.2552903 -0.361877334 0.7200673 var271 -0.0680064479 0.2072222 -0.328181232 0.7451325 var272 -0.1776069310 0.2287416 -0.776452095 0.4437692 var273 -0.0374118346 0.2277425 -0.164272515 0.8706562 var274 0.0877037245 0.2180473 0.402223481 0.6904689 var275 -0.0016240717 0.2913139 -0.005574988 0.9955900 var276 0.1670149940 0.2327284 0.717639018 0.4787213 var277 0.1542172653 0.2293724 0.672344500 0.5066864 var278 -0.0108006893 0.2634879 -0.040991220 0.9675838 var279 0.1334885400 0.2086489 0.639775940 0.5273407 var280 0.1637485211 0.2134740 0.767065523 0.4492427 var281 0.0649039066 0.1972117 0.329107849 0.7444393 var282 -0.0277897733 0.2630854 -0.105630223 0.9166030 var283 0.1978208690 0.1913322 1.033913324 0.3097222 var284 0.0984930229 0.2972660 0.331329592 0.7427780 var285 -0.1113854013 0.2238975 -0.497483952 0.6225990 var286 0.0770616839 0.2067096 0.372801690 0.7120070 var287 -0.0634971052 0.2337652 -0.271627762 0.7878326 var288 0.1652137421 0.2168261 0.761964380 0.4522341 var289 -0.0984475187 0.2827889 -0.348130788 0.7302565 var290 0.1166070472 0.1940659 0.600863259 0.5525988 var291 -0.0682754836 0.2270118 -0.300757444 0.7657452 var292 0.1016526112 0.2081493 0.488363972 0.6289646 var293 -0.2976518291 0.2175924 -1.367932916 0.1818403 var294 -0.1119627963 0.2411543 -0.464278710 0.6459147 var295 0.2734232937 0.2291048 1.193442092 0.2423685 var296 -0.1054927068 0.2409970 -0.437734561 0.6648217 var297 -0.2151298321 0.3031934 -0.709546479 0.4836518 var298 0.0208265210 0.2160796 0.096383564 0.9238789 var299 0.0882009038 0.2477594 0.355994206 0.7244217 var300 0.1604547308 0.2218983 0.723100206 0.4754104 > expect.err(try(predict(linmod.bigdat, newdata=bigdat[,1:(p-3)])), "object 'var297' not found") Error in eval(predvars, data, env) : object 'var297' not found Got expected error from try(predict(linmod.bigdat, newdata = bigdat[, 1:(p - 3)])) > plot(linmod.bigdat) > # plotmo(linmod.bigdat) # works, but commented out because slow(ish) > # plotres(linmod.bigdat) # ditto > > cat0("==check use of matrix as data in linmod.form\n") ==check use of matrix as data in linmod.form > # linmod.form allows a matrix, lm doesn't TODO is this inconsistency what we want? > tr.mat <- as.matrix(tr) > cat0("class(tr.mat)=", class(tr.mat), "\n") # class(tr.mat)=matrix class(tr.mat)=matrixarray > expect.err(try(lm(Volume~., data=tr.mat)), "'data' must be a data.frame, not a matrix or an array") Error in model.frame.default(formula = Volume ~ ., data = tr.mat, drop.unused.levels = TRUE) : 'data' must be a data.frame, not a matrix or an array Got expected error from try(lm(Volume ~ ., data = tr.mat)) > linmod.form.Volume.mat.tr <- linmod(Volume~., data=tr.mat) > check.lm(linmod.form.Volume.mat.tr, linmod.form.Volume.tr) check linmod.form.Volume.mat.tr vs linmod.form.Volume.tr > cat0("==print(summary(linmod.form.Volume.mat.tr))\n") ==print(summary(linmod.form.Volume.mat.tr)) > print(summary(linmod.form.Volume.mat.tr)) Call: linmod.formula(formula = Volume ~ ., data = tr.mat) Estimate StdErr t.value p.value (Intercept) -57.9876589 8.6382259 -6.712913 2.749507e-07 Girth 4.7081605 0.2642646 17.816084 8.223304e-17 Height 0.3392512 0.1301512 2.606594 1.449097e-02 > plotres(linmod.form.Volume.mat.tr) > > tr.mat.no.colnames <- as.matrix(tr) > colnames(tr.mat.no.colnames) <- NULL > expect.err(try(linmod(Volume~., data=tr.mat.no.colnames)), "object 'Volume' not found") Error in eval(predvars, data, env) : object 'Volume' not found Got expected error from try(linmod(Volume ~ ., data = tr.mat.no.colnames)) > linmod.form.Volume.mat.tr.no.colnames <- linmod(V3~., data=tr.mat.no.colnames) > check.lm(linmod.form.Volume.mat.tr.no.colnames, linmod.form.Volume.tr, + check.coef.names=FALSE, check.newdata=FALSE) # no check.newdata else object 'V1' not found check linmod.form.Volume.mat.tr.no.colnames vs linmod.form.Volume.tr > > # Check what happens when we change the original data used to build the model. > # Use plotres as an example function that must figure out residuals from predict(). > > pr <- function(model, main=deparse(substitute(model))) + { + plotres(model, which=3, main=main) # which=3 for just the residuals plot + } > cat0("==linmod.formula: change data used to build the model\n") ==linmod.formula: change data used to build the model > > trees1 <- trees > linmod.trees1 <- linmod(Volume~., data=trees1) > # delete the saved residuals and fitted.values so plotres has to use the saved > # call etc. to get the x and y used to build the model, and rely on predict() > linmod.trees1$residuals <- NULL > linmod.trees1$fitted.values <- NULL > par(mfrow=c(3,3)) > pr(linmod.trees1) > trees1 <- trees[, 3:1] # change column order in original data > pr(linmod.trees1, "change col order") > trees1 <- trees[1:3, ] # change number of rows in original data > pr(linmod.trees1, "change nbr rows") # TODO wrong residuals! (lm has the same issue) > cat("call$data now refers to the changed data:\n") # lm has the same problem if called with model=FALSE call$data now refers to the changed data: > print(eval(linmod.trees1$call$data)) Girth Height Volume 1 8.3 70 10.3 2 8.6 65 10.3 3 8.8 63 10.2 > cat("model.frame now returns the changed data:\n") model.frame now returns the changed data: > print(model.frame(linmod.trees1)) Volume Girth Height 1 10.3 8.3 70 2 10.3 8.6 65 3 10.2 8.8 63 > trees1 <- trees[nrow(tr):1, ] # change row order (but keep same nbr of rows) > pr(linmod.trees1, "change row order") > colnames(trees1) <- c("x1", "x2", "x3") # change column names in original data > expect.err(try(pr(linmod.trees1, + "change colnames")), "cannot get the original model predictors") Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: object 'Volume' not found (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(pr(linmod.trees1, "change colnames")) > trees1 <- "garbage" > expect.err(try(pr(linmod.trees1, + "trees1=\"garbage\"")), "cannot get the original model predictors") Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: object 'Volume' not found (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(pr(linmod.trees1, "trees1=\"garbage\"")) > trees1 <- 1:1000 > expect.err(try(pr(linmod.trees1, + "trees1=1:1000")), "cannot get the original model predictors") Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: object 'Volume' not found (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(pr(linmod.trees1, "trees1=1:1000")) > trees1 <- NULL # original data no longer available > expect.err(try(pr(linmod.trees1, + "trees1=NULL")), "cannot get the original model predictors") Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: object 'Volume' not found (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(pr(linmod.trees1, "trees1=NULL")) > remove(trees1) > expect.err(try(pr(linmod.trees1, + "remove(trees1)")), "cannot get the original model predictors") Error in eval(expr, envir, enclos) : object 'trees1' not found Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: object 'Volume' not found (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(pr(linmod.trees1, "remove(trees1)")) > > # similar to above, but don't delete the saved residuals and fitted.values > trees1 <- trees > linmod2.trees1 <- linmod(Volume~., data=trees1) > trees1 <- trees[1:3, ] # change number of rows in original data > expect.err(try(plotmo(linmod2.trees1)), "plotmo_y returned the wrong length (got 3 but expected 31)") Error : plotmo_y returned the wrong length (got 3 but expected 31) Got expected error from try(plotmo(linmod2.trees1)) > > par(org.par) > > cat0("==linmod.formula(keep=TRUE): change data used to build the model\n") ==linmod.formula(keep=TRUE): change data used to build the model > par(mfrow=c(3,3)) > trees1 <- trees > linmod.trees1.keep <- linmod(Volume~., data=trees1, keep=TRUE) > # delete the saved residuals and fitted.values so plotres has to use the saved > # call etc. to get the x and y used to build the model, and rely on predict() > linmod.trees1.keep$residuals <- NULL > linmod.trees1.keep$fitted.values <- NULL > pr(linmod.trees1.keep) > trees1 <- trees[, 3:1] # change column order in original data > pr(linmod.trees1.keep, "change col order") > trees1 <- trees[1:3, ] # change number of rows in original data > pr(linmod.trees1.keep, "change nbr rows") > trees1 <- trees[nrow(tr):1, ] # change row order (but keep same nbr of rows) > pr(linmod.trees1.keep, "change row order") > colnames(trees1) <- c("x1", "x2", "x3") # change column names in original data > pr(linmod.trees1.keep, "change colnames") > trees1 <- NULL # original data no longer available > pr(linmod.trees1.keep, "trees1=NULL") > remove(trees1) > pr(linmod.trees1.keep, "remove(trees1)") > par(org.par) > > cat0("==linmod.default: change data used to build the model\n") ==linmod.default: change data used to build the model > trees1 <- trees > x1 <- trees1[,1:2] > y1 <- trees1[,3] > linmod.xy <- linmod(x1, y1) > # delete the saved residuals and fitted.values so plotres has to use the saved > # call etc. to get the x1 and y1 used to build the model, and rely on predict() > linmod.xy$residuals <- NULL > linmod.xy$fitted.values <- NULL > par(mfrow=c(3,3)) > pr(linmod.xy) > x1 <- trees1[,2:1] # change column order in original x1 > pr(linmod.xy, "change col order") > x1 <- trees1[1:3, 1:2] # change number of rows in original x1 > expect.err(try(pr(linmod.xy, "change nbr rows")), + "plotmo_y returned the wrong length (got 31 but expected 3)") # TODO different behaviour to linmod.trees1 Error : plotmo_y returned the wrong length (got 31 but expected 3) Got expected error from try(pr(linmod.xy, "change nbr rows")) > cat("call$x1 now refers to the changed x1:\n") # lm has the same problem if called with model=FALSE call$x1 now refers to the changed x1: > print(eval(linmod.xy$call$x1)) NULL > x1 <- trees1[nrow(tr):1, 1:2] # change row order (but keep same nbr of rows) > pr(linmod.xy, "change row order") > x1 <- trees1[,1:2] > colnames(x1) <- c("x1", "x2") # change column names in original x1 > pr(linmod.xy, "change colnames") > x1 <- "garbage" > expect.err(try(pr(linmod.xy, "x1=\"garbage\"")), "cannot get the original model predictors") Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: no formula in getCall(object) (3) getCall(object)$x: garbage Error : cannot get the original model predictors Got expected error from try(pr(linmod.xy, "x1=\"garbage\"")) > x1 <- 1:1000 > expect.err(try(pr(linmod.xy, "x1=1:1000")), "ncol(newdata) is 1 but should be 2") stats::predict(linmod.object, data.frame[3,1], type="response") Error in predict.linmod(structure(list(coefficients = c(`(Intercept)` = -57.987658918381, : ncol(newdata) is 1 but should be 2 Got expected error from try(pr(linmod.xy, "x1=1:1000")) > x1 <- NULL # original x1 no longer available > expect.err(try(pr(linmod.xy, "x1=NULL")), "cannot get the original model predictors") Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: no formula in getCall(object) (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(pr(linmod.xy, "x1=NULL")) > remove(x1) > expect.err(try(pr(linmod.xy, "remove(x1)")), "cannot get the original model predictors") Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: no formula in getCall(object) (3) getCall(object)$x: object 'x1' not found Error : cannot get the original model predictors Got expected error from try(pr(linmod.xy, "remove(x1)")) > > # similar to above, but don't delete the saved residuals and fitted.values > trees1 <- trees > x1 <- trees1[,1:2] > y1 <- trees1[,3] > linmod.xy <- linmod(x1, y1) > x1 <- trees1[1:3, 1:2] # change number of rows in original x1 > expect.err(try(plotmo(linmod2.x1)), "object 'linmod2.x1' not found") # TODO error message misleading? Error : object 'linmod2.x1' not found Got expected error from try(plotmo(linmod2.x1)) > > par(org.par) > > cat0("==linmod.default(keep=TRUE): change data used to build the model\n") ==linmod.default(keep=TRUE): change data used to build the model > par(mfrow=c(3,3)) > trees1 <- trees > x1 <- trees1[,1:2] > linmod.xy <- linmod(x1, y1, keep=TRUE) > # delete the saved residuals and fitted.values so plotres has to use the saved > # call etc. to get the x1 and y1 used to build the model, and rely on predict() > linmod.xy$residuals <- NULL > linmod.xy$fitted.values <- NULL > pr(linmod.xy.keep) > x1 <- trees1[, 2:1] # change column order in original x1 > pr(linmod.xy.keep, "change col order") > x1 <- trees1[1:3, 1:2] # change number of rows in original x1 > pr(linmod.xy.keep, "change nbr rows") > x1 <- trees1[nrow(tr):1, 1:2] # change row order (but keep same nbr of rows) > pr(linmod.xy.keep, "change row order") > x1 <- trees1[,1:2] > colnames(x1) <- c("x1", "x2") # change column names in original x1 > pr(linmod.xy.keep, "change colnames") > x1 <- NULL # original x1 no longer available > pr(linmod.xy.keep, "x1=NULL") > remove(x1) > pr(linmod.xy.keep, "remove(x1)") > par(org.par) > > cat("==test processing a model created in a function with local data\n") ==test processing a model created in a function with local data > > # pr <- function(model, main=deparse(substitute(model))) > # { > # plotmo(model, degree1=1, degree2=0, pt.col=2, do.par=FALSE, main=main) > # } > pr <- function(model, main=deparse(substitute(model))) + { + plotres(model, which=3, main=main) # which=3 for just the residuals plot + } > lm.form.func <- function(keep=FALSE) + { + local.tr <- trees[1:20,] + lm(Volume~., data=local.tr, model=keep) + } > linmod.form.func <- function(keep=FALSE) + { + local.tr <- trees[1:20,] + model <- linmod(Volume~., data=local.tr, keep=keep) + # delete the saved residuals and fitted.values so plotres has to use the saved + # call etc. to get the x and y used to build the model, and rely on predict() + model$residuals <- NULL + model$fitted.values <- NULL + model + } > linmod.xy.func <- function(keep) + { + xx <- trees[1:20,1:2] + yy <- trees[1:20,3] + model <- linmod(xx, yy, keep=keep) + # delete the saved residuals and fitted.values so plotres has to use the saved + # call etc. to get the x and y used to build the model, and rely on predict() + model$residuals <- NULL + model$fitted.values <- NULL + model + } > par(mfrow=c(3,2)) > > lm.form <- lm.form.func(keep=FALSE) > pr(lm.form) > > lm.form.keep <- lm.form.func(keep=TRUE) > pr(lm.form.keep) > > linmod.form <- linmod.form.func(keep=FALSE) > pr(linmod.form) > > linmod.form.keep <- linmod.form.func(keep=TRUE) > pr(linmod.form.keep) > > linmod.xy <- linmod.xy.func(keep=FALSE) > expect.err(try(pr(linmod.xy)), "cannot get the original model predictors") Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: no formula in getCall(object) (3) getCall(object)$x: object 'xx' not found Error : cannot get the original model predictors Got expected error from try(pr(linmod.xy)) > > linmod.xy.keep <- linmod.xy.func(keep=TRUE) > pr(linmod.xy.keep) > > par(org.par) > > # test xlevels (predict with newdata using a string to represent a factor) > data(iris) > linmod.Sepal.Length <- linmod(Sepal.Length~Species,data=iris) > lm.Sepal.Length <- lm(Sepal.Length~Species,data=iris) > predict.linmod <- predict(linmod.Sepal.Length, newdata=data.frame(Species="setosa")) > predict.lm <- predict(lm.Sepal.Length, newdata=data.frame(Species="setosa")) > stopifnot(all.equal(predict.linmod, predict.lm)) > > source("test.epilog.R") plotmo/inst/slowtests/test.pre.Rout.save0000644000176200001440000001275614563614021020201 0ustar liggesusers> # test.pre.R: test the "pre" package with plotmo and plotres > > source("test.prolog.R") > library(pre) > library(plotmo) Loading required package: Formula Loading required package: plotrix > library(earth) # for ozone1 > options(warn=1) # print warnings as they occur > data(airquality) > airq <- airquality[complete.cases(airquality), (c("Ozone", "Wind", "Temp"))] > # prevent confusion caused by integer rownames which don't match row numbers > rownames(airq) <- NULL > airq <- airq[1:50, ] # small set of data for quicker test > > coef.glmnet <- glmnet:::coef.glmnet # TODO workaround required for glmnet 3.0 > predict.cv.glmnet <- glmnet:::predict.cv.glmnet > > set.seed(2018) > pre.mod <- pre(Ozone~., data=airq, ntrees=10) # ntrees=10 for faster test > plotres(pre.mod) # variable importance and residual plots > plotres(pre.mod, which=3, main="pre.mod residuals") # which=3 for just the residual vs fitted plot > plotmo(pre.mod) # plot model surface with background variables held at their medians plotmo grid: Wind Temp 10.3 75 > > # sanity check: compare model surface to to randomForest > # (commented out to save test time) > # > # library(randomForest) > # set.seed(2018) > # rf.mod <- randomForest(Ozone~., data=airq) > # plotmo(rf.mod) > > # compare singleplot and plotmo > > par(mfrow=c(2,2)) # 4 plots per page > > singleplot(pre.mod, varname="Temp", main="Temp\n(singleplot)") > > plotmo(pre.mod, + pmethod="partdep", # plot partial dependence plot, + degree1="Temp", degree2=0, # plot only Temp, no degree2 plots + do.par=FALSE, # don't automatically set par(), use above par(mfrow) + main="Temp\n(plotmo partdep)") calculating partdep for Temp > > # test penalty.par.val="lambda.min" > singleplot(pre.mod, varname="Temp", + main="penalty.par.val=lambda.min\n(singleplot)", + penalty.par.val="lambda.min") > > plotmo(pre.mod, + pmethod="partdep", + degree1="Temp", degree2=0, + do.par=FALSE, + main="penalty.par.val=lambda.min\n(plotmo partdep)", + predict.penalty.par.val="lambda.min") # use "predict." to pass it on to predict.pre calculating partdep for Temp > > par(org.par) > > # compare pairplot and plotmo > > par(mfrow=c(2,3)) # 6 plots per page > > pairplot(pre.mod, c("Temp", "Wind"), main="pairplot") Loading required namespace: interp > plotmo(pre.mod, main="plotmo partdep", + pmethod="partdep", + degree1=0, degree2="Temp", + do.par=FALSE) calculating partdep for Wind:Temp 01234567890 > > # Compare to pmethod="apartdep". An approximate partdep plot is > # faster than a full partdep plot (plotmo vignette Section 9.2). > > plotmo(pre.mod, main="plotmo apartdep", + pmethod="apartdep", + degree1=0, degree2="Temp", + do.par=FALSE) calculating apartdep for Wind:Temp 01234567890 > > # plot contour and image plots with plotmo > > plotmo(pre.mod, type2="contour", + degree1=0, degree2="Temp", do.par=FALSE) > > plotmo(pre.mod, type2="image", + degree1=0, degree2="Temp", do.par=FALSE) > > par(org.par) > > # test gpe models > > set.seed(2018) > gpe.mod <- gpe(Ozone~., data=airq, + base_learners=list(gpe_linear(), gpe_trees(), gpe_earth())) > plotmo(gpe.mod) # by default no degree2 plots because importance(gpe) not available plotmo grid: Wind Temp 10.3 75 > plotmo(gpe.mod, all2=TRUE, # force degree2 plot(s) by specifying all2=TRUE + persp.ticktype="detailed", persp.nticks=2) # optional (these get passed on to persp) plotmo grid: Wind Temp 10.3 75 > plotmo(gpe.mod, degree1=0, degree2=c("Wind", "Temp"), SHOWCALL=TRUE) # explictly specify degree2 plot > # which=3 below for only the residuals-vs-fitted plot > # optional info=TRUE to plot some extra information (RSq etc.) > plotres(gpe.mod, which=3, info=TRUE, main="gpe.mod residuals") > > # multinomial response > > set.seed(2018) > pre.iris <- pre(Species~., data=iris, ntrees=10) # ntrees=10 for faster testoptions(warn=2) # treat warnings as errors > options(warn=2) # treat warnings as errors > expect.err(try(plotmo(pre.iris)), "Defaulting to nresponse=1, see above messages") predict.pre[3,3]: setosa versicolor virginica 1 0.9746686 0.01299582 0.01233561 2 0.9746686 0.01299582 0.01233561 3 0.9750720 0.01300120 0.01192680 predict.pre returned multiple columns (see above) but nresponse is not specified Use the nresponse argument to specify a column. Example: nresponse=2 Example: nresponse="versicolor" Error : (converted from warning) Defaulting to nresponse=1, see above messages Got expected error from try(plotmo(pre.iris)) > options(warn=1) # print warnings as they occur > plotmo(pre.iris, all2=TRUE, nresponse="virginica", trace=1) importance: Petal.Length Petal.Width stats::predict(pre.object, data.frame[3,4], type="response") stats::fitted(object=pre.object) fitted() was unsuccessful, will use predict() instead assuming "Species" in the model.frame is the response, because terms(object) did not return the terms nresponse=3 but for plotmo_y using nresponse=1 because ncol(y) == 1 assuming "Species" in the model.frame is the response, because terms(object) did not return the terms got model response from model.frame(Species ~ ., data=object$data, na.action="na.fail") plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 5.8 3 4.35 1.3 > > source("test.epilog.R") plotmo/inst/slowtests/test.plotmo.args.Rout.save0000644000176200001440000001725314563614021021655 0ustar liggesusers> # test.plotmo.args..R: test dot and other argument handling in plotmo > > source("test.prolog.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix > data(ozone1) > options(warn=1) # print warnings as they occur > > options(warn=2) # treat warnings as errors > lm.mod <- lm(O3~wind, data=ozone1) > > expect.err(try(plotmo(lm.mod, se=2, leve=.95)), "plotmo's 'se' argument is deprecated, please use 'level' instead") Error : plotmo's 'se' argument is deprecated, please use 'level' instead Got expected error from try(plotmo(lm.mod, se = 2, leve = 0.95)) > > expect.err(try(plotmo(lm.mod, se=T)), "plotmo's 'se' argument is deprecated, please use 'level=.95' instead") Error : (converted from warning) plotmo's 'se' argument is deprecated, please use 'level=.95' instead Got expected error from try(plotmo(lm.mod, se = T)) > > expect.err(try(plotmo(lm.mod, se=.8)), "plotmo's 'se' argument is deprecated, please use 'level=.95' instead") Error : plotmo's 'se' argument is deprecated, please use 'level=.95' instead Got expected error from try(plotmo(lm.mod, se = 0.8)) > > expect.err(try(plotmo(lm.mod, level=2)), "level=2 is out of range, try level=.95") Error : level=2 is out of range, try level=.95 Got expected error from try(plotmo(lm.mod, level = 2)) > > oz2 <- ozone1[1:40,] > set.seed(2015) > a <- earth(O3~temp+wind, dat=oz2, deg=2, nk=21, ncr=3, nfo=3, varmod.me="lm") > > expect.err(try(plotmo(a, lw=2, trace=1, thresh=.9, SHOWCALL=TRUE)), "predict.earth ignored argument 'lw'") stats::predict(earth.object, NULL, type="response", lw=2, thresh=0.9) Error : (converted from warning) predict.earth ignored argument 'lw' Got expected error from try(plotmo(a, lw = 2, trace = 1, thresh = 0.9, SHOWCALL = TRUE)) > > options(warn=1) > > # test col.response and friends > plotmo(a, col.response=2, pch.response=c(1, 2, 20), type2="co", SHOWCALL=TRUE) # pch.response tests back compat plotmo grid: temp wind 53.5 4 > plotmo(a, pt.col=c(1,2,3), pt.pch=c(1, 2, 20), type2="im", SHOWCALL=TRUE) plotmo grid: temp wind 53.5 4 > plotmo(a, pt.col=c(1,2,3), pt.pch=paste(1:nrow(oz2)), pt.cex=.8, type2="im", do.par=2, SHOWCALL=TRUE) plotmo grid: temp wind 53.5 4 > plotmo(a, pt.col=c(1,2,3), pt.pch=paste(1:nrow(oz2)), pt.cex=.8, type2="co", degree1=0, do.par=F) Warning: plotmo: nothing to plot > par(org.par) > plotmo(a, col=2, SHOWCALL=TRUE) # will cause red response points plotmo grid: temp wind 53.5 4 > plotmo(a, pt.col=4, col=3, persp.col="pink", SHOWCALL=TRUE) # col now goes to lines plotmo grid: temp wind 53.5 4 > > # test cex and nrug and smooth > plotmo(a, cex=.8, SHOWCALL=TRUE, nrug=-1, rug.col=2, rug.lwd=1, smooth.col=3, + bty="n", col.lab="darkorange", xlab="an x label", cex.lab=1.2) # esoteric, but they work plotmo grid: temp wind 53.5 4 > plotmo(a, SHOWCALL=TRUE, density.col=2, density.lty=2, smooth.col=3, smooth.f=.3, col="lightblue") plotmo grid: temp wind 53.5 4 > plotmo(a, cex=1.2, SHOWCALL=TRUE, nrug="density") plotmo grid: temp wind 53.5 4 > > # test caption, grid, interval options > plotmo(a, caption.col=3, caption.font=2, grid.col="pink", + level=.8, SHOWCALL=TRUE) plotmo grid: temp wind 53.5 4 > plotmo(a, caption.col=2, caption.font=2, caption.cex=.8, grid.col=TRUE, bty="n", + level=.8, level.shade="lightblue", level.shade2="red", + grid.lty=3, grid.lwd=4, grid.nx=NA, SHOWCALL=TRUE) plotmo grid: temp wind 53.5 4 > > # test overall plot args handled by par() and graphics args outside do.par > par(mfrow=c(2,2), mar = c(3,3,3,1), mgp = c(1.5,.5,0), oma=c(0,0,4,0)) > par(col.main="#456789") > old.mar <- par("mar") > old.mfcol <- par("mfcol") > cat("before par: cex=", par("cex"), " col.main=", par("col.main"), + " col.axis=", par("col.axis"), " mar=", par("mar"), " mfcol=", par("mfcol"), + "\n", sep="") before par: cex=0.83 col.main=#456789 col.axis=black mar=3331 mfcol=22 > plotmo(a, mfcol=c(2,3), cex.main=1.4, oma=c(5,5,5,5), SHOWCALL=TRUE) plotmo grid: temp wind 53.5 4 > plotmo(a, caption="no cex") plotmo grid: temp wind 53.5 4 > plotmo(a, cex=1, caption="cex=1, plot should be identical to previous page") plotmo grid: temp wind 53.5 4 > plotmo(a, cex=1.2, caption="cex=1.2") plotmo grid: temp wind 53.5 4 > plotmo(a, do.par=FALSE, degree2=0, degree1=1, main="do.par=FALSE no cex", caption="a test graphics args with do.par=FALSE") plotmo grid: temp wind 53.5 4 > plotmo(a, do.par=FALSE, degree2=0, degree1=1, cex=1, main="do.par=FALSE cex=1") plotmo grid: temp wind 53.5 4 > plotmo(a, do.par=FALSE, degree2=0, degree1=1, cex=.8, main="do.par=FALSE cex=.8") plotmo grid: temp wind 53.5 4 > plotmo(a, do.par=FALSE, degree2=0, degree1=1, cex=1.1, xlab="xlab", col.main=2, col.axis="blue", col.lab=3, font.lab=2, + main="do.par=FALSE cex=1.1, col.main=2\ncol.axis=\"blue\", col.lab=3, font.lab=2") plotmo grid: temp wind 53.5 4 > plotmo(a, do.par=FALSE, degree1=1, degree2=1, persp.ticktype="d", + main="do.par=FALSE persp.ticktype=\"d\"") Warning: 'degree2' specified but no degree2 plots (maybe use all2=TRUE?) plotmo grid: temp wind 53.5 4 > # all of these should have been restored > cat("after par: cex=", par("cex"), " col.main=", par("col.main"), + " col.axis=", par("col.axis"), " mar=", par("mar"), " mfcol=", par("mfcol"), + "\n", sep="") after par: cex=0.83 col.main=#456789 col.axis=black mar=3331 mfcol=22 > stopifnot(par("col.main") == "#456789") > stopifnot(par("mar") == old.mar) > stopifnot(par("mfcol") == old.mfcol) > par(col.main=1) > > # test aliasing of col with other args, and back compat of col.degree1 vs degree1.col > data(etitanic) > a20 <- earth(pclass ~ ., data=etitanic, degree=2) > plotmo(a20, nresponse=1, col=2, col.degree1=3, persp.col="pink", SHOWCALL=1, degree1=1:2, degree2=1:2) plotmo grid: survived sex age sibsp parch 0 male 28 0 0 > plotmo(a20, nresponse=1, lty=2, persp.lty=1, SHOWCALL=1, degree1=1:2, degree2=1:2) plotmo grid: survived sex age sibsp parch 0 male 28 0 0 > > # test "prednames." with a long predictor name > data(trees) > trees.with.long.predname <- trees > trees.with.long.predname$a_quite_long_variable_name <- trees.with.long.predname$Girth > trees.with.long.predname$Girth <- NULL > mod <- earth(Volume~.,data=trees.with.long.predname) > par(mfrow=c(3,2), mar = c(3,3,3,1), mgp = c(1.5,.5,0), oma=c(0,0,4,0)) > plotmo(mod, do.par=FALSE) plotmo grid: Height a_quite_long_variable_name 76 12.9 > plotmo(mod, do.par=FALSE, prednames.abbreviate=FALSE) plotmo grid: Height a_quite_long_variable_name 76 12.9 > expect.err(try(plotmo(mod, do.par=FALSE, prednames.abbreviate=c(1,2))), "the prednames.abbreviate argument is not FALSE, TRUE, 0, or 1") Error : the prednames.abbreviate argument is not FALSE, TRUE, 0, or 1 Got expected error from try(plotmo(mod, do.par = FALSE, prednames.abbreviate = c(1, 2))) > plotmo(mod, do.par=FALSE, prednames.minlength=3) plotmo grid: Height a_quite_long_variable_name 76 12.9 > > source("test.epilog.R") plotmo/inst/slowtests/test.caret.bat0000755000176200001440000000152214563571565017400 0ustar liggesusers@rem test.caret.bat: test plotmo on caret models @rem Stephen Milborrow, Shrewsbury Aug 2016 @echo test.caret.bat @"C:\PROGRA~1\R\R-4.3.2\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.caret.R @if %errorlevel% equ 0 goto good1: @echo R returned errorlevel %errorlevel%, see test.caret.Rout: @echo. @tail test.caret.Rout @echo test.caret.R @exit /B 1 :good1 mks.diff test.caret.Rout test.caret.Rout.save @if %errorlevel% equ 0 goto good2: @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.caret.save.ps @exit /B 1 :good2 @rem test.caret.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.caret.save.ps @if %errorlevel% equ 0 goto good3: @echo === Files are different === @exit /B 1 :good3 @rm -f test.caret.Rout @rm -f Rplots.ps @exit /B 0 plotmo/inst/slowtests/modguide.model1.R0000644000176200001440000000447613725307662017736 0ustar liggesusers# modguide.model1.R: # # linmod code from Friedrich Leisch "Creating R Packages: A Tutorial" linmodEst <- function(x, y) { ## compute QR-decomposition of x qx <- qr(x) ## compute (x'x)^(-1) x'y coef <- solve.qr(qx, y) ## degrees of freedom and standard deviation of residuals df <- nrow(x)-ncol(x) sigma2 <- sum((y - x%*%coef)^2)/df ## compute sigma^2 * (x'x)^-1 vcov <- sigma2 * chol2inv(qx$qr) colnames(vcov) <- rownames(vcov) <- colnames(x) list(coefficients = coef, vcov = vcov, sigma = sqrt(sigma2), df = df) } print.linmod <- function(x, ...) { cat("Call:\n") print(x$call) cat("\nCoefficients:\n") print(x$coefficients) } summary.linmod <- function(object, ...) { se <- sqrt(diag(object$vcov)) tval <- coef(object) / se TAB <- cbind(Estimate = coef(object), StdErr = se, t.value = tval, p.value = 2*pt(-abs(tval), df=object$df)) res <- list(call=object$call, coefficients=TAB) class(res) <- "summary.linmod" res } print.summary.linmod <- function(x, ...) { cat("Call:\n") print(x$call) cat("\n") printCoefmat(x$coefficients, P.value=TRUE, has.Pvalue=TRUE) } linmod <- function(x, ...) UseMethod("linmod") linmod.default <- function(x, y, ...) { x <- as.matrix(x) y <- as.numeric(y) est <- linmodEst(x, y) est$fitted.values <- as.vector(x %*% est$coefficients) est$residuals <- y - est$fitted.values est$call <- match.call() class(est) <- "linmod" est } linmod.formula <- function(formula, data=list(), ...) { mf <- model.frame(formula=formula, data=data) x <- model.matrix(attr(mf, "terms"), data=mf) y <- model.response(mf) est <- linmod.default(x, y, ...) est$call <- match.call() est$formula <- formula est } predict.linmod <- function(object, newdata=NULL, ...) { if(is.null(newdata)) y <- fitted(object) else{ if(!is.null(object$formula)){ ## model has been fitted using formula interface x <- model.matrix(object$formula, newdata) } else{ x <- newdata } y <- as.vector(x %*% coef(object)) } y } plotmo/inst/slowtests/test.plotmo.bat0000755000176200001440000000154514563571565017621 0ustar liggesusers@rem test.plotmo.bat: this does a regression test of plotmo @rem Stephen Milborrow Apr 2007 Petaluma @echo test.plotmo.bat @"C:\PROGRA~1\R\R-4.3.2\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.plotmo.R @if %errorlevel% equ 0 goto good1: @echo R returned errorlevel %errorlevel%, see test.plotmo.Rout: @echo. @tail test.plotmo.Rout @echo test.plotmo.R @exit /B 1 :good1 mks.diff test.plotmo.Rout test.plotmo.Rout.save @if %errorlevel% equ 0 goto good2: @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.plotmo.save.ps @exit /B 1 :good2 @rem test.plotmo.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.plotmo.save.ps @if %errorlevel% equ 0 goto good3: @echo === Files are different === @exit /B 1 :good3 @rm -f test.plotmo.Rout @rm -f Rplots.ps @exit /B 0 plotmo/inst/slowtests/test.partykit.R0000644000176200001440000001251013725307664017574 0ustar liggesusers# test.partykit.R: test partykit and evtree packages source("test.prolog.R") library(plotmo) library(partykit) data("BostonHousing", package = "mlbench") data("PimaIndiansDiabetes", package = "mlbench") # lmtree boston <- transform(BostonHousing, chas = factor(chas, levels = 0:1, labels = c("no", "yes")), rad = factor(rad, ordered = TRUE)) set.seed(2018) lmtree.boston1 <- lmtree(medv ~ log(lstat) + rm^2 | crim + ptratio + tax + dis + rad + chas, data = boston, minsize = 40) boston2 <- boston boston2$log.lstat <- log(boston2$lstat) boston2$lstat <- NULL boston2$rm.squared <- boston2$rm^2 boston2$rm <- NULL set.seed(2018) lmtree.boston2 <- lmtree(medv ~ log.lstat + rm.squared | crim + ptratio + tax + dis + rad + chas, data = boston2, minsize = 40) plot(lmtree.boston1) plot(lmtree.boston2) plotmo(lmtree.boston1, SHOWCALL=TRUE) plotmo(lmtree.boston2, trace=2, SHOWCALL=TRUE) plotmo(lmtree.boston2, trace=1, all1=TRUE, degree2=c("ptratio", "log.lstat"), SHOWCALL=TRUE) plotmo(lmtree.boston2, all1=TRUE, all2=TRUE, SHOWCALL=TRUE) # TODO gives warnings because of because of price/citations in formula # data("Journals", package = "AER") # Journals <- transform(Journals, # age = 2000 - foundingyear, # chars = charpp * pages) # j_tree <- lmtree(log(subs) ~ log(price/citations) | price + citations + # age + chars + society, data = Journals, minsize = 10) # plotmo(j_tree, SHOWCALL=TRUE) # Works, but commented out to save testing time: # data("TeachingRatings", package = "AER") # tr_tree <- lmtree(eval ~ beauty | age + gender + division, # data = TeachingRatings, weights = students, subset = credits == "more", # caseweights = FALSE) # plot(tr_tree) # plotmo(tr_tree, all1=TRUE, all2=TRUE, SHOWCALL=TRUE) # glmtree glmtree1 <- glmtree(diabetes ~ glucose | mass + age, data = PimaIndiansDiabetes, family = binomial) plot(glmtree1) plotmo(glmtree1, SHOWCALL=TRUE) plotmo(glmtree1, all2=TRUE, SHOWCALL=TRUE) # mob pima <- PimaIndiansDiabetes[1:50,] # small set of data for fast test logit1 <- function(y, x, start = NULL, weights = NULL, offset = NULL, ...) { # note that a complicated formula is necessary formula <- as.formula(paste("y ~ ", paste(colnames(x)[-1], collapse="+"))) # -1 drops intercept glm(formula=formula, data=as.data.frame(x), family=binomial, start=start, ...) } mob1 <- mob(diabetes ~ glucose | mass + age, data = PimaIndiansDiabetes, fit = logit1) plot(mob1) plotmo(mob1, trace=1, SHOWCALL=TRUE) plotmo(mob1, pmethod="partdep", degree1=0, degree2=c("glucose", "mass"), persp.ticktype="detailed", SHOWCALL=TRUE) plotmo(mob1, all1=TRUE, all2=TRUE, SHOWCALL=TRUE) logit2 <- function(y, x, start = NULL, weights = NULL, offset = NULL, ...) { glm(y ~ 0 + x, family = binomial, start = start, ...) } mob2 <- mob(diabetes ~ glucose | mass, data = pima, fit = logit2) expect.err(try(plotmo(mob2)), "The formula in the mob fit function is not supported by plotmo") logit3 <- function(y, x, start = NULL, weights = NULL, offset = NULL, ...) { glm(y ~ 0+x , family = binomial, start = start, ...) } mob3 <- mob(diabetes ~ glucose | age, data = pima, fit = logit3) expect.err(try(plotmo(mob3)), "The formula in the mob fit function is not supported by plotmo") logit4 <- function(y, x, start = NULL, weights = NULL, offset = NULL, ...) { glm(y ~ x - 1, family = binomial, start = start, ...) } mob4 <- mob(diabetes ~ glucose | age, data = pima, fit = logit4) expect.err(try(plotmo(mob4)), "The formula in the mob fit function is not supported by plotmo") logit5 <- function(y, x, start = NULL, weights = NULL, offset = NULL, ...) { glm(y~x-1 , family = binomial, start = start, ...) } mob5 <- mob(diabetes ~ glucose | age, data = pima, fit = logit5) expect.err(try(plotmo(mob5)), "The formula in the mob fit function is not supported by plotmo") logit6 <- function (y, x, start = NULL, weights = NULL, offset = NULL, ...) { glm(as.formula(paste("y ~ ", paste(colnames(x)[-1], collapse="+"))), data=data.frame(x), family = binomial, start = start, ...) } mob6 <- mob(diabetes ~ glucose | mass + age, data = pima, fit = logit6) plot(mob6) # tree is just a root (no branches) plotmo(mob6) library(rpart.plot) rpart.Kyphosis <- rpart(Kyphosis ~ Age + Number + Start, data = kyphosis) plotmo(rpart.Kyphosis, SHOWCALL=TRUE) party.Kyphosis <- as.party(rpart.Kyphosis) expect.err(try(plotmo(party.Kyphosis)), "cannot get the original model predictors") library(evtree) ## regression set.seed(1090) airq <- subset(airquality, !is.na(Ozone) & complete.cases(airquality)) ev_air <- evtree(Ozone ~ ., data = airq) # plot(ev_air) plotmo(ev_air, SHOWCALL=TRUE) ## classification ev_iris <- evtree(Species ~ .,data = iris) # plot(ev_iris) plotmo(ev_iris, SHOWCALL=TRUE) plotmo(ev_iris, type="prob", nresponse="versicolor", pmethod="apartdep", SHOWCALL=TRUE) plotres(ev_iris, type="prob", nresponse="setosa", SHOWCALL=TRUE) # cforest cforest1 <- cforest(dist ~ speed, data = cars) plotmo(cforest1, trace=1, SHOWCALL=TRUE) plotres(cforest1, trace=1, SHOWCALL=TRUE) data("mammoexp", package = "TH.data") cforest2 <- cforest(ME ~ PB + SYMPT, data = mammoexp, ntree = 5) plotmo(cforest2, trace=1, SHOWCALL=TRUE, pmethod="apartdep") plotres(cforest2) source("test.epilog.R") plotmo/inst/slowtests/test.plotmo3.bat0000755000176200001440000000151614563571565017702 0ustar liggesusers@rem test.plotmo3.bat: extra tests for plotmo version 3 and higher @echo test.plotmo3.bat @"C:\PROGRA~1\R\R-4.3.2\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.plotmo3.R @if %errorlevel% equ 0 goto good1: @echo R returned errorlevel %errorlevel%, see test.plotmo3.Rout: @echo. @tail test.plotmo3.Rout @echo test.plotmo3.R @exit /B 1 :good1 mks.diff test.plotmo3.Rout test.plotmo3.Rout.save @if %errorlevel% equ 0 goto good2: @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.plotmo3.save.ps @exit /B 1 :good2 @rem test.plotmo3.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.plotmo3.save.ps @if %errorlevel% equ 0 goto good3: @echo === Files are different === @exit /B 1 :good3 @rm -f test.plotmo3.Rout @rm -f Rplots.ps @exit /B 0 plotmo/inst/slowtests/test.modguide.Rout.save0000644000176200001440000005402214563614021021200 0ustar liggesusers> # test.modguide.bat: test model1 and model2 (linmod examples) in modguide.pdf > > source("test.prolog.R") > options(warn=1) # print warnings as they occur > almost.equal <- function(x, y, max=1e-8) + { + stopifnot(max >= 0 && max < .01) + length(x) == length(y) && max(abs(x - y)) < max + } > # check that fit model matches ref lm model in all essential details > check.lm <- function(fit, ref, newdata=trees[3:5,], + check.coef.names=TRUE, + check.casenames=TRUE, + check.newdata=TRUE) + { + check.names <- function(fit.names, ref.names) + { + if(check.casenames && + # lm always adds rownames even if "1", "2", "3" + # this seems wasteful of resources, so linmod doesn't do this + !is.null(fit.names) && + !identical(fit.names, ref.names)) { + print(fit.names) + print(ref.names) + stop(deparse(substitute(fit.names)), " != ", + deparse(substitute(ref.names))) + } + } + cat("check ", deparse(substitute(fit)), " vs ", + deparse(substitute(ref)), "\n", sep="") + + stopifnot(coef(fit) == coef(ref)) + if(check.coef.names) + stopifnot(identical(names(coef(fit)), names(coef(ref)))) + + stopifnot(identical(dim(fit$coefficients), dim(ref$coefficients))) + stopifnot(length(fit$coefficients) == length(ref$coefficients)) + stopifnot(almost.equal(fit$coefficients, ref$coefficients)) + + stopifnot(identical(dim(fit$residuals), dim(ref$residuals))) + stopifnot(length(fit$residuals) == length(ref$residuals)) + stopifnot(almost.equal(fit$residuals, ref$residuals)) + + stopifnot(identical(dim(fit$fitted.values), dim(ref$fitted.values))) + stopifnot(length(fit$fitted.values) == length(ref$fitted.values)) + stopifnot(almost.equal(fit$fitted.values, ref$fitted.values)) + + if(!is.null(fit$vcov) && !is.null(ref$vcov)) { + stopifnot(identical(dim(fit$vcov), dim(ref$vcov))) + stopifnot(length(fit$vcov) == length(ref$vcov)) + stopifnot(almost.equal(fit$vcov, ref$vcov)) + } + ref.sigma <- ref$sigma + if(is.null(ref.sigma)) # in lm models, sigma is only available from summary() + ref.sigma <- summary(ref)$sigma + stopifnot(almost.equal(fit$sigma, ref.sigma)) + + stopifnot(almost.equal(fit$df, ref$df)) + + stopifnot(almost.equal(fitted(fit), fitted(ref))) + check.names(names(fitted(fit)), names(fitted(ref))) + + stopifnot(almost.equal(residuals(fit), residuals(ref))) + check.names(names(residuals(fit)), names(residuals(ref))) + + stopifnot(almost.equal(predict(fit), predict(ref))) + check.names(names(predict(fit)), names(predict(ref))) + if(check.newdata) { + stopifnot(almost.equal(predict(fit, newdata=newdata), + predict(ref, newdata=newdata))) + check.names(names(predict(fit, newdata=newdata)), + names(predict(ref, newdata=newdata))) + } + } > ### Model 1: original code from Friedrich Leisch tutorial > > source("modguide.model1.R") > > cat("==example issues with predict with functions in the tutorial\n") ==example issues with predict with functions in the tutorial > data(trees) > tr <- trees # trees data but with rownames > rownames(tr) <- paste("tree", 1:nrow(trees), sep="") > fit1 <- linmod(Volume~., data=tr) > expect.err(try(predict(fit1, newdata=data.frame(Girth=10, Height=80))), "object 'Volume' not found") Error in eval(predvars, data, env) : object 'Volume' not found Got expected error from try(predict(fit1, newdata = data.frame(Girth = 10, Height = 80))) > expect.err(try(predict(fit1, newdata=as.matrix(tr[1:3,]))), "'data' must be a data.frame, not a matrix or an array") Error in model.frame.default(object, data, xlev = xlev) : 'data' must be a data.frame, not a matrix or an array Got expected error from try(predict(fit1, newdata = as.matrix(tr[1:3, ]))) > library(plotmo) Loading required package: Formula Loading required package: plotrix > expect.err(try(plotmo(fit1)), "object 'Volume' not found") stats::predict(linmod.object, data.frame[3,2], type="response") Error in eval(predvars, data, env) : object 'Volume' not found Got expected error from try(plotmo(fit1)) > fit2 <- linmod(cbind(1, tr[,1:2]), tr[,3]) > stopifnot(coef(fit1) == coef(fit2)) > # following fail because newdata is a data.frame not a matrix > expect.err(try(predict(fit2, newdata=tr[,1:2])), "requires numeric/complex matrix/vector arguments") Error in x %*% coef(object) : requires numeric/complex matrix/vector arguments Got expected error from try(predict(fit2, newdata = tr[, 1:2])) > expect.err(try(predict(fit2, newdata=data.frame(Girth=10, Height=80))), "requires numeric/complex matrix/vector arguments") Error in x %*% coef(object) : requires numeric/complex matrix/vector arguments Got expected error from try(predict(fit2, newdata = data.frame(Girth = 10, Height = 80))) > expect.err(try(predict(fit2, newdata=as.matrix(data.frame(Girth=10, Height=80)))), "non-conformable arguments") Error in x %*% coef(object) : non-conformable arguments Got expected error from try(predict(fit2, newdata = as.matrix(data.frame(Girth = 10, Height = 80)))) > expect.err(try(plotmo(fit2)), "requires numeric/complex matrix/vector arguments") stats::predict(linmod.object, data.frame[3,3], type="response") Error in x %*% coef(object) : requires numeric/complex matrix/vector arguments Got expected error from try(plotmo(fit2)) > > cat("==a plotmo method function can deal with the issues\n") ==a plotmo method function can deal with the issues > plotmo.predict.linmod <- function(object, newdata, ...) + { + if(is.null(object$formula)) # x,y interface? + plotmo:::plotmo.predict.defaultm(object, newdata, ...) # pass matrix not data.frame + else { + # add dummy response column to newdata + newdata[[as.character(as.list(object$formula)[[2]])]] <- 1 + plotmo:::plotmo.predict.default(object, newdata, ...) + } + } > plotmo(fit1, pt.col=2, caption="fit1 with original tutorial code and plotmo.predict.linmod") plotmo grid: Girth Height 12.9 76 > plotmo(fit2, pt.col=2, caption="fit2 with original tutorial code and plotmo.predict.linmod") plotmo grid: 1 Girth Height 1 12.9 76 > remove(plotmo.predict.linmod) > > ### Model 2: minimal changes version for vignette "Guidelines for S3 Regression Models" > > source("modguide.model2.R") > > cat("==check that example issues with functions in the tutorial have gone\n") ==check that example issues with functions in the tutorial have gone > fit1.form <- linmod(Volume~., data=tr) > cat("==print(summary(fit1.form))\n") ==print(summary(fit1.form)) > print(summary(fit1.form)) Call: linmod.formula(formula = Volume ~ ., data = tr) Estimate StdErr t.value p.value (Intercept) -57.98766 8.63823 -6.7129 2.75e-07 *** Girth 4.70816 0.26426 17.8161 < 2.2e-16 *** Height 0.33925 0.13015 2.6066 0.01449 * --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 > stopifnot(abs(predict(fit1.form, newdata=data.frame(Girth=10, Height=80)) - 16.234045) < 1e-5) > stopifnot(sum(abs(predict(fit1.form, newdata=as.matrix(tr[1:3,])) - c(4.8376597, 4.5538516, 4.8169813))) < 1e-5) > > lm.tr <- lm(Volume~., data=tr) > check.lm(fit1.form, lm.tr) check fit1.form vs lm.tr > > fit1.mat <- linmod(tr[,1:2], tr[,3]) # note no need for intercept term > cat("==print(summary(fit1.mat))\n") ==print(summary(fit1.mat)) > print(summary(fit1.mat)) Call: linmod.default(x = tr[, 1:2], y = tr[, 3]) Estimate StdErr t.value p.value (Intercept) -57.98766 8.63823 -6.7129 2.75e-07 *** Girth 4.70816 0.26426 17.8161 < 2.2e-16 *** Height 0.33925 0.13015 2.6066 0.01449 * --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 > stopifnot(abs(predict(fit1.mat, newdata=data.frame(Girth=10, Height=80)) - 16.234045) < 1e-5) > stopifnot(sum(abs(predict(fit1.mat, newdata=tr[1:3,1:2]) - c(4.8376597, 4.5538516, 4.8169813))) < 1e-5) > stopifnot(abs(predict(fit1.mat, newdata=as.matrix(data.frame(Girth=10, Height=80))) - 16.234045) < 1e-5) > > check.lm(fit1.mat, lm.tr, newdata=trees[3:5,1:2]) check fit1.mat vs lm.tr > > cat("==example plots\n") ==example plots > > library(plotmo) > data(trees) > > fit1.form <- linmod(Volume~., data=trees) > print(fit1.form) Call: linmod.formula(formula = Volume ~ ., data = trees) Coefficients: (Intercept) Girth Height -57.9876589 4.7081605 0.3392512 > print(summary(fit1.form)) Call: linmod.formula(formula = Volume ~ ., data = trees) Estimate StdErr t.value p.value (Intercept) -57.98766 8.63823 -6.7129 2.75e-07 *** Girth 4.70816 0.26426 17.8161 < 2.2e-16 *** Height 0.33925 0.13015 2.6066 0.01449 * --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 > > fit1.mat <- linmod(trees[,1:2], trees[,3]) > print(fit1.mat) Call: linmod.default(x = trees[, 1:2], y = trees[, 3]) Coefficients: (Intercept) Girth Height -57.9876589 4.7081605 0.3392512 > print(summary(fit1.mat)) Call: linmod.default(x = trees[, 1:2], y = trees[, 3]) Estimate StdErr t.value p.value (Intercept) -57.98766 8.63823 -6.7129 2.75e-07 *** Girth 4.70816 0.26426 17.8161 < 2.2e-16 *** Height 0.33925 0.13015 2.6066 0.01449 * --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 > > plotmo(fit1.form) plotmo grid: Girth Height 12.9 76 > plotmo(fit1.mat) plotmo grid: Girth Height 12.9 76 > > plotres(fit1.form) > plotres(fit1.mat) > > cat("==test model building with different numeric args\n") ==test model building with different numeric args > > x <- tr[,1:2] > y <- tr[,3] > fit2.mat <- linmod(x, y) > check.lm(fit2.mat, lm.tr, newdata=trees[3:5,1:2]) check fit2.mat vs lm.tr > > # check consistency with lm > expect.err(try(linmod(y~x)), "invalid type (list) for variable 'x'") Error in model.frame.default(formula = formula, data = data) : invalid type (list) for variable 'x' Got expected error from try(linmod(y ~ x)) > expect.err(try(lm(y~x)), "invalid type (list) for variable 'x'") Error in model.frame.default(formula = y ~ x, drop.unused.levels = TRUE) : invalid type (list) for variable 'x' Got expected error from try(lm(y ~ x)) > > fit3.mat <- linmod(as.matrix(x), as.matrix(y)) > check.lm(fit3.mat, lm.tr, newdata=trees[3:5,1:2]) check fit3.mat vs lm.tr > > fit4.form <- linmod(y ~ as.matrix(x)) > lm4 <- linmod(y ~ as.matrix(x)) > check.lm(fit4.form, lm4) check fit4.form vs lm4 > stopifnot(coef(fit4.form) == coef(lm.tr), + gsub("as.matrix(x)", "", names(coef(fit4.form)), fixed=TRUE) == names(coef(lm.tr))) > > xm <- as.matrix(x) > fit5.form <- linmod(y ~ xm) > lm5 <- linmod(y ~ xm) > check.lm(fit5.form, lm5) check fit5.form vs lm5 > stopifnot(coef(fit5.form) == coef(lm.tr), + gsub("xm", "", names(coef(fit5.form)), fixed=TRUE) == names(coef(lm.tr))) > > cat("==test correct use of global x1 and y1\n") ==test correct use of global x1 and y1 > x1 <- tr[,1] > y1 <- tr[,3] > linmod1 <- linmod(y1~x1) > > fit6.mat <- linmod(x1, y1) > check.lm(fit6.mat, linmod1, newdata=x1[3:5], + check.newdata=FALSE, # TODO needed because linmod1 ignores newdata(!) + check.coef.names=FALSE, check.casenames=FALSE) check fit6.mat vs linmod1 > print(predict(fit6.mat, newdata=x1[3:5])) [1] 7.636077 16.248033 17.261205 > stopifnot(almost.equal(predict(fit6.mat, newdata=x1[3]), 7.63607739644657)) > # production version only: > # stopifnot(coef(fit6.mat) == coef(linmod1), > # names(coef(fit6.mat)) == c("(Intercept)", "V1")) # names(coef(linmod1) are "(Intercept)" "x1" > > fit6.form <- linmod(y1~x1) > check.lm(fit6.form, linmod1) check fit6.form vs linmod1 > > cat("==check integer input (sibsp is an integer) \n") ==check integer input (sibsp is an integer) > > library(earth) # for etitanic data > data(etitanic) > tit <- etitanic[seq(1, nrow(etitanic), by=60), ] # small set of data for tests (18 cases) > tit$survived <- tit$survived != 0 # convert to logical > rownames(tit) <- paste("pas", 1:nrow(tit), sep="") > cat(paste(colnames(tit), "=", sapply(tit, class), sep="", collapse=", "), "\n") pclass=factor, survived=logical, sex=factor, age=numeric, sibsp=integer, parch=integer > > fit7.mat <- linmod(tit$age, tit$sibsp) > lm7 <- lm.fit(cbind(1, tit$age), tit$sibsp) > stopifnot(coef(fit7.mat) == coef(lm7)) # coef names will differ > > fit7.form <- linmod(sibsp~age, data=tit) > lm7.form <- lm(sibsp~age, data=tit) > check.lm(fit7.form, lm7.form, newdata=tit[3:5,]) check fit7.form vs lm7.form > > fit8.mat <- linmod(tit$sibsp, tit$age) > lm8 <- lm.fit(cbind(1, tit$sibsp), tit$age) > stopifnot(coef(fit8.mat) == coef(lm8)) # coef names will differ > > fit8.form <- linmod(age~sibsp, data=tit) > lm8.form <- lm(age~sibsp, data=tit) > check.lm(fit8.form, lm8.form, newdata=tit[3:5,]) check fit8.form vs lm8.form > > # drop=FALSE so response is a data frame > fit1a.mat <- linmod(trees[,1:2], trees[, 3, drop=FALSE]) > print(fit1a.mat) Call: linmod.default(x = trees[, 1:2], y = trees[, 3, drop = FALSE]) Coefficients: (Intercept) Girth Height -57.9876589 4.7081605 0.3392512 > print(summary(fit1.mat)) Call: linmod.default(x = trees[, 1:2], y = trees[, 3]) Estimate StdErr t.value p.value (Intercept) -57.98766 8.63823 -6.7129 2.75e-07 *** Girth 4.70816 0.26426 17.8161 < 2.2e-16 *** Height 0.33925 0.13015 2.6066 0.01449 * --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 > plotres(fit1a.mat) # plot caption shows response name "Volume" > > cat("==test model building with different non numeric args\n") ==test model building with different non numeric args > > library(earth) # for etitanic data > data(etitanic) > tit <- etitanic[seq(1, nrow(etitanic), by=60), ] # small set of data for tests (18 cases) > tit$survived <- tit$survived != 0 # convert to logical > rownames(tit) <- paste("pas", 1:nrow(tit), sep="") > cat(paste(colnames(tit), "=", sapply(tit, class), sep="", collapse=", "), "\n") pclass=factor, survived=logical, sex=factor, age=numeric, sibsp=integer, parch=integer > > lm9 <- lm(survived~., data=tit) > fit9.form <- linmod(survived~., data=tit) > check.lm(fit9.form, lm9, newdata=tit[3:5,]) check fit9.form vs lm9 > > options(warn=2) # treat warnings as errors > # factors in x > expect.err(try(linmod(tit[,c(1,3,4,5,6)], tit[,"survived"])), "NAs introduced by coercion") Error in storage.mode(x) <- "double" : (converted from warning) NAs introduced by coercion Got expected error from try(linmod(tit[, c(1, 3, 4, 5, 6)], tit[, "survived"])) > options(warn=1) # print warnings as they occur > expect.err(try(linmod(tit[,c(1,3,4,5,6)], tit[,"survived"])), "NA/NaN/Inf in foreign function call (arg 1)") Warning in storage.mode(x) <- "double" : NAs introduced by coercion Error in qr.default(x) : NA/NaN/Inf in foreign function call (arg 1) Got expected error from try(linmod(tit[, c(1, 3, 4, 5, 6)], tit[, "survived"])) > > options(warn=2) # treat warnings as errors > expect.err(try(lm(pclass~., data=tit)), "using type = \"numeric\" with a factor response will be ignored") Error in model.response(mf, "numeric") : (converted from warning) using type = "numeric" with a factor response will be ignored Got expected error from try(lm(pclass ~ ., data = tit)) > # minimal version > expect.err(try(linmod(pclass~., data=tit)), "(converted from warning) NAs introduced by coercion") Error in storage.mode(y) <- "double" : (converted from warning) NAs introduced by coercion Got expected error from try(linmod(pclass ~ ., data = tit)) > expect.err(try(linmod(tit$pclass, tit$survived)), "(converted from warning) NAs introduced by coercion") Error in storage.mode(x) <- "double" : (converted from warning) NAs introduced by coercion Got expected error from try(linmod(tit$pclass, tit$survived)) > # # production version > # expect.err(try(linmod(pclass~., data=tit)), "'y' is not numeric or logical") > options(warn=1) > > lm10 <- lm(pclass~., data=tit) # will give warnings Warning in model.response(mf, "numeric") : using type = "numeric" with a factor response will be ignored Warning in Ops.factor(y, z$residuals) : '-' not meaningful for factors > fit10.form <- linmod(as.numeric(pclass)~., data=tit) > stopifnot(coef(fit10.form) == coef(lm10)) > stopifnot(names(coef(fit10.form)) == names(coef(lm10))) > # check.lm(fit10.form, lm10) # fails because lm10 fitted is all NA > > # production version: (minimal version just gives warnings and builds lousy model) > # expect.err(try(linmod(pclass~., data=tit)), "'y' is not numeric or logical") > # expect.err(try(linmod(tit[,-1], tit[,1])), "'y' is not numeric or logical") > # expect.err(try(linmod(1:10, paste(1:10))), "'y' is not numeric or logical") > > fit10a.form <- linmod(survived~pclass, data=tit) > lm10a <- lm(survived~pclass, data=tit) > check.lm(fit10a.form, lm10a, newdata=tit[3:5,]) check fit10a.form vs lm10a > > expect.err(try(linmod(paste(1:10), 1:10)), "requires numeric/complex matrix/vector arguments") Error in x %*% coef : requires numeric/complex matrix/vector arguments Got expected error from try(linmod(paste(1:10), 1:10)) > > lm11 <- lm(as.numeric(pclass)~., data=tit) > fit11.form <- linmod(as.numeric(pclass)~., data=tit) > check.lm(fit11.form, lm11, newdata=tit[3:5,]) check fit11.form vs lm11 > > cat("==data.frame with strings\n") ==data.frame with strings > > df.with.string <- + data.frame(1:5, + c(1,2,-1,4,5), + c("a", "b", "a", "a", "b"), + stringsAsFactors=FALSE) > colnames(df.with.string) <- c("num1", "num2", "string") > > fit30.form <- linmod(num1~num2, df.with.string) > lm30 <- lm(num1~num2, df.with.string) > check.lm(fit30.form, lm30, check.newdata=FALSE) check fit30.form vs lm30 > > fit31.form <- linmod(num1~., df.with.string) > lm31 <- lm(num1~., df.with.string) > check.lm(fit31.form, lm31, check.newdata=FALSE) check fit31.form vs lm31 > > expect.err(try(linmod(string~., df.with.string)), "non-numeric argument to binary operator") Warning in storage.mode(y) <- "double" : NAs introduced by coercion Error in y - x %*% coef : non-numeric argument to binary operator Got expected error from try(linmod(string ~ ., df.with.string)) > # production version > # expect.err(try(linmod(string~., df.with.string)), "'y' is not numeric or logical") > > vec <- c(1,2,3,4,3) > options(warn=2) # treat warnings as errors > expect.err(try(linmod(df.with.string, vec)), "NAs introduced by coercion") Error in storage.mode(x) <- "double" : (converted from warning) NAs introduced by coercion Got expected error from try(linmod(df.with.string, vec)) > options(warn=1) > # minimal version > expect.err(try(linmod(df.with.string, vec)), "NA/NaN/Inf in foreign function call (arg 1)") Warning in storage.mode(x) <- "double" : NAs introduced by coercion Error in qr.default(x) : NA/NaN/Inf in foreign function call (arg 1) Got expected error from try(linmod(df.with.string, vec)) > # production version > # expect.err(try(linmod(df.with.string, vec)), "NA in 'x'") > > options(warn=2) # treat warnings as errors > expect.err(try(linmod(df.with.string, vec)), "NAs introduced by coercion") Error in storage.mode(x) <- "double" : (converted from warning) NAs introduced by coercion Got expected error from try(linmod(df.with.string, vec)) > options(warn=1) > # minimal version > expect.err(try(linmod(df.with.string, vec)), "NA/NaN/Inf in foreign function call (arg 1)") Warning in storage.mode(x) <- "double" : NAs introduced by coercion Error in qr.default(x) : NA/NaN/Inf in foreign function call (arg 1) Got expected error from try(linmod(df.with.string, vec)) > # production version > # expect.err(try(linmod(df.with.string, vec)), "NA in 'x'") > > cat("==more variables than cases\n") ==more variables than cases > > set.seed(1) > x2 <- matrix(rnorm(6), nrow=2) > y2 <- c(1,2) > # production version > # expect.err(try(linmod(y2~x2)), "more variables than cases") > # minimal version > expect.err(try(linmod(y2~x2)), "'size' cannot exceed nrow(x) = 2") Error in chol2inv(qx$qr) : 'size' cannot exceed nrow(x) = 2 Got expected error from try(linmod(y2 ~ x2)) > > x3 <- matrix(1:10, ncol=2) > y3 <- c(1,2,9,4,5) > # production version will give a better error message > expect.err(try(linmod(y3~x3)), "singular matrix 'a' in 'solve'") Error in solve.qr(qx, y) : singular matrix 'a' in 'solve' Got expected error from try(linmod(y3 ~ x3)) > > cat("==nrow(x) does not match length(y)\n") ==nrow(x) does not match length(y) > # note that the production version gives better error messages > > x4 <- matrix(1:10, ncol=2) > y4 <- c(1,2,9,4) > expect.err(try(linmod(x4, y4)), "singular matrix 'a' in 'solve'") Error in solve.qr(qx, y) : singular matrix 'a' in 'solve' Got expected error from try(linmod(x4, y4)) > > x5 <- matrix(1:10, ncol=2) > y5 <- c(1,2,9,4,5,9) > expect.err(try(linmod(x5, y5)), "singular matrix 'a' in 'solve'") Error in solve.qr(qx, y) : singular matrix 'a' in 'solve' Got expected error from try(linmod(x5, y5)) > > cat("==y has multiple columns\n") ==y has multiple columns > > vec <- c(1,2,3,4,3) > y2 <- cbind(c(1,2,3,4,9), vec^2) > expect.err(try(linmod(vec, y2)), "'qr' and 'y' must have the same number of rows") Error in qr.coef(a, b) : 'qr' and 'y' must have the same number of rows Got expected error from try(linmod(vec, y2)) > # following does not issue any error message, it should > # expect.err(try(linmod(y2~vec)), "error message") > > ### Model 3: production version of linmod is tested in test.linmod.R > > source("test.epilog.R") plotmo/inst/slowtests/README.txt0000644000176200001440000000114213306016353016304 0ustar liggesusersplotmo/inst/slowtests/README.txt -------------------------------- The tests in this directory must be run manually before submitting a new version of this package to CRAN. They are much more comprehensive than the standard CRAN checks in tests/tests.plotmo.R, but take several minutes to run. Also they compare postscript files, and there are sometimes arbitrary changes to the format of those postscript files due to changes in the postscript driver across R releases. Such changes must be manually checked by comparing the files in a postscript viewer. Complete automation isn't possible. plotmo/inst/slowtests/test.center.bat0000755000176200001440000000154514563571565017567 0ustar liggesusers@rem test.center.bat: test plotmo's center and ndiscrete args @rem Stephen Milborrow, Berea Apr 2011 @echo test.center.bat @"C:\PROGRA~1\R\R-4.3.2\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.center.R @if %errorlevel% equ 0 goto good1: @echo R returned errorlevel %errorlevel%, see test.center.Rout: @echo. @tail test.center.Rout @echo test.center.R @exit /B 1 :good1 mks.diff test.center.Rout test.center.Rout.save @if %errorlevel% equ 0 goto good2: @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.center.save.ps @exit /B 1 :good2 @rem test.center.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.center.save.ps @if %errorlevel% equ 0 goto good3: @echo === Files are different === @exit /B 1 :good3 @rm -f test.center.Rout @rm -f Rplots.ps @exit /B 0 plotmo/inst/slowtests/test.partykit.Rout.save0000644000176200001440000005361714567065443021277 0ustar liggesusers> # test.partykit.R: test partykit and evtree packages > > source("test.prolog.R") > library(plotmo) Loading required package: Formula Loading required package: plotrix > library(partykit) Loading required package: grid Loading required package: libcoin Loading required package: mvtnorm > data("BostonHousing", package = "mlbench") > data("PimaIndiansDiabetes", package = "mlbench") > > # lmtree > > boston <- transform(BostonHousing, + chas = factor(chas, levels = 0:1, labels = c("no", "yes")), + rad = factor(rad, ordered = TRUE)) > set.seed(2018) > lmtree.boston1 <- lmtree(medv ~ log(lstat) + rm^2 | + crim + ptratio + tax + dis + rad + chas, + data = boston, minsize = 40) > > boston2 <- boston > boston2$log.lstat <- log(boston2$lstat) > boston2$lstat <- NULL > boston2$rm.squared <- boston2$rm^2 > boston2$rm <- NULL > set.seed(2018) > lmtree.boston2 <- lmtree(medv ~ log.lstat + rm.squared | + crim + ptratio + tax + dis + rad + chas, + data = boston2, minsize = 40) > > plot(lmtree.boston1) > plot(lmtree.boston2) > > plotmo(lmtree.boston1, SHOWCALL=TRUE) plotmo grid: lstat rm crim ptratio tax dis rad chas 11.36 6.2085 0.25651 19.05 330 3.20745 24 no > plotmo(lmtree.boston2, trace=2, SHOWCALL=TRUE) plotmo trace 2: plotmo(object=lmtree.boston2, trace=2, SHOWCALL=TRUE) --get.model.env for object with class lmtree object call is lmtree(formula=medv~log.lstat+rm.squared|crim+ptratio+tax+dis+rad+chas, data=boston2, minsize=40) using the environment saved in $terms of the lmtree model: R_GlobalEnv --plotmo_prolog for lmtree object 'lmtree.boston2' variable importance: log.lstat rm.squared tax ptratio changing class of 'lmtree.boston2' from c("lmtree", "modelparty", "party") to "party_plotmo" for standard "[[" --plotmo_x for party_plotmo object get.object.x: object$x is NULL (and it has no colnames) object call is lmtree(formula=medv~log.lstat+rm.squared|crim+ptratio+tax+dis+rad+chas, data=... get.x.from.model.frame: formula(object) is medv ~ log.lstat + rm.squared + (crim + ptratio + tax + d... naked formula is medv ~ log.lstat + rm.squared + crim + ptratio + tax + dis + rad + chas formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names crim zn indus chas nox age dis rad tax ptratio b medv log.lstat rm.squared na.action(object) is "na.pass" stats::model.frame(medv ~ log.lstat + rm.squared + crim ..., data=call$data, na.action="na.pass") x=model.frame[,-1] is usable and has column names log.lstat rm.squared crim ptratio tax dis rad chas plotmo_x returned[506,8]: log.lstat rm.squared crim ptratio tax dis rad chas 1 1.605430 43.23063 0.00632 15.3 296 4.0900 1 no 2 2.212660 41.22924 0.02731 17.8 242 4.9671 2 no 3 1.393766 51.62422 0.02729 17.8 242 4.9671 2 no ... 1.078410 48.97200 0.03237 18.7 222 6.0622 3 no 506 2.064328 36.36090 0.04741 21.0 273 2.5050 1 no factors: rad(ordered) chas ----Metadata: plotmo_predict with nresponse=NULL and newdata=NULL plotmo_predict with NULL newdata (nrows=3), using plotmo_x to get the data --plotmo_x for party_plotmo object get.object.x: object$x is NULL (and it has no colnames) object call is lmtree(formula=medv~log.lstat+rm.squared|crim+ptratio+tax+dis+rad+chas, data=... get.x.from.model.frame: formula(object) is medv ~ log.lstat + rm.squared + (crim + ptratio + tax + d... naked formula is medv ~ log.lstat + rm.squared + crim + ptratio + tax + dis + rad + chas formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names crim zn indus chas nox age dis rad tax ptratio b medv log.lstat rm.squared na.action(object) is "na.pass" stats::model.frame(medv ~ log.lstat + rm.squared + crim ..., data=call$data, na.action="na.pass") x=model.frame[,-1] is usable and has column names log.lstat rm.squared crim ptratio tax dis rad chas plotmo_x returned[506,8]: log.lstat rm.squared crim ptratio tax dis rad chas 1 1.605430 43.23063 0.00632 15.3 296 4.0900 1 no 2 2.212660 41.22924 0.02731 17.8 242 4.9671 2 no 3 1.393766 51.62422 0.02729 17.8 242 4.9671 2 no ... 1.078410 48.97200 0.03237 18.7 222 6.0622 3 no 506 2.064328 36.36090 0.04741 21.0 273 2.5050 1 no factors: rad(ordered) chas will use the above data instead of newdata=NULL for predict.party_plotmo stats::predict(lmtree.object, data.frame[3,8], type="response") predict returned[3,1] with no column names: 1 26.03975 2 26.21389 3 35.63227 predict after processing with nresponse=NULL is [3,1] with no column names: 1 26.03975 2 26.21389 3 35.63227 ----Metadata: plotmo_fitted with nresponse=NULL stats::fitted(object=party_plotmo.object) fitted(object) returned[506,1]: (fitted) 1 7 2 6 3 6 ... 6 506 8 fitted(object) after processing with nresponse=NULL is [506,1]: (fitted) 1 7 2 6 3 6 ... 6 506 8 ----Metadata: plotmo_y with nresponse=NULL --plotmo_y with nresponse=NULL for party_plotmo object get.object.y: object$y is NULL (and it has no colnames) object call is lmtree(formula=medv~log.lstat+rm.squared|crim+ptratio+tax+dis+rad+chas, data=... get.y.from.model.frame: formula(object) is medv ~ log.lstat + rm.squared + (crim + ptratio + tax + d... formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names crim zn indus chas nox age dis rad tax ptratio b medv log.lstat rm.squared na.action(object) is "na.pass" stats::model.frame(medv ~ log.lstat + rm.squared + (crim..., data=call$data, na.action="na.pass") y=model.frame[,1] is usable and has column name medv plotmo_y returned[506,1]: medv 1 24.0 2 21.6 3 34.7 ... 33.4 506 11.9 plotmo_y after processing with nresponse=NULL is [506,1]: medv 1 24.0 2 21.6 3 34.7 ... 33.4 506 11.9 converted nresponse=NA to nresponse=1 nresponse=1 (was NA) ncol(fitted) 1 ncol(predict) 1 ncol(y) 1 ----Metadata: plotmo_y with nresponse=1 --plotmo_y with nresponse=1 for party_plotmo object get.object.y: object$y is NULL (and it has no colnames) object call is lmtree(formula=medv~log.lstat+rm.squared|crim+ptratio+tax+dis+rad+chas, data=... get.y.from.model.frame: formula(object) is medv ~ log.lstat + rm.squared + (crim + ptratio + tax + d... formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names crim zn indus chas nox age dis rad tax ptratio b medv log.lstat rm.squared na.action(object) is "na.pass" stats::model.frame(medv ~ log.lstat + rm.squared + (crim..., data=call$data, na.action="na.pass") y=model.frame[,1] is usable and has column name medv got model response from model.frame(medv ~ log.lstat + rm.squared + (crim..., data=call$data, na.action="na.pass") plotmo_y returned[506,1]: medv 1 24.0 2 21.6 3 34.7 ... 33.4 506 11.9 plotmo_y after processing with nresponse=1 is [506,1]: medv 1 24.0 2 21.6 3 34.7 ... 33.4 506 11.9 got response name "medv" from yfull resp.levs is NULL ----Metadata: done number of x values: log.lstat 455 rm.squared 446 crim 504 ptratio 46 tax 66 d... ----plotmo_singles for party_plotmo object singles: 1 log.lstat, 2 rm.squared, 4 ptratio, 5 tax ----plotmo_pairs for party_plotmo object pairs: [,1] [,2] [1,] "1 log.lstat" "2 rm.squared" [2,] "1 log.lstat" "4 ptratio" [3,] "1 log.lstat" "5 tax" [4,] "2 rm.squared" "4 ptratio" [5,] "2 rm.squared" "5 tax" [6,] "4 ptratio" "5 tax" graphics::par(mfrow=c(4,4), mgp=c(1.5,0.4,0), tcl=-0.3, font.main=2, mar=c(3,2,1.2,0.8), oma=c(0,0,4,0), cex.main=1.1, cex.lab=1, cex.axis=1, cex=0.66) ----Figuring out ylim --get.ylim.by.dummy.plots --plot.degree1(draw.plot=FALSE) degree1 plot1 (pmethod "plotmo") variable log.lstat newdata[50,8]: log.lstat rm.squared crim ptratio tax dis rad chas 1 0.5481214 38.54547 0.25651 19.05 330 3.20745 24 no 2 0.6111556 38.54547 0.25651 19.05 330 3.20745 24 no 3 0.6741898 38.54547 0.25651 19.05 330 3.20745 24 no ... 0.7372240 38.54547 0.25651 19.05 330 3.20745 24 no 50 3.6367964 38.54547 0.25651 19.05 330 3.20745 24 no factors: rad(ordered) chas stats::predict(lmtree.object, data.frame[50,8], type="response") predict returned[50,1] with no column names: 1 23.25924 2 23.24236 3 23.22549 ... 23.20861 50 22.43238 predict after processing with nresponse=1 is [50,1]: predict 1 23.25924 2 23.24236 3 23.22549 ... 23.20861 50 22.43238 Reducing trace level for subsequent degree1 plots degree1 plot2 (pmethod "plotmo") variable rm.squared degree1 plot3 (pmethod "plotmo") variable ptratio degree1 plot4 (pmethod "plotmo") variable tax --plot.degree2(draw.plot=FALSE) degree2 plot1 (pmethod "plotmo") variables log.lstat:rm.squared newdata[400,8]: log.lstat rm.squared crim ptratio tax dis rad chas 1 0.5481214 12.68072 0.25651 19.05 330 3.20745 24 no 2 0.7106832 12.68072 0.25651 19.05 330 3.20745 24 no 3 0.8732451 12.68072 0.25651 19.05 330 3.20745 24 no ... 1.0358069 12.68072 0.25651 19.05 330 3.20745 24 no 400 3.6367964 77.08840 0.25651 19.05 330 3.20745 24 no factors: rad(ordered) chas stats::predict(lmtree.object, data.frame[400,8], type="response") predict returned[400,1] with no column names: 1 6.346628 2 6.303109 3 6.259590 ... 6.216071 400 47.635075 predict after processing with nresponse=1 is [400,1]: predict 1 6.346628 2 6.303109 3 6.259590 ... 6.216071 400 47.635075 Reducing trace level for subsequent degree2 plots degree2 plot2 (pmethod "plotmo") variables log.lstat:ptratio degree2 plot3 (pmethod "plotmo") variables log.lstat:tax degree2 plot4 (pmethod "plotmo") variables rm.squared:ptratio degree2 plot5 (pmethod "plotmo") variables rm.squared:tax degree2 plot6 (pmethod "plotmo") variables ptratio:tax --done get.ylim.by.dummy.plots ylim c(3.124, 53.64) clip TRUE --plot.degree1(draw.plot=TRUE) plotmo grid: log.lstat rm.squared crim ptratio tax dis rad chas 2.430097 38.54547 0.25651 19.05 330 3.20745 24 no graphics::plot.default(x=c(0.548,0.611,0...), y=c(23.26,23.24,2...), type="n", main="1 log.lstat", xlab="", ylab="", xaxt="s", yaxt="s", xlim=c(0.548,3.637), ylim=c(3.12,53.64)) --plot.degree2(draw.plot=TRUE) persp(log.lstat:rm.squard) theta 55 persp(log.lstat:ptratio) theta 145 persp(log.lstat:tax) theta 55 persp(rm.squard:ptratio) theta 235 persp(rm.squard:tax) theta 235 persp(ptratio:tax) theta 145 > plotmo(lmtree.boston2, trace=1, all1=TRUE, degree2=c("ptratio", "log.lstat"), SHOWCALL=TRUE) variable importance: log.lstat rm.squared tax ptratio stats::predict(lmtree.object, data.frame[3,8], type="response") stats::fitted(object=party_plotmo.object) got model response from model.frame(medv ~ log.lstat + rm.squared + (crim..., data=call$data, na.action="na.pass") plotmo grid: log.lstat rm.squared crim ptratio tax dis rad chas 2.430097 38.54547 0.25651 19.05 330 3.20745 24 no > plotmo(lmtree.boston2, all1=TRUE, all2=TRUE, SHOWCALL=TRUE) plotmo grid: log.lstat rm.squared crim ptratio tax dis rad chas 2.430097 38.54547 0.25651 19.05 330 3.20745 24 no > > # TODO gives warnings because of because of price/citations in formula > # data("Journals", package = "AER") > # Journals <- transform(Journals, > # age = 2000 - foundingyear, > # chars = charpp * pages) > # j_tree <- lmtree(log(subs) ~ log(price/citations) | price + citations + > # age + chars + society, data = Journals, minsize = 10) > # plotmo(j_tree, SHOWCALL=TRUE) > > # Works, but commented out to save testing time: > # data("TeachingRatings", package = "AER") > # tr_tree <- lmtree(eval ~ beauty | age + gender + division, > # data = TeachingRatings, weights = students, subset = credits == "more", > # caseweights = FALSE) > # plot(tr_tree) > # plotmo(tr_tree, all1=TRUE, all2=TRUE, SHOWCALL=TRUE) > > # glmtree > > glmtree1 <- glmtree(diabetes ~ glucose | mass + age, + data = PimaIndiansDiabetes, family = binomial) > plot(glmtree1) Loading required namespace: vcd > plotmo(glmtree1, SHOWCALL=TRUE) plotmo grid: glucose mass age 117 32 29 > plotmo(glmtree1, all2=TRUE, SHOWCALL=TRUE) plotmo grid: glucose mass age 117 32 29 > > # mob > > pima <- PimaIndiansDiabetes[1:50,] # small set of data for fast test > > logit1 <- function(y, x, start = NULL, weights = NULL, offset = NULL, ...) + { + # note that a complicated formula is necessary + formula <- as.formula(paste("y ~ ", paste(colnames(x)[-1], collapse="+"))) # -1 drops intercept + glm(formula=formula, data=as.data.frame(x), family=binomial, start=start, ...) + } > mob1 <- mob(diabetes ~ glucose | mass + age, + data = PimaIndiansDiabetes, fit = logit1) > plot(mob1) > plotmo(mob1, trace=1, SHOWCALL=TRUE) variable importance: glucose mass age stats::predict(modelparty.object, data.frame[3,3], type="response") stats::fitted(object=party_plotmo.object) got model response from model.frame(diabetes ~ glucose + (mass + age), data=call$data, na.action="na.pass") plotmo grid: glucose mass age 117 32 29 > plotmo(mob1, pmethod="partdep", degree1=0, + degree2=c("glucose", "mass"), persp.ticktype="detailed", SHOWCALL=TRUE) calculating partdep for glucose:mass 01234567890 > plotmo(mob1, all1=TRUE, all2=TRUE, SHOWCALL=TRUE) plotmo grid: glucose mass age 117 32 29 > > logit2 <- function(y, x, start = NULL, weights = NULL, offset = NULL, ...) + { + glm(y ~ 0 + x, family = binomial, start = start, ...) + } > mob2 <- mob(diabetes ~ glucose | mass, data = pima, fit = logit2) > expect.err(try(plotmo(mob2)), "The formula in the mob fit function is not supported by plotmo") The following formula in the mob fit function is not supported by plotmo: glm(y ~ 0 + x, family = binomial, start = start, ...) Possible workaround: Replace the fit function with: logit2 <- function (y, x, start = NULL, weights = NULL, offset = NULL, ...) { glm(as.formula(paste("y ~ ", paste(colnames(x)[-1], collapse="+"))), data=x, family = binomial, start = start, ...) } Error : The formula in the mob fit function is not supported by plotmo (see above) This is because predict.mob often fails with newdata and type="response" e.g. example(mob); predict(pid_tree, newdata=PimaIndiansDiabetes[1:3,], type="response") Got expected error from try(plotmo(mob2)) > > logit3 <- function(y, x, start = NULL, weights = NULL, offset = NULL, ...) + { + glm(y ~ 0+x , family = binomial, start = start, ...) + } > mob3 <- mob(diabetes ~ glucose | age, data = pima, fit = logit3) > expect.err(try(plotmo(mob3)), "The formula in the mob fit function is not supported by plotmo") The following formula in the mob fit function is not supported by plotmo: glm(y ~ 0 + x, family = binomial, start = start, ...) Possible workaround: Replace the fit function with: logit3 <- function (y, x, start = NULL, weights = NULL, offset = NULL, ...) { glm(as.formula(paste("y ~ ", paste(colnames(x)[-1], collapse="+"))), data=x, family = binomial, start = start, ...) } Error : The formula in the mob fit function is not supported by plotmo (see above) This is because predict.mob often fails with newdata and type="response" e.g. example(mob); predict(pid_tree, newdata=PimaIndiansDiabetes[1:3,], type="response") Got expected error from try(plotmo(mob3)) > > logit4 <- function(y, x, start = NULL, weights = NULL, offset = NULL, ...) + { + glm(y ~ x - 1, family = binomial, start = start, ...) + } > mob4 <- mob(diabetes ~ glucose | age, data = pima, fit = logit4) > expect.err(try(plotmo(mob4)), "The formula in the mob fit function is not supported by plotmo") The following formula in the mob fit function is not supported by plotmo: glm(y ~ x - 1, family = binomial, start = start, ...) Possible workaround: Replace the fit function with: logit4 <- function (y, x, start = NULL, weights = NULL, offset = NULL, ...) { glm(as.formula(paste("y ~ ", paste(colnames(x)[-1], collapse="+"))), data=x, family = binomial, start = start, ...) } Error : The formula in the mob fit function is not supported by plotmo (see above) This is because predict.mob often fails with newdata and type="response" e.g. example(mob); predict(pid_tree, newdata=PimaIndiansDiabetes[1:3,], type="response") Got expected error from try(plotmo(mob4)) > > logit5 <- function(y, x, start = NULL, weights = NULL, offset = NULL, ...) + { + glm(y~x-1 , family = binomial, start = start, ...) + } > mob5 <- mob(diabetes ~ glucose | age, data = pima, fit = logit5) > expect.err(try(plotmo(mob5)), "The formula in the mob fit function is not supported by plotmo") The following formula in the mob fit function is not supported by plotmo: glm(y ~ x - 1, family = binomial, start = start, ...) Possible workaround: Replace the fit function with: logit5 <- function (y, x, start = NULL, weights = NULL, offset = NULL, ...) { glm(as.formula(paste("y ~ ", paste(colnames(x)[-1], collapse="+"))), data=x, family = binomial, start = start, ...) } Error : The formula in the mob fit function is not supported by plotmo (see above) This is because predict.mob often fails with newdata and type="response" e.g. example(mob); predict(pid_tree, newdata=PimaIndiansDiabetes[1:3,], type="response") Got expected error from try(plotmo(mob5)) > > logit6 <- function (y, x, start = NULL, weights = NULL, offset = NULL, ...) + { + glm(as.formula(paste("y ~ ", paste(colnames(x)[-1], collapse="+"))), + data=data.frame(x), family = binomial, start = start, ...) + } > mob6 <- mob(diabetes ~ glucose | mass + age, data = pima, fit = logit6) > plot(mob6) # tree is just a root (no branches) > plotmo(mob6) plotmo grid: glucose mass age 118.5 31.35 33 > > library(rpart.plot) Loading required package: rpart > rpart.Kyphosis <- rpart(Kyphosis ~ Age + Number + Start, data = kyphosis) > plotmo(rpart.Kyphosis, SHOWCALL=TRUE) plotmo grid: Age Number Start 87 4 13 > party.Kyphosis <- as.party(rpart.Kyphosis) > expect.err(try(plotmo(party.Kyphosis)), "cannot get the original model predictors") Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: object 'Kyphosis' not found (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(plotmo(party.Kyphosis)) > > library(evtree) > ## regression > set.seed(1090) > airq <- subset(airquality, !is.na(Ozone) & complete.cases(airquality)) > ev_air <- evtree(Ozone ~ ., data = airq) > # plot(ev_air) > plotmo(ev_air, SHOWCALL=TRUE) plotmo grid: Solar.R Wind Temp Month Day 207 9.7 79 7 16 > ## classification > ev_iris <- evtree(Species ~ .,data = iris) > # plot(ev_iris) > plotmo(ev_iris, SHOWCALL=TRUE) plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 5.8 3 4.35 1.3 > plotmo(ev_iris, type="prob", nresponse="versicolor", pmethod="apartdep", SHOWCALL=TRUE) calculating apartdep for Petal.Length calculating apartdep for Petal.Width calculating apartdep for Petal.Length:Petal.Width 01234567890 > plotres(ev_iris, type="prob", nresponse="setosa", SHOWCALL=TRUE) > > # cforest > > cforest1 <- cforest(dist ~ speed, data = cars) > plotmo(cforest1, trace=1, SHOWCALL=TRUE) variable importance: speed stats::predict(cforest.object, data.frame[3,1], type="response") stats::fitted(object=cforest.object) got model response from model.frame(dist ~ speed, data=object$data, na.action="na.fail") > plotres(cforest1, trace=1, SHOWCALL=TRUE) variable importance: speed stats::residuals(object=cforest.object, type="response") residuals() was unsuccessful, will use predict() instead stats::predict(cforest.object, data.frame[3,1], type="response") stats::fitted(object=cforest.object) got model response from model.frame(dist ~ speed, data=object$data, na.action="na.fail") training rsq 0.58 > > data("mammoexp", package = "TH.data") > cforest2 <- cforest(ME ~ PB + SYMPT, data = mammoexp, ntree = 5) > plotmo(cforest2, trace=1, SHOWCALL=TRUE, pmethod="apartdep") variable importance: SYMPT PB stats::predict(cforest.object, data.frame[3,2], type="response") stats::fitted(object=cforest.object) got model response from model.frame(ME ~ PB + SYMPT, data=object$data, na.action="na.fail") calculating apartdep for PB calculating apartdep for SYMPT calculating apartdep for PB:SYMPT 01234567890 > plotres(cforest2) > > source("test.epilog.R") plotmo/inst/slowtests/test.plotmo.dots.bat0000755000176200001440000000156114563571565020567 0ustar liggesusers@rem test.plotmo.dots.R: test handling of dots arguments @echo test.plotmo.dots.bat @"C:\PROGRA~1\R\R-4.3.2\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.plotmo.dots.R @if %errorlevel% equ 0 goto good1: @echo R returned errorlevel %errorlevel%, see test.plotmo.dots.Rout: @echo. @tail test.plotmo.dots.Rout @echo test.plotmo.dots.R @exit /B 1 :good1 mks.diff test.plotmo.dots.Rout test.plotmo.dots.Rout.save @if %errorlevel% equ 0 goto good2: @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.plotmo.dots.save.ps @exit /B 1 :good2 @rem test.plotmo.dots.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.plotmo.dots.save.ps @if %errorlevel% equ 0 goto good3: @echo === Files are different === @exit /B 1 :good3 @rm -f test.plotmo.dots.Rout @rm -f Rplots.ps @exit /B 0 plotmo/inst/slowtests/test.dots.R0000644000176200001440000007355014055527241016701 0ustar liggesusers# test.dots.R source("test.prolog.R") cat0("=== test dotindex\n") test.dotindex <- function(expected, ARGNAME, ..., EX=FALSE) { dotindex <- plotmo:::dotindex(ARGNAME=ARGNAME, EX=EX, ...) stopifnot(all.equal(dotindex, expected)) } test.dotindex(NA, "x") # empty dots test.dotindex(NA, "x", a=10, b=20) test.dotindex(1, "a", a=10, b=20) test.dotindex(2, "b", a=10, b=20) test.dotindex(1, "a1", a=10, b=20) test.dotindex(NA, "a", a1=10, a2=20) expect.err(try(test.dotindex(1, nonesuch, a=10, a=20)), "object 'nonesuch' not found") expect.err(try(test.dotindex(1, "a1", a=10, a=20)), "argument 'a' for test.dotindex() is duplicated") expect.err(try(test.dotindex(1, "aa1", a=10, aa=20)), "arguments 'a' and 'aa' both match 'aa1' in test.dotindex") stopifnot(is.na(plotmo:::dotindex("a", EX=1, a1=10, a2=20))) stopifnot(plotmo:::dotindex("a2", EX=1, a1=10, a2=20) == 2) # multiple argnames test.dotindex(NA, c("a", "b")) # empty dots test.dotindex(1, c("a", "b"), a=2, c=3) test.dotindex(1, c("a", "b"), a=5, b=6) test.dotindex(2, c("a", "b"), x=1, a=5, b=6) test.dotindex(3, c("b,a"), x=1, a=5, b=6) test.dotindex(1, c("a b"), b=3, c=4) test.dotindex(2, c(" a b "), c=3, b=4) test.dotindex(NA, c("a", "b"), c=3) stopifnot(plotmo:::dotindex(c("x", "a1"), EX=1, a1=10, a2=20) == 1) test.dota <- function(expected, ARGNAME, ..., DEF=NA, EX=FALSE) { if(is.na(DEF)) dot <- plotmo:::dota(ARGNAME, EX=EX, ...) else dot <- plotmo:::dota(ARGNAME, EX=EX, DEF=DEF, ...) stopifnot(all.equal(dot, expected)) } cat0("=== test dot\n") test.dota(NA, "x") # empty dots test.dota(NA, "x", a=10, b=20) test.dota(10, "a", a=10, b=20) test.dota(20, "b", a=10, b=20) test.dota(99, DEF=99, "nonesuch", a=10, b=20) test.dota(NA, "a", a1=10, a2=20) expect.err(try(test.dota(1, "a1", a=10, a=20)), "argument 'a' for test.dota() is duplicated") expect.err(try(test.dota(1, 99, a=10, a=20)), "is.character(argname) is not TRUE") expect.err(try(test.dota(1, test.dota, a=10, a=20)), "is.character(argname) is not TRUE") expect.err(try(test.dota(1, "", a=10, a=20)), "empty string in ARGNAME") expect.err(try(test.dota(1, "x^x", a=10, a=20)), "illegal character \"^\" in ARGNAME") test.dota(10, "abc", EX=T, abc=10) test.dota(NA, "a", EX=T, a1=10, a2=20) expect.err(try(test.dota(1, "a1", a1=10, a1=20)), "argument 'a1' for test.dota() is duplicated") stopifnot(is.na(plotmo:::dota("a", EX=1, a1=1, a2=2))) stopifnot(plotmo:::dota("a2", EX=1, a1=10, a2=20, a3=30) == 20) foo <- function(func, x) func(x) foo(mean, 33) foo(function(...) plotmo:::dota("x", ...), 33) foo(function(...) plotmo:::dota("x99", ...), 33) foo(function(...) { plotmo:::dota("nonesuch", ...) }, 33) test.dota(1, "a", EX=T, a=1) test.dota(2, "b", EX=T, a=1, b=2, c=3) test.dota(NA, "x", EX=T, a=1, b=2, c=3) test.dota(2, "a", EX=T, ab=1, a=2) test.dota(2, "a", EX=T, aa=1, a=2) test.dota(NA, "a", EX=T, aa=1, ab=2) expect.err(try(test.dota(2, "a", EX=T, aa=1, a=2, a=3)), "argument 'a' for test.dota() is duplicated") expect.err(try(test.dota(2, "a", EX=T, a=none.such)), "cannot evaluate 'a'") # multiple argnames test.dota(2, c("a", "b"), a=2, c=3) test.dota(5, c("a", "b"), a=5, b=6) test.dota(5, c("a", "b"), x=1, a=5, b=6) test.dota(3, c("a", "b"), b=3, c=4) test.dota(4, c("a", "b"), c=3, b=4) test.dota(NA, c("a", "b"), c=3) expect.err(try(test.dota(1, c("b", "aa1"), a=10, aa=20)), "arguments 'a' and 'aa' both match 'aa1' in test.dota") expect.err(try(test.dota(1, c("x", ""), a=10, b=20)), "empty string in ARGNAME") stopifnot(plotmo:::dota(c("x", "a2", "y"), EX=1, a1=10, a2=20, a3=30) == 20) test.dota(NA, c("a", "b"), aa=2, cc=3, EX=T) test.dota(2, c("aa", "b"), aa=2, cc=3, EX=T) test.dota(3, c("bb", "b"), bb=3, cc=4, EX=T) test.dota(NA, c("a", "b"), c=3, EX=T) foo.x <- function(...) { plotmo:::dota("x", ..., DEF="default", EX=FALSE) } stopifnot(foo.x(x=3) == 3) stopifnot(foo.x(y=3) == "default") foo2 <- function(funcarg, ...) funcarg(...) stopifnot(is.na(foo2(function(...) plotmo:::dota("x", ...), 3))) # 3 is unnamed stopifnot(foo2(function(...) plotmo:::dota("x", EX=0, ...), x=3) == 3) stopifnot(foo2(function(...) plotmo:::dota("x99", EX=0, ...), x=3) == 3) stopifnot(foo2(function(...) { plotmo:::dota("x", DEF="default", EX=FALSE, ...) }, x=3) == 3) stopifnot(foo2(function(...) { plotmo:::dota("y", DEF="default", EX=FALSE, ...) }, x=3) == "default") # expect.err(try(foo2(function(...) { plotmo:::dota("y", DEF="default", EX=FALSE, ...) }, 3)), "unnamed arguments in ... are not allowed for funcarg()") stopifnot(foo2(foo.x, x=3) == 3) stopifnot(foo2(foo.x, y=3) == "default") test.is.dot <- function(expected, ARGNAME, ...) { present <- plotmo:::is.dot(ARGNAME, ...) stopifnot(all.equal(present, expected)) } cat0("=== test is.dot\n") test.is.dot(FALSE, "x") # empty dots test.is.dot(FALSE, "x", EX=0, a=10, b=20) test.is.dot(TRUE, "a", EX=0, a=10, b=20) test.is.dot(TRUE, "b", EX=0, a=10, b=20) test.is.dot(TRUE, "a1", EX=0, a=10, b=20) test.is.dot(FALSE, "a", EX=0, a1=10, a2=20) expect.err(try(test.is.dot(TRUE, "a1", EX=0, a=10, a=20)), "argument 'a' for test.is.dot() is duplicated") expect.err(try(test.is.dot(TRUE, "a", EX=0, a=10, a=20)), "argument 'a' for test.is.dot() is duplicated") stopifnot(plotmo:::is.dot("a", EX=1, a1=10, a2=20, a3=30) == FALSE) stopifnot(plotmo:::is.dot("x", EX=1, a1=10, a2=20, a3=30) == FALSE) stopifnot(plotmo:::is.dot("a3", EX=1, a1=10, a2=20, a3=30) == TRUE) # multiple argnames test.is.dot(TRUE, EX=0, c("a1", "b1"), a=2, c=3) test.is.dot(TRUE, EX=0, c("a1", "b1"), b=3, c=4) test.is.dot(TRUE, EX=0, c("a1", "b1"), c=3, b=4) test.is.dot(FALSE, EX=0, c("a1", "b1"), c=3) expect.err(try(test.is.dot(FALSE, c("aa1", "b"), EX=0, a=10, aa=20)), "arguments 'a' and 'aa' both match 'aa1' in test.is.dot") stopifnot(plotmo:::is.dot(c("x", "a", "y"), EX=1, a1=10, a2=20, a3=30) == FALSE) stopifnot(plotmo:::is.dot(c("x", "a2", "y"), EX=1, a1=10, a2=20, a3=30) == TRUE) cat0("=== test expand.drop\n") # nchar is used an example func, it has formals "x", "type", "allowNA" stopifnot(is.null(plotmo:::expand.drop(NULL, prefix="prefix.", func=nchar))) stopifnot(plotmo:::expand.drop("a", prefix="prefix.", func=nchar) == ">PREFIX|>EXPLICIT|^a") stopifnot(plotmo:::expand.drop("a", prefix="prefix.", func=nchar, include.standard.prefixes=TRUE) == ">STANDARDPREFIXES|^force\\.|^def\\.|^drop\\.|>PREFIX|^prefix\\.|>EXPLICIT|^a") stopifnot(plotmo:::expand.drop("FORMALS", prefix="prefix.", func=base::nchar) == ">FORMALS|^x|^type|^allowNA|^keepNA|>PREFIX|>EXPLICIT") stopifnot(plotmo:::expand.drop("FORMALS", prefix="prefix.", func=base::nchar, include.standard.prefixes=TRUE) == ">FORMALS|^x|^type|^allowNA|^keepNA|>STANDARDPREFIXES|^force\\.|^def\\.|^drop\\.|>PREFIX|^prefix\\.|>EXPLICIT") expect.err(try(plotmo:::expand.drop("FORMALS", prefix="prefix.", func=NULL)), "\"FORMALS\" specified in DROP, but FUNC is NULL") expect.err(try(plotmo:::expand.drop("FORMALS", prefix="prefix.", func=base::c)), "\"FORMALS\" specified but formals(FUNC) returned no formal arguments") foo99 <- function(...) NULL expect.err(try(plotmo:::expand.drop("FORMALS", prefix="prefix.", func=foo99)), "\"FORMALS\" specified but formals(FUNC) returned only \"...\"") stopifnot(plotmo:::expand.drop("a,FORMALS", prefix="prefix.", func=base::nchar) == ">FORMALS|^x|^type|^allowNA|^keepNA|>PREFIX|>EXPLICIT|^a") stopifnot(plotmo:::expand.drop("a,FORMALS", prefix="prefix.", func=base::nchar, include.standard.prefixes=TRUE) == ">FORMALS|^x|^type|^allowNA|^keepNA|>STANDARDPREFIXES|^force\\.|^def\\.|^drop\\.|>PREFIX|^prefix\\.|>EXPLICIT|^a") expect.err(try(plotmo:::expand.drop("", prefix="prefix.", func=base::nchar)), "DROP is an empty string") stopifnot(plotmo:::expand.drop("a", prefix="lines.", func=base::nchar) == ">PREFIX|>EXPLICIT|^a") stopifnot(plotmo:::expand.drop("a", "lines.a", prefix="lines.", func=base::nchar, include.standard.prefixes=TRUE) == ">STANDARDPREFIXES|^force\\.|^def\\.|^drop\\.|>PREFIX|^lines\\.|>EXPLICIT|^a") stopifnot(plotmo:::expand.drop("a*", prefix="lines.", func=base::nchar) == ">PREFIX|>EXPLICIT|^a.*") stopifnot(plotmo:::expand.drop("a.*", prefix="lines.", func=base::nchar) == ">PREFIX|>EXPLICIT|^a\\..*") stopifnot(plotmo:::expand.drop("a$", prefix="lines.", func=base::nchar) == ">PREFIX|>EXPLICIT|^a$") stopifnot(plotmo:::expand.drop("a$,b*,c*$", prefix="lines.", func=base::nchar) == ">PREFIX|>EXPLICIT|^a$|^b.*|^c.*$") stopifnot(plotmo:::expand.drop(c("a", "b,c", " d e$ f ", "g h$, i"), prefix="lines.", func=base::nchar) == ">PREFIX|>EXPLICIT|^a|^b|^c|^d|^e$|^f|^g|^h$|^i") stopifnot(plotmo:::expand.drop("PLOT.ARGS", prefix="lines.", func=base::nchar) == ">PREFIX|>EXPLICIT|>PLOT_ARGS|^add$|^adj$|^bty$|^cex$|^cex\\.axis$|^cex\\.lab$|^cex\\.main$|^cex\\.sub$|^col$|^col\\.axis$|^col\\.lab$|^col\\.main$|^col\\.sub$|^crt$|^family$|^font$|^font$|^font\\.axis$|^font\\.lab$|^font\\.main$|^font\\.sub$|^lend$|^ljoin$|^lmitre$|^lty$|^lwd$|^main$|^pch$|^srt$|^xaxp$|^xaxs$|^xaxt$|^xlab$|^xlim$|^xlog$|^xpd$|^yaxp$|^yaxs$|^yaxt$|^ylab$|^ylim$|^ylog$") stopifnot(plotmo:::expand.drop("abc,PLOT.ARGS", prefix="lines.", func=base::nchar) == ">PREFIX|>EXPLICIT|^abc|>PLOT_ARGS|^add$|^adj$|^bty$|^cex$|^cex\\.axis$|^cex\\.lab$|^cex\\.main$|^cex\\.sub$|^col$|^col\\.axis$|^col\\.lab$|^col\\.main$|^col\\.sub$|^crt$|^family$|^font$|^font$|^font\\.axis$|^font\\.lab$|^font\\.main$|^font\\.sub$|^lend$|^ljoin$|^lmitre$|^lty$|^lwd$|^main$|^pch$|^srt$|^xaxp$|^xaxs$|^xaxt$|^xlab$|^xlim$|^xlog$|^xpd$|^yaxp$|^yaxs$|^yaxt$|^ylab$|^ylim$|^ylog$") stopifnot(plotmo:::expand.drop("abc,FORMALS,PLOT.ARGS", prefix="lines.", func=base::nchar) == ">FORMALS|^x|^type|^allowNA|^keepNA|>PREFIX|>EXPLICIT|^abc|>PLOT_ARGS|^add$|^adj$|^bty$|^cex$|^cex\\.axis$|^cex\\.lab$|^cex\\.main$|^cex\\.sub$|^col$|^col\\.axis$|^col\\.lab$|^col\\.main$|^col\\.sub$|^crt$|^family$|^font$|^font$|^font\\.axis$|^font\\.lab$|^font\\.main$|^font\\.sub$|^lend$|^ljoin$|^lmitre$|^lty$|^lwd$|^main$|^pch$|^srt$|^xaxp$|^xaxs$|^xaxt$|^xlab$|^xlim$|^xlog$|^xpd$|^yaxp$|^yaxs$|^yaxt$|^ylab$|^ylim$|^ylog$") stopifnot(plotmo:::expand.drop("abc,FORMALS,PAR.ARGS", prefix="lines.", func=base::nchar) == ">FORMALS|^x|^type|^allowNA|^keepNA|>PREFIX|>EXPLICIT|^abc|>PAR_ARGS|^adj$|^ann$|^ask$|^bg$|^bty$|^cex$|^cex\\.axis$|^cex\\.lab$|^cex\\.main$|^cex\\.sub$|^col\\.axis$|^col\\.lab$|^col\\.main$|^col\\.sub$|^crt$|^err$|^family$|^fg$|^fig$|^fin$|^font$|^font\\.axis$|^font\\.lab$|^font\\.main$|^font\\.sub$|^lab$|^las$|^lend$|^lheight$|^ljoin$|^lmitre$|^lty$|^mai$|^mar$|^mex$|^mfcol$|^mfg$|^mfrow$|^mgp$|^mkh$|^new$|^oma$|^omd$|^omi$|^pch$|^pin$|^plt$|^ps$|^pty$|^srt$|^tck$|^tcl$|^usr$|^xaxp$|^xaxs$|^xaxt$|^xlog$|^xpd$|^yaxp$|^yaxs$|^yaxt$|^ylbias$|^ylog$") stopifnot(plotmo:::expand.drop("abc,FORMALS,PLOTMO.ARGS", prefix="lines.", func=base::nchar) == ">FORMALS|^x|^type|^allowNA|^keepNA|>PREFIX|>EXPLICIT|^abc|>PLOTMO_ARGS|^caption\\.|^cex\\.|^col\\.|^contour\\.|^cum\\.|^degree1\\.|^degree2\\.|^density\\.|^filled\\.contour\\.|^font\\.|^func\\.|^grid\\.|^heatmap\\.|^image\\.|^jitter\\.|^legend\\.|^label\\.|^level\\.|^line\\.|^lines\\.|^lty\\.|^lty\\.|^lwd\\.|^main\\.|^mtext\\.|^nresiduals|^par\\.|^pch\\.|^persp\\.|^plot\\.|^plotmath\\.|^prednames\\.|^qq\\.|^qqline\\.|^pt\\.|^response\\.|^rug\\.|^smooth\\.|^text\\.|^title\\.|^vfont\\.") test.deprefix <- function(expected, ..., FNAME="test.deprefix", KEEP=NULL) { args <- plotmo:::deprefix(..., FNAME=FNAME, KEEP=KEEP, CALLARGS="") # can't use all.equal because it complains about names # cat("args:\n") # print(args) # cat("expected:\n") # print(expected) stopifnot(length(args) == length(expected)) for(i in seq_len(length(expected))) { stopifnot(names(args)[i] == names(expected)[i]) stopifnot(args[[i]] == expected[[i]]) } } cat0("=== test deprefix\n") test.deprefix( expected=list(a=1, b=2), DROP="*", PREFIX="predict.", def.a=1, predict.b=2, c=3) test.deprefix(TRACE=2, expected=list(b="predict.b", d="def.d", c="predict.c", e="predict.e"), PREFIX="predict.", DROP="*", a="a", b="b", c="c", w1.xlab="xlab", def.b="def.b", def.d="def.d", predict.b="predict.b", predict.c="predict.c", predict.e="predict.e") test.deprefix(TRACE=2, expected=list(b="predict.b", d="def.d", a="a", c="predict.c", e="predict.e"), KEEP=NULL, PREFIX="predict.", DROP="w1.", a="a", b="b", c="c", w1.xlab="xlab", def.b="def.b", def.d="def.d", predict.b="predict.b", predict.c="predict.c", predict.e="predict.e") test.deprefix( expected=list(a="predict.a"), KEEP=NULL, PREFIX="predict.", DROP="w1.", a="plain.a", predict.a="predict.a") test.deprefix(expected=list(a="aa1"), KEEP=NULL, PREFIX="predict.", a="aa1") test.deprefix(expected=list(a="aa2"), KEEP=NULL, PREFIX="predict.", def.a="aa2") test.deprefix(expected=list(a="aa3", b="bb3"), KEEP=NULL, PREFIX="predict.", def.a="aa3", b="bb3") test.deprefix(expected=list(10, 20), TRACE=2, KEEP=NULL, DROP="w1.,persp.,xlab.", PREFIX="predict.", force.anon2=20, force.anon1=10) test.deprefix(expected=list(10, 20, a=3), TRACE=2, KEEP=NULL, DROP="w1.,persp.,xlab.", PREFIX="predict.", force.anon2=20, force.anon1=10, a=3) expect.err(try(test.deprefix(expected=list(10, 20, a=4), KEEP=NULL, DROP="w1.,persp.,xlab.", PREFIX="predict.", force.anon=10, force.anon=20, a=3, predict.a=4)), "argument 'force.anon' for test.deprefix() is duplicated") expect.err(try(test.deprefix(expected=list(10, 20, a=4), KEEP=NULL, DROP="w1.,persp.,xlab.", PREFIX="predict.", FNAME="foobar", force.anon=10, force.anon=20, a=3, predict.a=4)), "argument 'force.anon' for foobar() is duplicated") test.deprefix(expected=list(10, 20, a=4), KEEP=NULL, DROP="w1.,persp.,xlab.", PREFIX="predict.", force.anon1=10, force.anon2=20, a=3, predict.a=4) test.deprefix(expected=list(10, 20, b=3, a=4), KEEP=NULL, DROP="w1.,persp.,xlab.", PREFIX="predict.", force.anon1=10, force.anon2=20, def.b=3, a=3, predict.a=4) test.deprefix(expected=list(10, 20, b=5, a=3), KEEP=NULL, DROP="w1.,persp.,xlab.", PREFIX="predict.", force.anon1=10, force.anon2=20, def.b=3, a=3, predict.b=5) test.deprefix(expected=list(10, 20, b=6, a=3), KEEP=NULL, DROP="w1.,persp.,xlab.", PREFIX="predict.", force.anon1=10, force.anon2=20, def.b=3, a=3, b=6) expect.err(try(test.deprefix(expected=NULL, KEEP=NULL, PREFIX="predict.", DROP="w1\\.")), "illegal character \"\\\" in DROP = \"w1\\.\"") test.deprefix(expected=list(b="predict.b", d="def.d", a="a", c="predict.c", w1.xl="xlab2", e="predict.e"), PREFIX="predict.", DROP="w1.xlab$", a="a", b="b", c="c", w1.xlab="xlab1", # will be dropped (exact match) w1.xl="xlab2", # will be kept (not an exact match) def.b="def.b", def.d="def.d", predict.b="predict.b", predict.c="predict.c", predict.e="predict.e") # expect.err(try(plotmo:::deprefix(FNAME="test.deprefix", PREFIX="predict.", UPPER.CASE123=99, # def.a=1, predict.b=2, c=3)), # "uppercase argument names like \"UPPER.CASE123\" are not allowed for test.deprefix()") test.expand.dotnames <- function(expected, PREFIX, FUNC=NULL, FNAME="test.expand.dotnames", FORMALS=NULL, ...) { dots <- as.list(match.call(expand.dots=FALSE)$...) args <- plotmo:::expand.dotnames(dots, PREFIX, FUNC, FNAME, FORMALS) # can't use all.equal because it complains about named list versus unnamed list stopifnot(length(args) == length(expected)) for(i in seq_len(length(expected))) { stopifnot(names(args)[i] == names(expected)[i]) stopifnot(eval(args[[i]]) == expected[[i]]) } } cat0("=== test expand.dotnames\n") test.expand.dotnames(expected=list(x=9, persp.shade=3), "persp.", graphics:::persp.default, "persp.default", x=9, persp.sh=3) test.expand.dotnames(expected=list(x=9, persp.shade=3, persp.nonesuch=4), "persp.", graphics:::persp.default, "persp.default", x=9, persp.sh=3, persp.nonesuch=4) test.expand.dotnames(expected=list(x=9, persp.col=3), "persp.", graphics:::persp.default, "persp.default", x=9, persp.c=3) # TODO not sure why this works as it does test.expand.dotnames(expected=list(x=9, persp.x=3), "persp.", graphics:::persp.default, "persp.default", x=9, persp.x=3) expect.err(try(test.expand.dotnames(expected=NULL, "persp.", graphics:::persp.default, "persp.default", x=9, persp.l=3)), "'l' matches both the 'ltheta' and 'lphi' arguments of persp.default()") test.expand.dotnames(expected=list(x=9, plot.foo=3, plot.xlim=c(1,2)), "plot.", graphics:::plot.default, "plot.default", x=9, plot.foo=3, plot.xlim=c(1,2)) test.expand.dotnames(expected=list(x=9, plot.foo=3, plot.xlim=c(1,2)), "plot.", graphics:::plot.default, "plot.default", x=9, plot.foo=3, plot.xli=c(1,2)) expect.err(try(test.expand.dotnames(expected=NULL, "plot.", graphics:::plot.default, "plot.default", x=9, plot.foo=3, plot.xl=c(1,2))), "'xl' matches both the 'xlim' and 'xlab' arguments of plot.default()") foo3 <- function(aaa=1, aa=2, bb=3, bba=4, cca=5, ccb=6, def=7) cat0("foo3: aaa=", aaa, " aa=", aa, ", bb=", bb, " bba=", bba, " cca=", cca, " ccb=", ccb, " def=", def, "\n") # --- above tests again but using formals --- # formal args for graphics:::persp.default (R version 3.2.0) formals <- c( "x", "y", "z", "xlim", "zlim", "xlab", "ylab", "zlab", "main", "sub", "theta", "phi", "r", "d", "scale", "expand", "col", "border", "ltheta", "lphi", "shade", "box", "axes", "nticks", "ticktype") test.expand.dotnames(expected=list(x=9, persp.shade=3), "persp.", graphics:::persp, "persp", FORMALS=formals, x=9, persp.sh=3) test.expand.dotnames(expected=list(x=9, persp.shade=3, persp.nonesuch=4), "persp.", graphics:::persp, "persp", FORMALS=formals, x=9, persp.sh=3, persp.nonesuch=4) test.expand.dotnames(expected=list(x=9, persp.col=3), "persp.", graphics:::persp, "persp", FORMALS=formals, x=9, persp.c=3) # TODO not sure why this works as it does test.expand.dotnames(expected=list(x=9, persp.x=3), "persp.", graphics:::persp, "persp", FORMALS=formals, x=9, persp.x=3) expect.err(try(test.expand.dotnames(expected=NULL, "persp.", graphics:::persp, "persp", FORMALS=formals, x=9, persp.l=3)), "'l' matches both the 'ltheta' and 'lphi' arguments of persp()") # done formals tests test.expand.dotnames(expected=list(x=9, plot.foo=3, plot.xlim=c(1,2)), "plot.", graphics:::plot.default, "plot.default", x=9, plot.foo=3, plot.xlim=c(1,2)) test.expand.dotnames(expected=list(x=9, plot.foo=3, plot.xlim=c(1,2)), "plot.", graphics:::plot.default, "plot.default", x=9, plot.foo=3, plot.xli=c(1,2)) expect.err(try(test.expand.dotnames(expected=NULL, "plot.", graphics:::plot.default, "plot.default", x=9, plot.foo=3, plot.xl=c(1,2))), "'xl' matches both the 'xlim' and 'xlab' arguments of plot.default()") test.expand.dotnames(expected=list(foo3.aa=99), "foo3.", foo3, "foo3", foo3.aa=99) expect.err(try(plotmo:::call.plot(foo3, "foo3.", foo3.aa=99)), "Unnamed arguments are not allowed here\n The argument's value is \"foo3.\"") expect.err(try(plotmo:::call.plot(foo3, foo, foo3.aa=99)), "Unnamed arguments are not allowed here\n The argument's value is function.object") expect.err(try(plotmo:::call.plot(foo3, NULL, foo3.aa=99)), "Unnamed arguments are not allowed here\n The argument's value is NULL") expect.err(try(plotmo:::call.plot(foo3, stop("stop was called"), foo3.aa=99)), "Unnamed arguments are not allowed here (argument ..1 is unnamed)") expect.err(try(plotmo:::call.plot(foo3, cat("side effect\n"), foo3.aa=99)), "Unnamed arguments are not allowed here\n The argument's value is NULL") expect.err(try(plotmo:::call.plot(foo3, nonesuch1=1, nonesuch2, foo3.aa=99)), "Unnamed arguments are not allowed here (argument ..2 is unnamed)") plotmo:::call.plot(foo3, PREFIX="foo3.", foo3.aa=99) test.expand.dotnames(expected=list(foo3.aaa=99), "foo3.", foo3, "foo3", foo3.aaa=99) plotmo:::call.plot(foo3, foo3.aaa=99) expect.err(try(test.expand.dotnames(expected=list(foo3.aaa=99), "foo3.", foo3, "foo3", foo3.aa=88, foo3.aa=99)), "'foo3.aa' for foo3() is duplicated") expect.err(try(test.expand.dotnames(expected=list(foo3.aaa=99), "foo3.", foo3, "foo3", foo3.a=88, foo3.aa=99)), "'a' matches both the 'aaa' and 'aa' arguments of foo3()") expect.err(try(test.expand.dotnames(expected=list(foo3.aaa=99), "foo3.", foo3, "foo3", foo3.aaa=88, foo3.aaa=99)), "'foo3.aaa' for foo3() is duplicated") test.expand.dotnames(expected=list(foo3.bbb=88, foo3.bba=99), "foo3.", foo3, "foo3", foo3.bbb=88, foo3.bba=99) expect.err(try(plotmo:::call.plot(foo3, foo3.bbb=88, foo3.bba=99)), "unused argument (bbb = 88)") # same as above but with TRACE (so don't use try in call.dots) expect.err(try(plotmo:::call.plot(foo3, foo3.bbb=88, foo3.bba=99, TRACE=T)), "unused argument (bbb = 88)") test.expand.dotnames(expected=list(foo3.bb=88), "foo3.", foo3, "foo3", foo3.bb=88) plotmo:::call.plot(foo3, foo3.bb=88) # test with FUNC=NULL test.expand.dotnames(expected=list(foo3.aa=99), "foo3.", NULL, "foo3", foo3.aa=99) plotmo:::call.plot(foo3, foo3.aa=99) test.expand.dotnames(expected=list(foo3.aaa=99), "foo3.", NULL, "foo3", foo3.aaa=99) plotmo:::call.plot(foo3, foo3.aaa=99) expect.err(try(test.expand.dotnames(expected=list(foo3.aaa=99), "foo3.", NULL, "foo3", foo3.aa=88, foo3.aa=99)), "argument 'foo3.aa' for foo3() is duplicated") test.expand.dotnames(expected=list(foo3.a=88, foo3.aa=99), "foo3.", NULL, "foo3", foo3.a=88, foo3.aa=99) expect.err(try(plotmo:::call.plot(foo3, foo3.a=88, foo3.aa=99)), "'a' matches both the 'aaa' and 'aa' arguments of foo3()") expect.err(try(test.expand.dotnames(expected=list(foo3.aaa=99), "foo3.", NULL, "foo3", foo3.aaa=88, foo3.aaa=99)), "argument 'foo3.aaa' for foo3() is duplicated") test.expand.dotnames(expected=list(foo3.bbb=88, foo3.bba=99), "foo3.", NULL, "foo3", foo3.bbb=88, foo3.bba=99) expect.err(try(plotmo:::call.plot(foo3, PREFIX="foo3.", foo3.bbb=88, foo3.bba=99)), "unused argument (bbb = 88)") test.expand.dotnames(expected=list(foo3.bb=88), "foo3.", NULL, "foo3", foo3.bb=88) plotmo:::call.plot(foo3, foo3.bb=88) test.expand.dotnames(expected=list(foo3.bbx=88), "foo3.", NULL, "foo3", foo3.bbx=88) expect.err(try(plotmo:::call.plot(foo3, foo3.bbx=88)), "unused argument (bbx = 88)") test.expand.dotnames(expected=list(foo3.cc=77), "foo3.", NULL, "foo3", foo3.cc=77) expect.err(try(plotmo:::call.plot(foo3, foo3.cc=77)), "'cc' matches both the 'cca' and 'ccb' arguments of foo3()") # following two directly compare FUNC=NULL to FUNC=foo3 test.expand.dotnames(expected=list(foo3.cc=77), "foo3.", FUNC=NULL, "foo3", foo3.cc=77) expect.err(try(test.expand.dotnames(expected=NULL, "foo3.", FUNC=foo3, "foo3", foo3.cc=77)), "'cc' matches both the 'cca' and 'ccb' arguments of foo3()") test.expand.dotnames(expected=list(), "foo3.", foo3, "foo3", d=88, de=99) expect.err(try(plotmo:::call.plot(graphics::plot, x=1:3, y=1:3, 99)), "Unnamed arguments are not allowed here\n The argument's value is 99\n plotmo:::call.plot via try called call.dots(FUNC=plot, PREFIX=PREFIX, ...") # test TRACE print(plotmo:::deprefix(FUNC=nchar, PREFIX="foo3.", TRACE=TRUE, FNAME="nchar", allowN=1, b=2, foo3.c=3)) print(plotmo:::deprefix(FUNC=nchar, PREFIX="foo3.", TRACE=2, allowN=1, b=2, foo3.c=3)) print(plotmo:::deprefix(FUNC=nchar, PREFIX="foo3.", TRACE=3, allowN=1, b=2, foo3.c=3)) expect.err(try(plotmo:::call.plot(foo3, foo3.d=88, foo3.de=99)), "'foo3.d' and 'foo3.de' both match the 'def' argument of foo3()") cat0("=== test stop.if.dots\n") foo3 <- function(x=1, ...) plotmo:::stop.if.dots(...) foo3(1) # ok expect.err(try(foo3(10, y=2)), "foo3: unrecognized argument 'y'") expect.err(try(foo3(10, 99)), "foo3: unrecognized unnamed argument\n The call was foo3(x=10, 99)") expect.err(try(foo3(10, y=plot)), "foo3: unrecognized argument 'y'") expect.err(try(foo3(10, plot)), "foo3: unrecognized unnamed argument\n The call was foo3(x=10, plot)") expect.err(try(foo3(20, c(1,2,3), plot)), "foo3: unrecognized unnamed argument\n The call was foo3(x=20, c(1,2,3), plot)") expect.err(try(foo3(20, c(1,2,3,4,5,6,7,8,9,10,11,12), plot)), "foo3: unrecognized unnamed argument\n The call was foo3(x=20, c(1,2,3,4,5,6,7,8,9,10,11,12), plot)") # test that we don't crash because we eval the argument expect.err(try(foo3(20, y=stop("stop was called"))), "foo3: unrecognized argument 'y'") expect.err(try(foo3(20, stop("stop was called"))), "foo3: unrecognized unnamed argument") expect.err(try(foo3(20, cat("side effect\n"))), "foo3: unrecognized unnamed argument\n The call was foo3(x=20, cat(") foo2 <- function(...) plotmo:::stop.if.dots(...) foo2() # ok expect.err(try(foo2(y=2)), "foo2: unrecognized argument 'y'") expect.err(try(foo2(2)), "foo2: unrecognized unnamed argument\n The call was foo2(2)") expect.err(try(foo2(y=plot)), "foo2: unrecognized argument 'y'") expect.err(try(foo2(plot)), "foo2: unrecognized unnamed argument\n The call was foo2(plot)") foo2a <- function(funcarg, ...) funcarg(...) expect.err(try(foo2a(function(x=1, ...) plotmo:::stop.if.dots(...), x=1, y=2)), "funcarg: unrecognized argument 'y'") cat0("=== test warn.if.dots\n") options(warn=2) # treat warnings as errors foo3 <- function(x=1, ...) plotmo:::warn.if.dots(...) foo3(1) # ok expect.err(try(foo3(1, y=2)), "foo3 ignored argument 'y'") expect.err(try(foo3(1, 2)), "foo3 ignored unnamed argument\n The call was foo3(x=1, 2)") expect.err(try(foo3(1, y=plot)), "foo3 ignored argument 'y'") # TODO would like to improve this error messsage expect.err(try(foo3(1, plot)), "(converted from warning) foo3 ignored unnamed argument\n The call was foo3(x=1, plot)") foo4 <- function(...) plotmo:::warn.if.dots(...) foo4() # ok expect.err(try(foo4(y=2)), "foo4 ignored argument 'y'") expect.err(try(foo4(2)), "foo4 ignored unnamed argument\n The call was foo4(2)") expect.err(try(foo4(y=plot)), "foo4 ignored argument 'y'") expect.err(try(foo4(plot)), "(converted from warning) foo4 ignored unnamed argument\n The call was foo4(plot)") options(warn=1) foo3(1, nonesuch=12, nonesuch2=12, 999) # expect three warnings cat0("=== test using sample functions that invoke call.dots\n") x <- 1:10 y <- x * x lmfit <- lm(y~x) par(mfrow=c(3, 2)) par(oma=c(0, 0, 3, 0)) # plot1: simple example # we choose to use predict() here rather than fitted() because nearly all # models have a fitted() method, but many don't have a fitted() method. plot1 <- function(object, ...) { residuals <- residuals(object, ...) fitted <- predict(object, ...) plot(fitted, residuals, ...) } plot1(lmfit) mtext("example plot functions using prefixed dots", outer=TRUE, font=2, line=1, cex=1) # Following causes error in predict.lm(). The type argument meant for # residuals() is also sent to predict.lm(), where it is rejected. expect.err(try(plot1(lmfit, type="pearson")), "'arg' should be one of \"response\", \"terms\"") # plot2: use prefixed args plot2 <- function(object, ..., TRACE=2) { resids <- plotmo:::call.dots(residuals, object=object, ..., TRACE=TRACE) fitted <- plotmo:::call.dots(predict, object=object, ..., TRACE=TRACE) plotmo:::call.plot(plot, x=fitted, y=resids, ..., TRACE=TRACE) } # we can now direct args using the prefixes "residuals.", "predict.", or "plot.") plot2(lmfit, residuals.type="pearson") # We can also use the usual plot arguments like ylab: call.dots drops # them; call.plot recognizes them and passes them to lines(). plot2(lmfit, residuals.type="pearson", ylab="pearson residuals", main="plot2") # plot3: further refinements # o namespace added to FUNC arg # o full name for plot.default # o force. and def. prefixes # o explicit xlab and ylab for call.plot # o unprefixed args are passed to residuals() plot3 <- function(object, ..., TRACE=2) { resids <- plotmo:::call.dots(stats::residuals, DROP="plotmo:::PLOTARGS,predict.,plot.", TRACE=TRACE, force.object=object, ...) fitted <- plotmo:::call.dots(stats::predict, force.object=object, TRACE=TRACE, ...) plotmo:::call.plot(graphics::plot.default, force.x=fitted, force.y=resids, def.xlab="fitted", def.ylab="residuals", TRACE=TRACE, ...) } plot3(lmfit, type="pearson", main="plot3a") # type goes only to pearson, no prefix needed plot3(lmfit, type="pearson", predict.type="response", main="plot3b") cat0("=== test callers.name\n") test.callers.name <- function(x) { caller0 <- plotmo:::callers.name(0) # test.callers.name caller1 <- plotmo:::callers.name(1) # caller of test.callers.name caller99 <- plotmo:::callers.name(99) # sys.call(-n) : not that many frames on the stack s <- sprint("0 %s 1 %s 99 %s", caller0, caller1, caller99) cat(s, "\n", sep="") s } print(plotmo:::callers.name()) # "eval" myfunc <- function(func) func() stopifnot(myfunc(function(x) test.callers.name(99)) == "0 test.callers.name 1 func 99 unknown") stopifnot(test.callers.name() == "0 test.callers.name 1 stopifnot 99 unknown") source("test.epilog.R") plotmo/inst/slowtests/modguide.model2.R0000644000176200001440000000441213725307662017725 0ustar liggesusers# modguide.model2.R: # # linmod code from Stephen Milborrow "Guidelines for S3 Regression Models" # This is called Model 2 in that document. # ## A simple linear model (extended from Friedrich Leisch's tutorial). ## Functions like print.linmod in the tutorial don't appear in the code below. linmod <- function(...) UseMethod("linmod") linmod.fit <- function(x, y) # internal function, not for the casual user { # first column of x is the intercept (all 1s) y <- as.vector(as.matrix(y)) # necessary when y is a data.frame qx <- qr(x) # QR-decomposition of x coef <- solve.qr(qx, y) # compute (x'x)^(-1) x'y df.residual <- nrow(x) - ncol(x) # degrees of freedom sigma2 <- sum((y - x %*% coef)^2) / df.residual # variance of residuals vcov <- sigma2 * chol2inv(qx$qr) # covar mat is sigma^2 * (x'x)^(-1) colnames(vcov) <- rownames(vcov) <- colnames(x) fitted.values <- qr.fitted(qx, y) names(fitted.values) <- rownames(x) fit <- list(coefficients = coef, residuals = y - fitted.values, fitted.values = fitted.values, vcov = vcov, sigma = sqrt(sigma2), df.residual = df.residual) class(fit) <- "linmod" fit } linmod.default <- function(x, y, ...) { fit <- linmod.fit(cbind("(Intercept)"=1, as.matrix(x)), y) fit$call <- match.call() fit } linmod.formula <- function(formula, data=parent.frame(), ...) { mf <- model.frame(formula=formula, data=data) terms <- attr(mf, "terms") fit <- linmod.fit(model.matrix(terms, mf), model.response(mf)) fit$call <- match.call() fit$terms <- terms fit } predict.linmod <- function(object, newdata=NULL, ...) { if(is.null(newdata)) y <- fitted(object) else { if(is.null(object$terms)) # x,y interface x <- cbind(1, as.matrix(newdata)) else { # formula interface terms <- delete.response(object$terms) x <- model.matrix(terms, model.frame(terms, as.data.frame(newdata))) } y <- as.vector(x %*% coef(object)) } y } plotmo/inst/slowtests/test.glmnetUtils.bat0000755000176200001440000000157314563571565020617 0ustar liggesusers@rem test.glmnetUtils.bat: glmnetUtils tests for plotmo and plotres @echo test.glmnetUtils.bat @"C:\PROGRA~1\R\R-4.3.2\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.glmnetUtils.R @if %errorlevel% equ 0 goto good1: @echo R returned errorlevel %errorlevel%, see test.glmnetUtils.Rout: @echo. @tail test.glmnetUtils.Rout @echo test.glmnetUtils.R @exit /B 1 :good1 mks.diff test.glmnetUtils.Rout test.glmnetUtils.Rout.save @if %errorlevel% equ 0 goto good2: @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.glmnetUtils.save.ps @exit /B 1 :good2 @rem test.glmnetUtils.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.glmnetUtils.save.ps @if %errorlevel% equ 0 goto good3: @echo === Files are different === @exit /B 1 :good3 @rm -f test.glmnetUtils.Rout @rm -f Rplots.ps @exit /B 0 plotmo/inst/slowtests/test.center.R0000644000176200001440000001122613725307662017206 0ustar liggesusers# test.center.R: test plotmo's center and ndiscrete args # Stephen Milborrow, Berea Apr 2011 source("test.prolog.R") library(rpart.plot) library(plotmo) library(earth) data(etitanic) et <- etitanic[, c("survived", "pclass", "sex", "age")] et$pclassn <- as.numeric(et$pclass) et <- et[c(30:80,330:380,630:680), ] par(mfrow=c(3,3)) par(mar=c(3, 3.5, 3, 0.5)) par(mgp=c(1.5, .5, 0)) ndiscrete <- 0 #--- row 1 set.seed(844) a1 <- lm(survived~pclassn+sex, data=et) plotmo(a1, all2=T, do.par=F, degree1=NA, degree2=1, center=TRUE, clip=F, main="a1: survived~pclassn+sex\n(default ndiscrete)", pt.col=ifelse(et$survived, "black", "red"), pt.pch=".", pt.cex=2.5, lab=c(1,1,1)) set.seed(844) plotmo(a1, degree1=1, all2=T, degree2=0, do.par=F, xflip=T, center=TRUE, clip=F, grid.levels=list(sex="f"), ndiscrete=ndiscrete, main="pclassn with sex=\"female\"", smooth.col="lightblue", smooth.lwd=2, pt.col=ifelse(et$survived, "black", "red"), pt.pch=".", pt.cex=2.5) set.seed(844) plotmo(a1, degree1=1, all2=T, degree2=0, do.par=F, xflip=T, center=TRUE, clip=F, grid.levels=list(sex="m"), ndiscrete=ndiscrete, main="pclassn with sex=\"male\"", smooth.col="lightblue", smooth.lwd=2, pt.col=ifelse(et$survived, "black", "red"), pt.pch=".", pt.cex=2.5) #--- row 2 a2 <- lm(survived~pclassn*sex, data=et) set.seed(844) plotmo(a2, all2=T, do.par=F, degree2=1, degree1=0, center=TRUE, clip=F, main="a2: survived~pclassn*sex\n(default ndiscrete)") set.seed(844) plotmo(a2, degree1=1, all2=T, degree2=0, do.par=F, xflip=T, center=TRUE, clip=F, grid.levels=list(sex="f"), ndiscrete=ndiscrete, main="pclassn with sex=\"female\"", smooth.col="lightblue", smooth.lwd=2, pt.col=ifelse(et$survived, "black", "red"), pt.pch=".", pt.cex=2.5) set.seed(844) plotmo(a2, degree1=1, all2=T, degree2=0, do.par=F, xflip=T, center=TRUE, clip=F, grid.levels=list(sex="m"), ndiscrete=ndiscrete, main="pclassn with sex=\"male\"", smooth.col="lightblue", smooth.lwd=2, pt.col=ifelse(et$survived, "black", "red"), pt.pch=".", pt.cex=2.5) #--- row 3 par(mfg=c(3,2)) a3 <- lm(survived~pclassn, data=et) set.seed(844) plotmo(a3, do.par=F, xflip=T, center=TRUE, clip=F, ndiscrete=ndiscrete, main="a3: survived~pclassn", degree1.col=1, smooth.col="lightblue", smooth.lwd=2, pt.col=ifelse(et$survived, "black", "red"), pt.pch=".", pt.cex=2.5) plot(0, 0, type="n", axes=FALSE, xlab="", ylab="") #--- row 1 # note that this is an example of a model that gets generated differently # with Scale.y=TRUE vs Scale.y=FALSE (although not shown here) a4 <- earth(survived~pclassn+age, data=et, degree=2) set.seed(844) plotmo(a4, do.par=F, center=TRUE, clip=F, ylim=c(-.6,.7), main="earth: survived~pclassn+age\n(default ndiscrete)", degree1=0, all2=T) set.seed(844) plotmo(a4, do.par=F, xflip=F, all1=T, center=TRUE, clip=F, ylim=c(-.6,.7), main="a4, age with pclassn=1st", ndiscrete=ndiscrete, degree2=0, degree1=2, # grid.levels=list(pclassn="1st"), grid.levels=list(pclassn=1), smooth.col="lightblue", smooth.lwd=2, pt.col=ifelse(et$survived, "black", "red"), pt.pch=".", pt.cex=2.5) set.seed(844) plotmo(a4, do.par=F, xflip=F, all1=T, center=TRUE, clip=F, ylim=c(-.6,.7), main="age with pclassn=3rd", ndiscrete=ndiscrete, degree2=0, degree1=2, grid.levels=list(pclassn=3), smooth.col="lightblue", smooth.lwd=2, pt.col=ifelse(et$survived, "black", "red"), pt.pch=".", pt.cex=2.5) #--- row 2 set.seed(844) plotmo(a4, do.par=F, center=TRUE, clip=F, type2="im", main="a4 earth: survived~pclassn+age\n(default ndiscrete)", degree1=0, all2=T, yflip=T, pt.col=ifelse(et$survived, 1, "red"), image.col=gray(seq(6, 10, length=10) / 10), xflip=T, pt.pch=".", pt.cex=2) set.seed(844) plotmo(a4, do.par=F, xflip=F, all1=T, center=TRUE, clip=F, main="pclassn with age=10", ndiscrete=ndiscrete, degree2=0, degree1=1, grid.levels=list(age=10), smooth.col="lightblue", smooth.lwd=2, pt.col=ifelse(et$survived, "black", "red"), pt.pch=".", pt.cex=2.5) set.seed(844) plotmo(a4, do.par=F, xflip=F, all1=T, center=TRUE, clip=F, main="pclassn with age=40", ndiscrete=ndiscrete, degree2=0, degree1=1, grid.levels=list(age=40), smooth.col="lightblue", smooth.lwd=2, pt.col=ifelse(et$survived, "black", "red"), pt.pch=".", pt.cex=2.5) source("test.epilog.R") plotmo/inst/slowtests/test.gbm.R0000644000176200001440000005140613727246550016477 0ustar liggesusers# test.gbm.R: gbm tests for plotmo and plotres source("test.prolog.R") library(gbm) library(rpart.plot) # for ptitanic, want data with NAs for testing library(plotmo) data(ptitanic) cat("--- distribution=\"gaussian\", formula interface ----------------------------------\n") set.seed(2016) ptit <- ptitanic[sample(1:nrow(ptitanic), size=70), ] # small data for fast test set.seed(2016) # # TODO bug in gbm: following causes error: survived is not of type numeric, ordered, or factor # ptit$survived <- ptit$survived == "survived" ptit <- ptit[!is.na(ptit$age), ] train.frac <- .8 set.seed(2016) gbm.gaussian <- gbm(age~., data=ptit, train.frac=train.frac, distribution="gaussian", n.trees=50, shrinkage=.1, keep.data=FALSE) expect.err(try(plotres(gbm.gaussian)), "use keep.data=TRUE in the call to gbm") set.seed(2016) gbm.gaussian <- gbm(age~., data=ptit, train.frac=train.frac, distribution="gaussian", n.trees=50, shrinkage=.1) par(mfrow=c(2,2), mar=c(3,3,4,1)) w1 <- plotres(gbm.gaussian, which=1, do.par=FALSE, w1.smooth=TRUE, w1.main="gbm.gaussian") cat("w1 plot for gbm.gaussian returned (w1.smooth=TRUE):\n") print(w1) plot(0, 0) # dummy plot w3 <- plotres(gbm.gaussian, which=3, do.par=FALSE, info=TRUE, smooth.col=0, col=ptit$sex, # ylim=c(-40,40), wmain="nresponse=1") # compare to manual residuals iused <- 1:(train.frac * nrow(ptit)) y <- ptit$age[iused] n.trees <- plotmo:::gbm.n.trees(gbm.gaussian) # TODO following fails in the new version of gbm (version 2.2) (you have to provide newdata) # yhat <- predict(gbm.gaussian, type="response", n.trees=n.trees) yhat <- predict(gbm.gaussian, newdata=ptit, type="response", n.trees=n.trees) yhat <- yhat[iused] plot(yhat, y - yhat, col=ptit$sex[iused], main="manual gaussian residuals", pch=20, ylim=c(-40,40)) abline(h=0, col="gray") stopifnot(all(yhat == w3$x)) stopifnot(all(y - yhat == w3$y)) par(org.par) w1 <- plotres(gbm.gaussian, predict.n.trees=13, w1.grid.col=1, trace=1, SHOWCALL=TRUE, w1.smooth=TRUE, w1.main="predict.n.trees=13 w1.grid.col=1") cat("second w1 plot for gbm.gaussian returned (w1.smooth=TRUE):\n") print(w1) plotmo(gbm.gaussian, trace=-1, SHOWCALL=TRUE) # plotmo(gbm.gaussian, trace=-1, all1=TRUE, SHOWCALL=TRUE) # plotmo(gbm.gaussian, trace=-1, all2=TRUE, SHOWCALL=TRUE) # test color argument par(mfrow=c(2,2), mar=c(3,3,4,1)) plotres(gbm.gaussian, which=1) title("test color argument") plotres(gbm.gaussian, which=1, w1.col=c(1,2,3,0)) plotres(gbm.gaussian, which=1, w1.col=c(1,0,0,4), w1.legend.x=40, w1.legend.y=.3) plotres(gbm.gaussian, which=1, w1.col=c(2,3,4,1), w1.legend.x="topright") par(org.par) par(mfrow=c(2,2), mar=c(3,3,4,1)) plot_gbm(gbm.gaussian) title("test plot_gbm") w1 <- plot_gbm(gbm.gaussian, col=c(1,2,3,0), grid.col=1, smooth=TRUE, main="col=c(1,2,3,0), grid.col=1") cat("third w1 plot for gbm.gaussian returned (smooth=TRUE):\n") print(w1) par(org.par) # test xlim and ylim par(mfrow=c(2,3), mar=c(3,3,4,1)) plot_gbm(gbm.gaussian, main="test xlim and ylim default") plot_gbm(gbm.gaussian, ylim=NULL, main="ylim=NULL") plot_gbm(gbm.gaussian, xlim=c(5, 50), main="xlim=c(5, 50)") plot_gbm(gbm.gaussian, ylim=c(100, 250), main="ylim=c(100, 250)") plot_gbm(gbm.gaussian, xlim=c(10, 25), ylim=c(150, 170), main="xlim=c(10, 25), ylim=c(150, 170)") plot_gbm(gbm.gaussian, xlim=c(-10, 40), ylim=c(-10, 300), legend.x=NA, main="xlim=c(-10, 40), ylim=c(-10, 300)\nlegend.x=NA") par(org.par) # test the smooth argument par(mfrow=c(3,3), mar=c(3,3,4,1)) imin <- plot_gbm(gbm.gaussian, main="smooth=default") imin.default <- imin cat("smooth=default imin=c(", imin[1], ",", imin[2], ",", imin[3], ",", imin[4], ")\n", sep="") imin <- plot_gbm(gbm.gaussian, smooth=c(1,0,0,0), main="smooth=c(1,0,0,0)") cat("smooth=c(1,0,0,0) imin=c(", imin[1], ",", imin[2], ",", imin[3], ",", imin[4], ")\n", sep="") imin <- plot_gbm(gbm.gaussian, smooth=c(0,1,0,0), main="smooth=c(0,1,0,0)") cat("smooth=c(0,1,0,0) imin=c(", imin[1], ",", imin[2], ",", imin[3], ",", imin[4], ")\n", sep="") imin <- plot_gbm(gbm.gaussian, smooth=c(0,0,1,0), main="smooth=c(0,0,1,0)") cat("smooth=c(0,0,1,0) imin=c(", imin[1], ",", imin[2], ",", imin[3], ",", imin[4], ")\n", sep="") imin <- plot_gbm(gbm.gaussian, smooth=c(0,0,0,1), main="smooth=c(0,0,0,1)\nsame as default") cat("smooth=c(0,0,0,1) imin=c(", imin[1], ",", imin[2], ",", imin[3], ",", imin[4], ")\n", sep="") imin <- plot_gbm(gbm.gaussian, smooth=c(0,0,0,0), main="smooth=c(0,0,0,0)") cat("smooth=c(0,0,0,0) imin=c(", imin[1], ",", imin[2], ",", imin[3], ",", imin[4], ")\n", sep="") imin <- plot_gbm(gbm.gaussian, smooth=c(0,0,1,1), main="smooth=c(0,0,1,1)") cat("smooth=c(0,0,1,1) imin=c(", imin[1], ",", imin[2], ",", imin[3], ",", imin[4], ")\n", sep="") imin <- plot_gbm(gbm.gaussian, smooth=1, main="smooth=1") # gets recycled cat("smooth=1 imin=c(", imin[1], ",", imin[2], ",", imin[3], ",", imin[4], ")\n", sep="") imin.smooth <- imin imin.noplot <- plot_gbm(gbm.gaussian, col=0) # will not be plotted print(imin.default) print(imin.noplot) stopifnot(identical(imin.default, imin.noplot)) imin.noplot <- plot_gbm(gbm.gaussian, col=0, smooth=1) # will not be plotted print(imin.smooth) print(imin.noplot) stopifnot(identical(imin.smooth, imin.noplot)) par(org.par) cat("--- distribution=\"gaussian\", glm.fit interface ----------------------------------\n") set.seed(2016) ptit <- ptitanic[sample(1:nrow(ptitanic), size=70), ] set.seed(2016) ptit <- ptit[!is.na(ptit$age), ] train.frac <- .8 set.seed(2016) gbm.gaussian.fit <- gbm.fit(ptit[,-4], ptit[,4], nTrain=floor(train.frac * nrow(ptit)), distribution="gaussian", verbose=FALSE, n.trees=50, shrinkage=.1) par(mfrow=c(2,2), mar=c(3,3,4,1)) w1 <- plotres(gbm.gaussian.fit, which=1, do.par=FALSE, w1.smooth=TRUE, w1.main="gbm.gaussian.fit") cat("w1 plot for gbm.gaussian.fit returned (w1.smooth=TRUE):\n") print(w1) plot(0, 0) # dummy plot w3 <- plotres(gbm.gaussian.fit, which=3, do.par=FALSE, info=TRUE, trace=0, smooth.col=0, col=ptit$sex, # ylim=c(-40,40), wmain="nresponse=1") # compare to manual residuals iused <- 1:(train.frac * nrow(ptit)) y.fit <- ptit$age[iused] n.trees <- plotmo:::gbm.n.trees(gbm.gaussian.fit) # TODO following fails in the new version of gbm (version 2.2) (you have to provide newdata) # yhat.fit <- predict(gbm.gaussian.fit, type="response", n.trees=n.trees) yhat.fit <- predict(gbm.gaussian.fit, newdata=ptit[,-4], type="response", n.trees=n.trees) yhat.fit <- yhat.fit[iused] # plot(yhat.fit, y.fit - yhat.fit, # col=ptit$sex[iused], main="manual gaussian residuals\n(TODO gbm.fit don't match)", # pch=20, ylim=c(-40,40)) # abline(h=0, col="gray") # --- TODO known issue, these fail --- # compare to formual interface # stopifnot(all(yhat.fit == yhat)) stopifnot(all(y.fit == y)) # # sanity check # stopifnot(all(yhat.fit == w3$x)) # stopifnot(all(y.fit - yhat.fit == w3$y.fit)) plotmo(gbm.gaussian.fit, trace=-1, SHOWCALL=TRUE) par(org.par) cat("--- distribution=\"laplace\" ----------------------------------\n") set.seed(2016) ptit <- ptitanic[sample(1:nrow(ptitanic), size=70), ] ptit <- ptit[!is.na(ptit$age), ] ptit$survived <- ptit$parch <- ptit$sex <- NULL train.frac <- .8 set.seed(2016) gbm.laplace <- gbm(age~., data=ptit, train.frac=train.frac, distribution="laplace", n.trees=100, shrinkage=.1) par(mfrow=c(2,2), mar=c(3,3,4,1)) w1 <- plotres(gbm.laplace, which=1:2, do.par=FALSE, w1.smooth=TRUE, w1.main="gbm.laplace") cat("w1 plot for gbm.laplace returned (w1.smooth=TRUE):\n") print(w1) w3 <- plotres(gbm.laplace, which=3, do.par=FALSE, info=TRUE) # compare to manual residuals iused <- 1:(train.frac * nrow(ptit)) y <- ptit$age[iused] n.trees <- plotmo:::gbm.n.trees(gbm.laplace) # TODO following fails in the new version of gbm (version 2.2) (you have to provide newdata) # yhat <- predict(gbm.laplace, type="response", n.trees=n.trees) yhat <- predict(gbm.laplace, newdata=ptit, type="response", n.trees=n.trees) yhat <- yhat[iused] plot(yhat, y - yhat, main="manual laplace residuals", pch=20, ylim=c(-40,40)) abline(h=0, col="gray") stopifnot(all(yhat == w3$x)) stopifnot(all(y - yhat == w3$y)) plotmo(gbm.laplace, trace=-1, SHOWCALL=TRUE) par(org.par) # # TODO commented out because gives random slightly different results per invocation # cat("--- distribution=\"tdist\" ----------------------------------\n") # # set.seed(2016) # ptit <- ptitanic[sample(1:nrow(ptitanic), size=70), ] # ptit <- ptit[!is.na(ptit$age), ] # ptit$survived <- ptit$parch <- ptit$sex <- NULL # train.frac <- .8 # set.seed(2016) # gbm.tdist <- gbm(age~., data=ptit, train.frac=train.frac, # distribution="tdist", # n.trees=100, shrinkage=.1) # par(mfrow=c(2,2), mar=c(3,3,4,1)) # set.seed(2016) # w1 <- plotres(gbm.tdist, which=1:2, do.par=FALSE, # w1.main="gbm.tdist") # # cat("w1 plot for gbm.tdist returned (w1.smooth=default):\n") # print(w1) # # set.seed(2016) # w3 <- plotres(gbm.tdist, which=3, do.par=FALSE, info=TRUE) # # # compare to manual residuals # iused <- 1:(train.frac * nrow(ptit)) # y <- ptit$age[iused] # n.trees <- plotmo:::gbm.n.trees(gbm.tdist) # # TODO following fails in the new version of gbm (version 2.2) (you have to provide newdata) # # yhat <- predict(gbm.tdist, type="response", n.trees=n.trees) # yhat <- predict(gbm.tdist, newdata=ptit, type="response", n.trees=n.trees) # yhat <- yhat[iused] # plot(yhat, y - yhat, # main="manual tdist residuals", # pch=20, ylim=c(-40,40)) # abline(h=0, col="gray") # stopifnot(all(yhat == w3$x)) # stopifnot(all(y - yhat == w3$y)) # plotmo(gbm.tdist, trace=-1, SHOWCALL=TRUE) # par(org.par) cat("--- distribution=\"bernoulli\" ----------------------------------\n") set.seed(2016) ptit <- ptitanic[sample(1:nrow(ptitanic), size=80), ] ptit$survived <- ptit$survived == "survived" temp <- ptit$pclass # put pclass at the end so can check ordering of importances ptit$pclass <- NULL ptit$pclass <- factor(as.numeric(temp), labels=c("first", "second", "third")) train.frac <- .9 set.seed(2016) gbm.bernoulli <- gbm(survived~., data=ptit, train.frac=train.frac, distribution="bernoulli", n.trees=100, shrinkage=.1, cv.folds=3) par(mfrow=c(2,2)) par(mar=c(3.5, 3, 2, 0.5)) # small margins and text to pack figs in par(mgp=c(1.5, .4, 0)) # squash axis annotations w1 <- plotres(gbm.bernoulli, which=c(1,4), col=ptit$survived+2, trace=0, do.par=FALSE, w1.main="gbm.bernoulli") cat("w1 plot for gbm.bernoulli with cv.folds=3 returned:\n") print(w1) w3 <- plotres(gbm.bernoulli, which=3, predict.n.trees=40, ylim=c(-.6, 1), xlim=c(.1, .6), col=ptit$sex, trace=0, do.par=FALSE, smooth.col=0) # compare to manual residuals iused <- 1:(train.frac * nrow(ptit)) y <- ptit$survived[iused] # TODO following fails in the new version of gbm (version 2.2) (you have to provide newdata) # yhat <- predict(gbm.bernoulli, type="response", n.trees=40) yhat <- predict(gbm.bernoulli, newdata=ptit, type="response", n.trees=40) yhat <- yhat[iused] plot(yhat, y - yhat, col=ptit$sex, main="manual bernoulli residuals", pch=20, cex=1, ylim=c(-.6, 1), xlim=c(.1, .6)) abline(h=0, col="gray") stopifnot(all(yhat == w3$x)) stopifnot(all(y - yhat == w3$y)) par(org.par) plotmo(gbm.bernoulli, do.par=2) print(summary(gbm.bernoulli)) # will also plot par(org.par) cat("--- distribution=\"huberized\" ----------------------------------\n") set.seed(2016) ptit <- ptitanic[sample(1:nrow(ptitanic), size=100), ] ptit$survived <- ptit$survived == "survived" ptit$sibsp <- ptit$parch <- ptit$pclass <- NULL train.frac <- 1 set.seed(2016) gbm.huberized <- gbm(survived~., data=ptit, train.frac=train.frac, distribution="huberized", n.trees=200, shrinkage=.1) par(mfrow=c(2,2)) par(mar=c(3.5, 3, 2, 0.5)) # small margins and text to pack figs in par(mgp=c(1.5, .4, 0)) # squash axis annotations w1 <- plotres(gbm.huberized, which=c(1,4), col=ptit$survived+2, trace=0, do.par=FALSE, w1.main="gbm.huberized") cat("w1 plot for gbm.huberized returned (smooth=default):\n") print(w1) # TODO huberized residuals look weird w3 <- plotres(gbm.huberized, which=3, predict.n.trees=40, col=ptit$sex, trace=0, do.par=FALSE, smooth.col=0) # compare to manual residuals iused <- 1:(train.frac * nrow(ptit)) y <- ptit$survived[iused] # TODO following fails in the new version of gbm (version 2.2) (you have to provide newdata) # yhat <- predict(gbm.huberized, type="response", n.trees=40) yhat <- predict(gbm.huberized, newdata=ptit, type="response", n.trees=40) yhat <- yhat[iused] plot(yhat, y - yhat, col=ptit$sex, ylim=c(-2.5, 2.5), main="manual huberized residuals", pch=20) abline(h=0, col="gray") stopifnot(all(yhat == w3$x)) stopifnot(all(y - yhat == w3$y)) par(org.par) plotmo(gbm.huberized, do.par=2) print(summary(gbm.huberized)) # will also plot par(org.par) cat("--- distribution=\"adaboost\" ----------------------------------\n") set.seed(2016) ptit <- ptitanic[sample(1:nrow(ptitanic), size=100), ] ptit$survived <- ptit$survived == "survived" ptit$sibsp <- ptit$parch <- ptit$pclass <- NULL train.frac <- .8 set.seed(2016) gbm.adaboost <- gbm(survived~., data=ptit, train.frac=train.frac, distribution="adaboost", n.trees=150, shrinkage=.01) par(mfrow=c(2,2)) par(mar=c(3.5, 3, 2, 0.5)) # small margins and text to pack figs in par(mgp=c(1.5, .4, 0)) # squash axis annotations w1 <- plotres(gbm.adaboost, which=c(1,4), col=ptit$survived+2, trace=0, do.par=FALSE, w1.main="gbm.adaboost") cat("w1 plot for gbm.adaboost returned (smooth=default):\n") print(w1) w3 <- plotres(gbm.adaboost, which=3, predict.n.trees=40, col=ptit$sex, trace=0, do.par=FALSE, smooth.col=0) # compare to manual residuals iused <- 1:(train.frac * nrow(ptit)) y <- ptit$survived[iused] # TODO following fails in the new version of gbm (version 2.2) (you have to provide newdata) # yhat <- predict(gbm.adaboost, type="response", n.trees=40) yhat <- predict(gbm.adaboost, newdata=ptit, type="response", n.trees=40) yhat <- yhat[iused] plot(yhat, y - yhat, col=ptit$sex, main="manual adaboost residuals", pch=20) abline(h=0, col="gray") stopifnot(all(yhat == w3$x)) stopifnot(all(y - yhat == w3$y)) par(org.par) plotmo(gbm.adaboost, do.par=2) print(summary(gbm.adaboost)) # will also plot par(org.par) # test gbm multinomial model, also test very small number of trees in plot_gbm data(iris) set.seed(2016) gbm.iris <- gbm(Species~., data=iris, distribution="multinomial", n.tree=5) expect.err(try(plotres(gbm.iris)), "gbm distribution=\"multinomial\" is not yet supported") expect.err(try(plotmo(gbm.iris)), "gbm distribution=\"multinomial\" is not yet supported") plot_gbm(gbm.iris) # TODO following fails in the new version of gbm (version 2.2) # (distribution "multinomial" is no longer supported) # # cat("--- distribution=\"multinomial\" ----------------------------------\n") # # set.seed(2016) # ptit <- ptitanic[sample(1:nrow(ptitanic), size=500), ] # set.seed(2016) # gbm.multinomial <- gbm(pclass~., # data=ptit, train.frac=.7, # distribution="multinomial", # n.trees=100, shrinkage=.1) # # w1 <- plot_gbm(gbm.multinomial, main="gbm.multinomial", smooth=T) # cat("plot_gbm for gbm.multinomial returned (smooth=TRUE):\n") # print(w1) # # expect.err(try(plotres(gbm.multinomial)), # "gbm distribution=\"multinomial\" is not yet supported") # # expect.err(try(plotmo(gbm.multinomial)), # "gbm distribution=\"multinomial\" is not yet supported") # cat("--- gbmt distribution=\"Gaussian\", formula interface ----------------------------------\n") # # set.seed(2016) # ptit <- ptitanic[sample(1:nrow(ptitanic), size=70), ] # small data for fast test # set.seed(2016) # # # TODO bug in gbm: following causes error: survived is not of type numeric, ordered, or factor # # ptit$survived <- ptit$survived == "survived" # ptit <- ptit[!is.na(ptit$age), ] # # TODO change this to build same model as gbm.gaussian # train_params <- # training_params(num_trees = 50, # shrinkage = 0.1, # bag_fraction = 0.5, # num_train = round(.8 * nrow(ptit))) # par(mfrow=c(2,2), mar=c(3,3,4,1)) # set.seed(2016) # gbmt.gaussian <- gbmt(age~., data=ptit, # distribution=gbm_dist("Gaussian"), # train_params = train_params, # is_verbose = FALSE) # expect.err(try(plotres(gbmt.gaussian)), # "use keep.data=TRUE in the call to gbm") # set.seed(2016) # gbmt.gaussian <- gbmt(age~., data=ptit, # distribution=gbm_dist("Gaussian"), # train_params = train_params, # is_verbose = FALSE, keep_gbm_data=TRUE) # w1 <- plotres(gbmt.gaussian, which=1, do.par=FALSE, w1.smooth=TRUE, # w1.main="gbmt.gaussian") # cat("w1 plot for gbmt.gaussian returned (w1.smooth=TRUE):\n") # print(w1) # plot(0, 0) # dummy plot # set.seed(2016) # w3 <- plotres(gbmt.gaussian, which=3, do.par=FALSE, info=TRUE, # smooth.col=0, col=ptit$sex, # ylim=c(-40,40), # wmain="nresponse=1") # # # compare to manual residuals # iused <- 1:(train.frac * nrow(ptit)) # y <- ptit$age[iused] # n.trees <- plotmo:::gbm.n.trees(gbmt.gaussian) # # TODO following fails in the new version of gbm (version 2.2) (you have to provide newdata) # # yhat <- predict(gbmt.gaussian, type="response", n.trees=n.trees) # yhat <- predict(gbmt.gaussian, newdata=ptit, type="response", n.trees=n.trees) # yhat <- yhat[iused] # plot(yhat, y - yhat, # col=ptit$sex[iused], main="manual gaussian residuals", # pch=20, ylim=c(-40,40)) # abline(h=0, col="gray") # stopifnot(all(yhat == w3$x)) # stopifnot(all(y - yhat == w3$y)) # par(org.par) # # w1 <- plotres(gbmt.gaussian, predict.n.trees=13, w1.grid.col=1, trace=1, SHOWCALL=TRUE, # w1.smooth=TRUE, # w1.main="predict.n.trees=13 w1.grid.col=1") # cat("second w1 plot for gbmt.gaussian returned (w1.smooth=TRUE):\n") # print(w1) # plotmo(gbmt.gaussian, trace=-1, SHOWCALL=TRUE) # # par(org.par) # # cat("--- distribution=\"bernoulli\" ----------------------------------\n") # # set.seed(2016) # ptit <- ptitanic[sample(1:nrow(ptitanic), size=80), ] # ptit$survived <- ptit$survived == "survived" # temp <- ptit$pclass # put pclass at the end so can check ordering of importances # ptit$pclass <- NULL # ptit$pclass <- factor(as.numeric(temp), labels=c("first", "second", "third")) # # TODO change this to build same model as gbm.bernoulli # train_params <- # training_params(num_trees = 100, # shrinkage = 0.1, # bag_fraction = 0.5, # num_train = round(.8 * nrow(ptit))) # set.seed(2016) # gbmt.bernoulli <- gbmt(survived~., data=ptit, # distribution=gbm_dist("Bernoulli"), # train_params = train_params, # cv_folds = 3, # is_verbose = FALSE, keep_gbm_data=TRUE) # par(mfrow=c(2,2)) # par(mar=c(3.5, 3, 2, 0.5)) # small margins and text to pack figs in # par(mgp=c(1.5, .4, 0)) # squash axis annotations # w1 <- plotres(gbmt.bernoulli, which=c(1,4), # col=ptit$survived+2, trace=0, do.par=FALSE, # w1.main="gbmt.bernoulli") # cat("w1 plot for gbmt.bernoulli with cv.folds=3 returned:\n") # print(w1) # # w3 <- plotres(gbmt.bernoulli, which=3, predict.n.trees=40, # ylim=c(-.6, 1), xlim=c(.1, .6), # col=ptit$sex, trace=0, do.par=FALSE, smooth.col=0) # # # compare to manual residuals # iused <- 1:(train.frac * nrow(ptit)) # y <- ptit$survived[iused] # # TODO following fails in the new version of gbm (version 2.2) (you have to provide newdata) # # yhat <- predict(gbmt.bernoulli, type="response", n.trees=40) # yhat <- predict(gbmt.bernoulli, newdata=ptit, type="response", n.trees=40) # yhat <- yhat[iused] # plot(yhat, y - yhat, col=ptit$sex, # main="manual bernoulli residuals", pch=20, cex=1, # ylim=c(-.6, 1), xlim=c(.1, .6)) # abline(h=0, col="gray") # stopifnot(all(yhat == w3$x)) # stopifnot(all(y - yhat == w3$y)) # par(org.par) # # plotmo(gbmt.bernoulli, do.par=2) # print(summary(gbmt.bernoulli)) # will also plot # par(org.par) source("test.epilog.R") plotmo/inst/slowtests/test.modguide.R0000644000176200001440000003323113725307664017525 0ustar liggesusers# test.modguide.bat: test model1 and model2 (linmod examples) in modguide.pdf source("test.prolog.R") options(warn=1) # print warnings as they occur almost.equal <- function(x, y, max=1e-8) { stopifnot(max >= 0 && max < .01) length(x) == length(y) && max(abs(x - y)) < max } # check that fit model matches ref lm model in all essential details check.lm <- function(fit, ref, newdata=trees[3:5,], check.coef.names=TRUE, check.casenames=TRUE, check.newdata=TRUE) { check.names <- function(fit.names, ref.names) { if(check.casenames && # lm always adds rownames even if "1", "2", "3" # this seems wasteful of resources, so linmod doesn't do this !is.null(fit.names) && !identical(fit.names, ref.names)) { print(fit.names) print(ref.names) stop(deparse(substitute(fit.names)), " != ", deparse(substitute(ref.names))) } } cat("check ", deparse(substitute(fit)), " vs ", deparse(substitute(ref)), "\n", sep="") stopifnot(coef(fit) == coef(ref)) if(check.coef.names) stopifnot(identical(names(coef(fit)), names(coef(ref)))) stopifnot(identical(dim(fit$coefficients), dim(ref$coefficients))) stopifnot(length(fit$coefficients) == length(ref$coefficients)) stopifnot(almost.equal(fit$coefficients, ref$coefficients)) stopifnot(identical(dim(fit$residuals), dim(ref$residuals))) stopifnot(length(fit$residuals) == length(ref$residuals)) stopifnot(almost.equal(fit$residuals, ref$residuals)) stopifnot(identical(dim(fit$fitted.values), dim(ref$fitted.values))) stopifnot(length(fit$fitted.values) == length(ref$fitted.values)) stopifnot(almost.equal(fit$fitted.values, ref$fitted.values)) if(!is.null(fit$vcov) && !is.null(ref$vcov)) { stopifnot(identical(dim(fit$vcov), dim(ref$vcov))) stopifnot(length(fit$vcov) == length(ref$vcov)) stopifnot(almost.equal(fit$vcov, ref$vcov)) } ref.sigma <- ref$sigma if(is.null(ref.sigma)) # in lm models, sigma is only available from summary() ref.sigma <- summary(ref)$sigma stopifnot(almost.equal(fit$sigma, ref.sigma)) stopifnot(almost.equal(fit$df, ref$df)) stopifnot(almost.equal(fitted(fit), fitted(ref))) check.names(names(fitted(fit)), names(fitted(ref))) stopifnot(almost.equal(residuals(fit), residuals(ref))) check.names(names(residuals(fit)), names(residuals(ref))) stopifnot(almost.equal(predict(fit), predict(ref))) check.names(names(predict(fit)), names(predict(ref))) if(check.newdata) { stopifnot(almost.equal(predict(fit, newdata=newdata), predict(ref, newdata=newdata))) check.names(names(predict(fit, newdata=newdata)), names(predict(ref, newdata=newdata))) } } ### Model 1: original code from Friedrich Leisch tutorial source("modguide.model1.R") cat("==example issues with predict with functions in the tutorial\n") data(trees) tr <- trees # trees data but with rownames rownames(tr) <- paste("tree", 1:nrow(trees), sep="") fit1 <- linmod(Volume~., data=tr) expect.err(try(predict(fit1, newdata=data.frame(Girth=10, Height=80))), "object 'Volume' not found") expect.err(try(predict(fit1, newdata=as.matrix(tr[1:3,]))), "'data' must be a data.frame, not a matrix or an array") library(plotmo) expect.err(try(plotmo(fit1)), "object 'Volume' not found") fit2 <- linmod(cbind(1, tr[,1:2]), tr[,3]) stopifnot(coef(fit1) == coef(fit2)) # following fail because newdata is a data.frame not a matrix expect.err(try(predict(fit2, newdata=tr[,1:2])), "requires numeric/complex matrix/vector arguments") expect.err(try(predict(fit2, newdata=data.frame(Girth=10, Height=80))), "requires numeric/complex matrix/vector arguments") expect.err(try(predict(fit2, newdata=as.matrix(data.frame(Girth=10, Height=80)))), "non-conformable arguments") expect.err(try(plotmo(fit2)), "requires numeric/complex matrix/vector arguments") cat("==a plotmo method function can deal with the issues\n") plotmo.predict.linmod <- function(object, newdata, ...) { if(is.null(object$formula)) # x,y interface? plotmo:::plotmo.predict.defaultm(object, newdata, ...) # pass matrix not data.frame else { # add dummy response column to newdata newdata[[as.character(as.list(object$formula)[[2]])]] <- 1 plotmo:::plotmo.predict.default(object, newdata, ...) } } plotmo(fit1, pt.col=2, caption="fit1 with original tutorial code and plotmo.predict.linmod") plotmo(fit2, pt.col=2, caption="fit2 with original tutorial code and plotmo.predict.linmod") remove(plotmo.predict.linmod) ### Model 2: minimal changes version for vignette "Guidelines for S3 Regression Models" source("modguide.model2.R") cat("==check that example issues with functions in the tutorial have gone\n") fit1.form <- linmod(Volume~., data=tr) cat("==print(summary(fit1.form))\n") print(summary(fit1.form)) stopifnot(abs(predict(fit1.form, newdata=data.frame(Girth=10, Height=80)) - 16.234045) < 1e-5) stopifnot(sum(abs(predict(fit1.form, newdata=as.matrix(tr[1:3,])) - c(4.8376597, 4.5538516, 4.8169813))) < 1e-5) lm.tr <- lm(Volume~., data=tr) check.lm(fit1.form, lm.tr) fit1.mat <- linmod(tr[,1:2], tr[,3]) # note no need for intercept term cat("==print(summary(fit1.mat))\n") print(summary(fit1.mat)) stopifnot(abs(predict(fit1.mat, newdata=data.frame(Girth=10, Height=80)) - 16.234045) < 1e-5) stopifnot(sum(abs(predict(fit1.mat, newdata=tr[1:3,1:2]) - c(4.8376597, 4.5538516, 4.8169813))) < 1e-5) stopifnot(abs(predict(fit1.mat, newdata=as.matrix(data.frame(Girth=10, Height=80))) - 16.234045) < 1e-5) check.lm(fit1.mat, lm.tr, newdata=trees[3:5,1:2]) cat("==example plots\n") library(plotmo) data(trees) fit1.form <- linmod(Volume~., data=trees) print(fit1.form) print(summary(fit1.form)) fit1.mat <- linmod(trees[,1:2], trees[,3]) print(fit1.mat) print(summary(fit1.mat)) plotmo(fit1.form) plotmo(fit1.mat) plotres(fit1.form) plotres(fit1.mat) cat("==test model building with different numeric args\n") x <- tr[,1:2] y <- tr[,3] fit2.mat <- linmod(x, y) check.lm(fit2.mat, lm.tr, newdata=trees[3:5,1:2]) # check consistency with lm expect.err(try(linmod(y~x)), "invalid type (list) for variable 'x'") expect.err(try(lm(y~x)), "invalid type (list) for variable 'x'") fit3.mat <- linmod(as.matrix(x), as.matrix(y)) check.lm(fit3.mat, lm.tr, newdata=trees[3:5,1:2]) fit4.form <- linmod(y ~ as.matrix(x)) lm4 <- linmod(y ~ as.matrix(x)) check.lm(fit4.form, lm4) stopifnot(coef(fit4.form) == coef(lm.tr), gsub("as.matrix(x)", "", names(coef(fit4.form)), fixed=TRUE) == names(coef(lm.tr))) xm <- as.matrix(x) fit5.form <- linmod(y ~ xm) lm5 <- linmod(y ~ xm) check.lm(fit5.form, lm5) stopifnot(coef(fit5.form) == coef(lm.tr), gsub("xm", "", names(coef(fit5.form)), fixed=TRUE) == names(coef(lm.tr))) cat("==test correct use of global x1 and y1\n") x1 <- tr[,1] y1 <- tr[,3] linmod1 <- linmod(y1~x1) fit6.mat <- linmod(x1, y1) check.lm(fit6.mat, linmod1, newdata=x1[3:5], check.newdata=FALSE, # TODO needed because linmod1 ignores newdata(!) check.coef.names=FALSE, check.casenames=FALSE) print(predict(fit6.mat, newdata=x1[3:5])) stopifnot(almost.equal(predict(fit6.mat, newdata=x1[3]), 7.63607739644657)) # production version only: # stopifnot(coef(fit6.mat) == coef(linmod1), # names(coef(fit6.mat)) == c("(Intercept)", "V1")) # names(coef(linmod1) are "(Intercept)" "x1" fit6.form <- linmod(y1~x1) check.lm(fit6.form, linmod1) cat("==check integer input (sibsp is an integer) \n") library(earth) # for etitanic data data(etitanic) tit <- etitanic[seq(1, nrow(etitanic), by=60), ] # small set of data for tests (18 cases) tit$survived <- tit$survived != 0 # convert to logical rownames(tit) <- paste("pas", 1:nrow(tit), sep="") cat(paste(colnames(tit), "=", sapply(tit, class), sep="", collapse=", "), "\n") fit7.mat <- linmod(tit$age, tit$sibsp) lm7 <- lm.fit(cbind(1, tit$age), tit$sibsp) stopifnot(coef(fit7.mat) == coef(lm7)) # coef names will differ fit7.form <- linmod(sibsp~age, data=tit) lm7.form <- lm(sibsp~age, data=tit) check.lm(fit7.form, lm7.form, newdata=tit[3:5,]) fit8.mat <- linmod(tit$sibsp, tit$age) lm8 <- lm.fit(cbind(1, tit$sibsp), tit$age) stopifnot(coef(fit8.mat) == coef(lm8)) # coef names will differ fit8.form <- linmod(age~sibsp, data=tit) lm8.form <- lm(age~sibsp, data=tit) check.lm(fit8.form, lm8.form, newdata=tit[3:5,]) # drop=FALSE so response is a data frame fit1a.mat <- linmod(trees[,1:2], trees[, 3, drop=FALSE]) print(fit1a.mat) print(summary(fit1.mat)) plotres(fit1a.mat) # plot caption shows response name "Volume" cat("==test model building with different non numeric args\n") library(earth) # for etitanic data data(etitanic) tit <- etitanic[seq(1, nrow(etitanic), by=60), ] # small set of data for tests (18 cases) tit$survived <- tit$survived != 0 # convert to logical rownames(tit) <- paste("pas", 1:nrow(tit), sep="") cat(paste(colnames(tit), "=", sapply(tit, class), sep="", collapse=", "), "\n") lm9 <- lm(survived~., data=tit) fit9.form <- linmod(survived~., data=tit) check.lm(fit9.form, lm9, newdata=tit[3:5,]) options(warn=2) # treat warnings as errors # factors in x expect.err(try(linmod(tit[,c(1,3,4,5,6)], tit[,"survived"])), "NAs introduced by coercion") options(warn=1) # print warnings as they occur expect.err(try(linmod(tit[,c(1,3,4,5,6)], tit[,"survived"])), "NA/NaN/Inf in foreign function call (arg 1)") options(warn=2) # treat warnings as errors expect.err(try(lm(pclass~., data=tit)), "using type = \"numeric\" with a factor response will be ignored") # minimal version expect.err(try(linmod(pclass~., data=tit)), "(converted from warning) NAs introduced by coercion") expect.err(try(linmod(tit$pclass, tit$survived)), "(converted from warning) NAs introduced by coercion") # # production version # expect.err(try(linmod(pclass~., data=tit)), "'y' is not numeric or logical") options(warn=1) lm10 <- lm(pclass~., data=tit) # will give warnings fit10.form <- linmod(as.numeric(pclass)~., data=tit) stopifnot(coef(fit10.form) == coef(lm10)) stopifnot(names(coef(fit10.form)) == names(coef(lm10))) # check.lm(fit10.form, lm10) # fails because lm10 fitted is all NA # production version: (minimal version just gives warnings and builds lousy model) # expect.err(try(linmod(pclass~., data=tit)), "'y' is not numeric or logical") # expect.err(try(linmod(tit[,-1], tit[,1])), "'y' is not numeric or logical") # expect.err(try(linmod(1:10, paste(1:10))), "'y' is not numeric or logical") fit10a.form <- linmod(survived~pclass, data=tit) lm10a <- lm(survived~pclass, data=tit) check.lm(fit10a.form, lm10a, newdata=tit[3:5,]) expect.err(try(linmod(paste(1:10), 1:10)), "requires numeric/complex matrix/vector arguments") lm11 <- lm(as.numeric(pclass)~., data=tit) fit11.form <- linmod(as.numeric(pclass)~., data=tit) check.lm(fit11.form, lm11, newdata=tit[3:5,]) cat("==data.frame with strings\n") df.with.string <- data.frame(1:5, c(1,2,-1,4,5), c("a", "b", "a", "a", "b"), stringsAsFactors=FALSE) colnames(df.with.string) <- c("num1", "num2", "string") fit30.form <- linmod(num1~num2, df.with.string) lm30 <- lm(num1~num2, df.with.string) check.lm(fit30.form, lm30, check.newdata=FALSE) fit31.form <- linmod(num1~., df.with.string) lm31 <- lm(num1~., df.with.string) check.lm(fit31.form, lm31, check.newdata=FALSE) expect.err(try(linmod(string~., df.with.string)), "non-numeric argument to binary operator") # production version # expect.err(try(linmod(string~., df.with.string)), "'y' is not numeric or logical") vec <- c(1,2,3,4,3) options(warn=2) # treat warnings as errors expect.err(try(linmod(df.with.string, vec)), "NAs introduced by coercion") options(warn=1) # minimal version expect.err(try(linmod(df.with.string, vec)), "NA/NaN/Inf in foreign function call (arg 1)") # production version # expect.err(try(linmod(df.with.string, vec)), "NA in 'x'") options(warn=2) # treat warnings as errors expect.err(try(linmod(df.with.string, vec)), "NAs introduced by coercion") options(warn=1) # minimal version expect.err(try(linmod(df.with.string, vec)), "NA/NaN/Inf in foreign function call (arg 1)") # production version # expect.err(try(linmod(df.with.string, vec)), "NA in 'x'") cat("==more variables than cases\n") set.seed(1) x2 <- matrix(rnorm(6), nrow=2) y2 <- c(1,2) # production version # expect.err(try(linmod(y2~x2)), "more variables than cases") # minimal version expect.err(try(linmod(y2~x2)), "'size' cannot exceed nrow(x) = 2") x3 <- matrix(1:10, ncol=2) y3 <- c(1,2,9,4,5) # production version will give a better error message expect.err(try(linmod(y3~x3)), "singular matrix 'a' in 'solve'") cat("==nrow(x) does not match length(y)\n") # note that the production version gives better error messages x4 <- matrix(1:10, ncol=2) y4 <- c(1,2,9,4) expect.err(try(linmod(x4, y4)), "singular matrix 'a' in 'solve'") x5 <- matrix(1:10, ncol=2) y5 <- c(1,2,9,4,5,9) expect.err(try(linmod(x5, y5)), "singular matrix 'a' in 'solve'") cat("==y has multiple columns\n") vec <- c(1,2,3,4,3) y2 <- cbind(c(1,2,3,4,9), vec^2) expect.err(try(linmod(vec, y2)), "'qr' and 'y' must have the same number of rows") # following does not issue any error message, it should # expect.err(try(linmod(y2~vec)), "error message") ### Model 3: production version of linmod is tested in test.linmod.R source("test.epilog.R") plotmo/inst/slowtests/test.pre.R0000644000176200001440000000745213727235376016526 0ustar liggesusers# test.pre.R: test the "pre" package with plotmo and plotres source("test.prolog.R") library(pre) library(plotmo) library(earth) # for ozone1 options(warn=1) # print warnings as they occur data(airquality) airq <- airquality[complete.cases(airquality), (c("Ozone", "Wind", "Temp"))] # prevent confusion caused by integer rownames which don't match row numbers rownames(airq) <- NULL airq <- airq[1:50, ] # small set of data for quicker test coef.glmnet <- glmnet:::coef.glmnet # TODO workaround required for glmnet 3.0 predict.cv.glmnet <- glmnet:::predict.cv.glmnet set.seed(2018) pre.mod <- pre(Ozone~., data=airq, ntrees=10) # ntrees=10 for faster test plotres(pre.mod) # variable importance and residual plots plotres(pre.mod, which=3, main="pre.mod residuals") # which=3 for just the residual vs fitted plot plotmo(pre.mod) # plot model surface with background variables held at their medians # sanity check: compare model surface to to randomForest # (commented out to save test time) # # library(randomForest) # set.seed(2018) # rf.mod <- randomForest(Ozone~., data=airq) # plotmo(rf.mod) # compare singleplot and plotmo par(mfrow=c(2,2)) # 4 plots per page singleplot(pre.mod, varname="Temp", main="Temp\n(singleplot)") plotmo(pre.mod, pmethod="partdep", # plot partial dependence plot, degree1="Temp", degree2=0, # plot only Temp, no degree2 plots do.par=FALSE, # don't automatically set par(), use above par(mfrow) main="Temp\n(plotmo partdep)") # test penalty.par.val="lambda.min" singleplot(pre.mod, varname="Temp", main="penalty.par.val=lambda.min\n(singleplot)", penalty.par.val="lambda.min") plotmo(pre.mod, pmethod="partdep", degree1="Temp", degree2=0, do.par=FALSE, main="penalty.par.val=lambda.min\n(plotmo partdep)", predict.penalty.par.val="lambda.min") # use "predict." to pass it on to predict.pre par(org.par) # compare pairplot and plotmo par(mfrow=c(2,3)) # 6 plots per page pairplot(pre.mod, c("Temp", "Wind"), main="pairplot") plotmo(pre.mod, main="plotmo partdep", pmethod="partdep", degree1=0, degree2="Temp", do.par=FALSE) # Compare to pmethod="apartdep". An approximate partdep plot is # faster than a full partdep plot (plotmo vignette Section 9.2). plotmo(pre.mod, main="plotmo apartdep", pmethod="apartdep", degree1=0, degree2="Temp", do.par=FALSE) # plot contour and image plots with plotmo plotmo(pre.mod, type2="contour", degree1=0, degree2="Temp", do.par=FALSE) plotmo(pre.mod, type2="image", degree1=0, degree2="Temp", do.par=FALSE) par(org.par) # test gpe models set.seed(2018) gpe.mod <- gpe(Ozone~., data=airq, base_learners=list(gpe_linear(), gpe_trees(), gpe_earth())) plotmo(gpe.mod) # by default no degree2 plots because importance(gpe) not available plotmo(gpe.mod, all2=TRUE, # force degree2 plot(s) by specifying all2=TRUE persp.ticktype="detailed", persp.nticks=2) # optional (these get passed on to persp) plotmo(gpe.mod, degree1=0, degree2=c("Wind", "Temp"), SHOWCALL=TRUE) # explictly specify degree2 plot # which=3 below for only the residuals-vs-fitted plot # optional info=TRUE to plot some extra information (RSq etc.) plotres(gpe.mod, which=3, info=TRUE, main="gpe.mod residuals") # multinomial response set.seed(2018) pre.iris <- pre(Species~., data=iris, ntrees=10) # ntrees=10 for faster testoptions(warn=2) # treat warnings as errors options(warn=2) # treat warnings as errors expect.err(try(plotmo(pre.iris)), "Defaulting to nresponse=1, see above messages") options(warn=1) # print warnings as they occur plotmo(pre.iris, all2=TRUE, nresponse="virginica", trace=1) source("test.epilog.R") plotmo/inst/slowtests/test.pre.bat0000755000176200001440000000142314563571565017070 0ustar liggesusers@rem test.pre.bat: pre tests for plotmo and plotres @echo test.pre.bat @"C:\PROGRA~1\R\R-4.3.2\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.pre.R @if %errorlevel% equ 0 goto good1: @echo R returned errorlevel %errorlevel%, see test.pre.Rout: @echo. @tail test.pre.Rout @echo test.pre.R @exit /B 1 :good1 mks.diff test.pre.Rout test.pre.Rout.save @if %errorlevel% equ 0 goto good2: @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.pre.save.ps @exit /B 1 :good2 @rem test.pre.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.pre.save.ps @if %errorlevel% equ 0 goto good3: @echo === Files are different === @exit /B 1 :good3 @rm -f test.pre.Rout @rm -f Rplots.ps @exit /B 0 plotmo/inst/slowtests/test.unusual.vars.R0000644000176200001440000005576513737416673020422 0ustar liggesusers# test.unusual.vars.R: test unusual variable names, and unusual formulas # # This file was initially created for plotmo 3.6.0 (Sep 2020) # ALso tests the naken() func introduced in plotmo 3.6.0 and earth 5.2.0 (Sep 2020) source("test.prolog.R") library(earth) data(ozone1) data(etitanic) options(warn=1) # print warnings as they occur check.naken <- function(s, expected, trace=0) { nude <- plotmo:::naken.formula.string(s, trace=trace) printf("%-60.60s %-s\n", s, nude) stopifnot(nude == expected) } printf("=== check naken.formula.string\n") # edge cases check.naken("", "") check.naken(" ", "") check.naken("y~", "y ~ ") check.naken("y~ ", "y ~ ") check.naken("y ~ ", "y ~ ") check.naken("y ~ ", "y ~ ") check.naken(" y ~ ", "y ~ ") check.naken("[", "[", trace=2) check.naken("`", "`", trace=2) # standard formulas check.naken("x", "x") check.naken("x1", "x1") check.naken("y ~ x1 : x2 + x3", "y ~ x1 + x2 + x3", trace=2) check.naken("y ~ x1 + x2 - x3", "y ~ x1 + x2 + x3", trace=2) # TODO "-" is treated as a "+" check.naken("y ~ .-x3", "y ~ . + x3") check.naken("cbind(damage, 6-damage)~temp", "cbind(damage, 6-damage) ~ temp", trace=2) check.naken("depIndex~q_4 + q_2102+q_2104 +q_3105+ q_3106", "depIndex ~ q_4 + q_2102 + q_2104 + q_3105 + q_3106") check.naken("doy ~ (vh+wind+humidity)^2", "doy ~ vh + wind + humidity") check.naken("doy ~ s(wind) + s(humidity,wind) + s(vh)", "doy ~ wind + humidity + vh") check.naken("log(doy) ~ I(vh*wind) + I(humidity*temp)+log(doy)", "log(doy) ~ vh + wind + humidity + temp + doy") check.naken("log(doy)~vh+wind+humidity+I(wind*humidity)+temp+log(ibh)", "log(doy) ~ vh + wind + humidity + temp + ibh", trace=2) check.naken("O3 ~ s(humidity)+s(temp)+s(ibt)+s(temp,ibt)", "O3 ~ humidity + temp + ibt") check.naken("Ozone^(1/3) ~ lo(Solar.R) + lo(Wind, Temp)", "Ozone^(1/3) ~ Solar.R + Wind + Temp") check.naken("Volume~(Girth*Height2)-Height", "Volume ~ Girth + Height2 + Height") check.naken("y ~ s(x) + s(x,z1)", "y ~ x + z1") check.naken("y~s(x0,x1,k=12)+s(x2)+s(x3,k=20,fx=20)", "y ~ x0 + x1 + x2 + x3") check.naken("y~x[,1]+x[,2]", "y ~ x[,1] + x[,2]") check.naken("y~x[,1]+x[,my.list$j]", "y ~ x[,1] + x[,my.list$j]") check.naken("y~x[,i]+x[,2]", "y ~ x[,i] + x[,2]") check.naken("Salary~Hitters[,1]", "Salary ~ Hitters[,1]", trace=2) check.naken("Salary~Hitters[,-1]", "Salary ~ Hitters[,-1]", trace=2) check.naken("Salary~Hitters[,c(1,2)]", "Salary ~ Hitters[,c(1,2)]", trace=2) check.naken("Salary~Hitters[,1:2]", "Salary ~ Hitters[,1:2]") check.naken("Salary~Hitters[,c(1,2)]", "Salary ~ Hitters[,c(1,2)]", trace=2) # nested brackets check.naken("y ~ x1[[2]] + x1[[3]]", "y ~ x1[[2]] + x1[[3]]") check.naken("y[ , 1 ] ~ x1[[2]]", "y[ , 1 ] ~ x1[[2]]") check.naken("y ~ x0[,nonesuch1 + x1[nsuch2^2 + 3 ]]", "y ~ x0[,nonesuch1 + x1[nsuch2^2 + 3 ]]") check.naken("y ~ x0[1,x2[3]] + x4[[5]] + x6[ x7[, 8], x9[ ,x10[11] ], drop=x12[13]]", "y ~ x0[1,x2[3]] + x4[[5]] + x6[ x7[, 8], x9[ ,x10[11] ], drop=x12[13]]") # backquotes check.naken("y ~ `a b c10` + `def`", "y ~ `a b c10` + `def`") check.naken("`y` ~ `a b c10` + `def` + s(sqrt(`x 1`))", "`y` ~ `a b c10` + `def` + `x 1`") # without a response check.naken("x1 + x[,1] + `x3`", "x1 + x[,1] + `x3`") check.naken("Salary~Hitters[,c(1,2)]+sqrt(x)", "Salary ~ Hitters[,c(1,2)] + x") check.naken("Salary~Hitters[,c(1,2)]+sqrt(x)+x99", "Salary ~ Hitters[,c(1,2)] + x + x99") check.naken("Salary~x1+x2+`x6`+x3", "Salary ~ x1 + x2 + `x6` + x3") check.naken("x[,c(1,2)] + x[,3]", "x[,c(1,2)] + x[,3]") check.naken("x[,1] + x[,2] + x[,3] + x[,29] + x[,-14]", "x[,1] + x[,2] + x[,3] + x[,29] + x[,-14]") check.naken("x[,c(1,2)] + x[,3] + x[,5:6] + x[,-1]", "x[,c(1,2)] + x[,3] + x[,5:6] + x[,-1]") check.naken("log(y) ~ x9 + ns(x2,4) + s(x3,x4,df=4) + x5:sqrt(x6)", "log(y) ~ x9 + x2 + x3 + x4 + x5 + x6") check.naken("log(y) ~ x9 + sqrt(x6) + ns(x2,4) + s(x3,x4,df=4) + x5", "log(y) ~ x9 + x6 + x2 + x3 + x4 + x5") check.naken("x[,1] + sqrt(x2) + 2.34e6 + 1", "x[,1] + x2 + 1") printf("\n=== test problem in lm() formula with -nonesuch ===\n") # Using "-nonesuch" in a "." formula (where nonesuch is a non-existent variable name) # causes the following error in stats::terms.formula (called via model.frame.default) # Error in terms.formula(formula, data = data) : (converted from warning) # 'varlist' has changed (from nvar=3) to new 4 after EncodeVars() -- should no longer happen! options(warn=2) # treat warnings as errors expect.err(try(lm(formula = Volume ~ . - nonesuch, data=trees)), "'varlist' has changed (from nvar=3) to new 4 after EncodeVars() -- should no longer happen!") options(warn=1) # print warnings as they occur printf("\n=== test variables names with spaces in them ===\n") spaced.trees <- trees stopifnot(colnames(spaced.trees) == c("Girth", "Height", "Volume")) # sanity check colnames(spaced.trees) <- c("Girth extra", "Height 999", "Volume") # put spaces in the names lm.spaced.trees <- lm(Volume~., data=spaced.trees) options(warn=2) expect.err(try(plotmo(lm.spaced.trees)), "Cannot determine which variables to plot in degree2 plots") options(warn=1) plotmo(lm.spaced.trees) # warning, but still plots (no degree2 plots) plotmo(lm.spaced.trees, all2=TRUE) # no warning earth.spaced.trees <- earth(Volume~. , data=spaced.trees, degree=2) plotmo(earth.spaced.trees) cat("\nevimp(earth.spaced.trees)\n") print(evimp(earth.spaced.trees)) printf("\n=== test non standard variable names and use of earth's bx matrix ===\n") emod <- earth(survived~., data=etitanic, degree=2) plotmo(emod) cat("\nevimp(emod)\n") print(evimp(emod)) bx <- emod$bx bx.df <- as.data.frame(bx[,-1]) # -1 to drop intercept bx.df$survived <- etitanic$survived # following gsub make it a bit easier to see what's going on # because the next call to earth also creates hinge functions # (so we end up with nested hinge functions) colnames(bx.df) <- gsub("h(", "H(", colnames(bx.df), fixed=TRUE) lm.bx <- lm(survived ~ ., data=bx.df) set.seed(2020) earth.bx <- earth(survived ~ ., data=bx.df, degree=2) printf("\nsummary(earth.bx):\n") print(summary(earth.bx)) printf("\nevimp(earth.bx):\n") print(evimp(earth.bx)) plot(earth.bx, info=TRUE) plotmo(lm.bx) # Warning: Cannot determine which variables to plot in degree2 plots plotmo(lm.bx, all2=TRUE, SHOWCALL=TRUE) plotmo(earth.bx, pmethod="partdep", trace=2) printf("\n=== put spaces into the column names of bx (for both response and predictors) ===\n") spaced.bx <- bx.df colnames(spaced.bx) <- gsub("-", " - ", colnames(spaced.bx), fixed=TRUE) colnames(spaced.bx)[colnames(spaced.bx) == "survived"] <- "Survived = YES" printf("\nhead(spaced.bx):\n") print(head(spaced.bx)) lm.spaced.bx <- lm(`Survived = YES` ~ ., data=spaced.bx) set.seed(2020) earth.spaced.bx <- earth(`Survived = YES` ~ ., data=spaced.bx, degree=2, trace=.5, nfold=4, ncross=3, varmod.method="lm", pmethod="cv") printf("\nsummary(earth.spaced.bx):\n") print(summary(earth.spaced.bx)) printf("\nevimp(earth.spaced.bx):\n") print(evimp(earth.spaced.bx)) set.seed(2020) earth.glm.spaced.bx <- earth(`Survived = YES` ~ ., data=spaced.bx, degree=2, trace=.5, glm=list(family="binomial"), nfold=4, ncross=3, varmod.method="lm", pmethod="cv") printf("\nsummary(earth.glm.spaced.bx):\n") print(summary(earth.glm.spaced.bx)) printf("\nevimp(earth.glm.spaced.bx):\n") print(evimp(earth.glm.spaced.bx)) options(warn=2) expect.err(try(plotmo(lm.spaced.bx)), "Cannot determine which variables to plot in degree2 plots") options(warn=1) plotmo(lm.spaced.bx, do.par=2, SHOWCALL=TRUE) plotres(lm.spaced.bx, do.par=0, which=c(1, 3)) par(org.par) plotmo(earth.spaced.bx, degree1="sexmale", do.par=2, level=.8, SHOWCALL=TRUE) plot(earth.spaced.bx, do.par=0, which=c(1, 3), info=TRUE, level=.8, type="earth") par(org.par) plot(earth.spaced.bx, versus="b:", info=TRUE, level=.8, type="earth", SHOWCALL=TRUE) # following should be the same as previous page (since type="earth") plotmo(earth.glm.spaced.bx, degree1="sexmale", do.par=2, level=.8, type="earth", SHOWCALL=TRUE) plot(earth.glm.spaced.bx, do.par=0, which=1, info=TRUE, level=.8, type="earth") # $$ TODO Following shouldn't cause Warning: Internal inconsistency: p$fit - fitted != 0 # No warning if don't use glm=list(family="binomial") in call to earth options(warn=2) expect.err(try(plot(earth.glm.spaced.bx, do.par=0, which=3, info=TRUE, level=.8, type="earth")), "Internal inconsistency: p$fit != fitted") options(warn=1) plot(earth.glm.spaced.bx, do.par=0, which=3, info=TRUE, level=.8, type="earth") par(org.par) expect.err(try(plotmo(earth.glm.spaced.bx, level=.8)), "predict.earth: with earth-glm models, use type=\"earth\" when using the interval argument") plotmo(earth.glm.spaced.bx, degree1="sexmale", do.par=2, SHOWCALL=TRUE) plot(earth.glm.spaced.bx, do.par=0, which=c(1, 3), info=TRUE) par(org.par) printf("\n=== test combinations of variables in formula ===\n") vdata <- data.frame( resp = 1:13, bool = c(F, F, F, F, F, T, T, T, T, T, T, T, T), ord = ordered(c("ORD1", "ORD1", "ORD1", "ORD1", "ORD1", "ORD1", "ORD3", "ORD3", "ORD3", "ORD2", "ORD2", "ORD2", "ORD2"), levels=c("ORD1", "ORD3", "ORD2")), fac = as.factor(c("FAC1", "FAC1", "FAC1", "FAC2", "FAC2", "FAC2", "FAC3", "FAC3", "FAC3", "FAC1", "FAC2", "FAC3", "FAC3")), str = c("STR1", "STR1", "STR1", # WILL BE TREATED LIKE A FACTOR "STR2", "STR2", "STR2", "STR3", "STR3", "STR3", "STR3", "STR3", "STR3", "STR3"), num = c(1, 3, 2, 3, 4, 5, 6, 4, 5, 6.5, 3, 6, 5), # 7 unique values (but one is non integral) sqrt_num = sqrt(c(1, 3, 2, 3, 4, 5, 6, 4, 5, 6.5, 3, 6, 5)), int = c(1L, 1L, 3L, 3L, 4L, 4L, 3L, 5L, 3L, 6L, 7L, 8L, 10L), # 8 unique values date = as.Date( c("2018-08-01", "2018-08-02", "2018-08-03", "2018-08-04", "2018-08-05", "2018-08-06", "2018-08-07", "2018-08-08", "2018-08-08", "2018-08-08", "2018-08-10", "2018-08-11", "2018-08-11")), date_num = as.numeric(as.Date( c("2018-08-01", "2018-08-02", "2018-08-03", "2018-08-04", "2018-08-05", "2018-08-06", "2018-08-07", "2018-08-08", "2018-08-08", "2018-08-08", "2018-08-10", "2018-08-11", "2018-08-11")))) vdata$off <- (1:nrow(vdata)) / nrow(vdata) resp2 <- 13:1 vweights <- rep(1, length.out=nrow(vdata)) vweights[1] <- 2 set.seed(2020) lognum.bool.ord.off <- earth(resp ~ log(num) + bool + ord + offset(off), degree=2, weights=vweights, data=vdata, pmethod="none", varmod.method="lm", nfold=2, ncross=3, trace=1) printf("summary(lognum.bool.ord.off)\n") print(summary(lognum.bool.ord.off)) cat("\nevimp(lognum.bool.ord.off)\n") print(evimp(lognum.bool.ord.off)) plotmo(lognum.bool.ord.off, do.par=2, level=.8, SHOWCALL=TRUE) plot(lognum.bool.ord.off, which=1, do.par=0) par(org.par) num.fac.sqrt.num.ord.bool <- earth(resp ~ num + int + fac + offset(off) + sqrt(num) + ord:bool - int, data=vdata, pmethod="none", trace=1) plotmo(num.fac.sqrt.num.ord.bool, SHOWCALL=TRUE) cat("\nevimp(num.fac.sqrt.num.ord.bool)\n") print(evimp(num.fac.sqrt.num.ord.bool)) printf("\n=== unusual formulas, compare to lm ===\n") lm1 <- lm(resp~ord+sqrt(as.numeric(fac)) + num+sqrt(num / 2)+I(2 * int)+date, data = vdata) # same formula terms as lm1 but in different order earth1 <- earth(resp~sqrt(as.numeric(fac)) + ord + date + num + sqrt(.5 * num)+I(int / .5), data = vdata, linpreds=TRUE, thresh=0, penalty=-1) cat("\nevimp(earth1)\n") print(evimp(earth1)) plotmo(lm1, SHOWCALL=TRUE) plotmo(earth1, SHOWCALL=TRUE) stopifnot(max(abs(sort(lm1$coef) - sort(earth1$coef))) < 1e-10) stopifnot((summary(lm1)$r.squared - earth1$rsq) < 1e-10) stopifnot(max(abs(predict(lm1, newdata=vdata[5,,drop=FALSE]) - predict(earth1, newdata=vdata[5,,drop=FALSE]))) < 1e-10) fac.sqrt <- earth(resp~sqrt(num)+fac, data = vdata, linpreds=TRUE, thresh=0, penalty=-1) fac.sqrt_ <- earth(resp~sqrt_num+fac, data = vdata, linpreds=TRUE, thresh=0, penalty=-1) cat("\nevimp(fac.sqrt)\n") print(evimp(fac.sqrt)) cat("\nevimp(fac.sqrt_)\n") print(evimp(fac.sqrt_)) # as.vector to remove names (which are slightly different: sqrt(num) vs sqrt_num stopifnot(identical(as.vector(fac.sqrt$coef), as.vector(fac.sqrt_$coef))) newdata.extra <- vdata[3:5,] # extra variables unused in the model newdata.extra$extra <- sqrt(newdata.extra[,1]) cat("\ncolnames(newdata.extra):", paste(colnames(newdata.extra)), "\n") newd <- vdata[3:5,c("num", "fac")] # only variables used in the formula model newd_ <- vdata[3:5,c("num", "sqrt_num", "fac")] # only variables used in the xy model stopifnot(identical(predict(fac.sqrt, newdata=newdata.extra), predict(fac.sqrt_, newdata=newd_))) stopifnot(identical(predict(fac.sqrt, newdata=newd), predict(fac.sqrt_, newdata=newd_))) stopifnot(identical(predict(fac.sqrt, newdata=newd), predict(fac.sqrt_, newdata=newd_))) stopifnot(identical(predict(fac.sqrt, newdata=newd), predict(fac.sqrt_, newdata=newd_))) stopifnot(max(abs(predict(fac.sqrt, newdata=newdata.extra) - predict(fac.sqrt_, newdata=newdata.extra))) < 1e-10) stopifnot(max(abs(predict(fac.sqrt, newdata=newdata.extra) - predict(fac.sqrt_, newdata=newdata.extra))) < 1e-10) printf("\n=== two response model ===\n") vdata.2resp <- vdata resp2 <- 13:1 vdata.2resp$resp2 <- resp2 earth.2resp <- earth(resp+resp2~num+sqrt(num), data=vdata.2resp, weights=vweights, trace=1, linpreds=TRUE, thresh=0, penalty=-1) printf("\nsummary(earth.2resp)\n") print(summary(earth.2resp)) cat("\nevimp(earth.2resp)\n") print(evimp(earth.2resp)) par(mfrow = c(2, 2), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0), oma=c(0,0,4,0)) # for formula models, plotmo plots a sinle plot for the effect of num plotmo(earth.2resp, nresp=1, do.par=0, main="earth.2resp nresp1") title <- paste( "two-response model: resp+resp2~num+sqrt(num)\n", "the top row is for earth.formula models: the combined effect of num and sqrt(num) is plotted together\n", "the bottom row is for an earth.default model: num and sqrt(num) are plotted separately") title(title, outer=TRUE, cex=.6) plotmo(earth.2resp, nresp=2, do.par=0, main="earth.2resp nresp2") # put two response data mats into matrix form for earth.default and for lm xmat <- vdata[,c("num", "sqrt_num"), drop=FALSE] colnames(xmat) <- c("num", "sqrt(num)") xmat <- as.matrix(xmat) ymat <- vdata[, "resp", drop=FALSE] ymat$resp2 <- resp2 ymat <- as.matrix(ymat) earthxy.2resp <- earth(xmat, ymat, weights=vweights, trace=1, linpreds=TRUE, thresh=0, penalty=-1) printf("\nsummary(earthxy.2resp)\n") print(summary(earthxy.2resp)) cat("\nevimp(earthxy.2resp)\n") print(evimp(earthxy.2resp)) # for xy models, plotmo plots a separate plots for the effect of num and sqrt(num) plotmo(earthxy.2resp, nresp=1, do.par=0) # plotmo(earthxy.2resp, nresp=2, do.par=0) stopifnot(identical(earth.2resp$coeff, earthxy.2resp$coeff)) lm.2resp <- lm(ymat~xmat, weights=vweights) printf("\nsummary(lm.2resp)\n") print(summary(lm.2resp)) options(warn=2) # treat warnings as errors expect.err(try(plotmo(lm.2resp, nresp=1)), "the variable on the right side of the formula is a matrix or data.frame") options(warn=1) # print warnings as they occur # check that lm and earth coeffs are the same # need order() below because coeffs appear in different row order in the coeff mat earth.2resp.order <- order(earth.2resp$coeff[,1]) lm.order <- order(lm.2resp$coeff[,1]) stopifnot(max(abs(earth.2resp$coeff[earth.2resp.order] - lm.2resp$coeff[lm.order])) < 1e-10) printf("\n=== test glm() with spaced.bx ===\n") # glm requires response to be a factor (or two columns) spaced.bx.fac <- spaced.bx spaced.bx.fac$`surv fac` <- factor(ifelse(spaced.bx$`Survived = YES`, "yes", "no"), levels = c("yes", "no")) spaced.bx.fac$`Survived = YES` <- NULL glm.spaced.bx <- glm(`surv fac` ~ ., data=spaced.bx.fac, family="binomial") printf("summary(glm.spaced.bx):\n") print(summary(glm.spaced.bx)) plotmo(glm.spaced.bx, do.par=2) plotres(glm.spaced.bx, which=3, do.par=0, info=TRUE, main="plotres(glm.spaced.bx,which=3") # TODO why is Residuals-Vs-Fitted plot different for plotres and plot for glm models? plot(glm.spaced.bx, which=1, caption="plot(glm.spaced.bx, which=1)") par(org.par) plotmo(glm.spaced.bx, all2=TRUE, degree2=c("sexmale", "pclass"), SHOW.CALL=TRUE, do.par=2) plotmo(glm.spaced.bx, degree1=0, all2=TRUE, degree2=c("sexmale", "age"), do.par=0) par(org.par) # TODO I think plot(glm.spaced.bx) doesn't restore the graphics params? printf("\n=== test formulas which have a rhs variable which a matrix ===\n") # This also tests that earth's naming of variables is the same as lm for such rhs variables # # TODO plotmo fails when rhs variable is a matrix --- would be nice to fix that x_ <- etitanic[,"age",drop=FALSE] x_$pclass <- etitanic$pclass x_$pclass <- as.numeric(etitanic$pclass) x_ <- as.matrix(x_) y_ <- as.matrix(as.numeric(etitanic[,"survived"])) earthxy.rhs.mat <- earth(x_, y_, degree=2, trace=1) print(summary(earthxy.rhs.mat)) cat("\nevimp(earthxy.rhs.mat)\n") print(evimp(earthxy.rhs.mat)) cat("\nearthxy.rhs.mat$modvars\n") print(earthxy.rhs.mat$modvars) plotmo(earthxy.rhs.mat, SHOWCALL=TRUE) # ok earth.rhs.mat <- earth(y_ ~ x_, degree=2, trace=1) print(summary(earth.rhs.mat)) cat("\nevimp(earth.rhs.mat)\n") print(evimp(earth.rhs.mat)) cat("\nearth.rhs.mat$modvars\n") print(earth.rhs.mat$modvars) stopifnot(max(abs(earthxy.rhs.mat$coeff - earth.rhs.mat$coeff)) < 1e-15) expect.err(try(plotmo(earth.rhs.mat)), # Warning: the variable on the right side of the formula is a matrix or data.frame "model.frame.default could not interpret the data passed to get.earth.x from model.matrix.earth from predict.earth") expect.err(try(plotmo(earth.rhs.mat, all1=TRUE)), # still fails "model.frame.default could not interpret the data passed to get.earth.x from model.matrix.earth from predict.earth") lm.rhs.mat <- lm(y_ ~ x_) print(summary(lm.rhs.mat)) expect.err(try(plotmo(lm.rhs.mat)), # Warning: the variable on the right side of the formula is a matrix or data.frame "predict returned the wrong length (got 1046 but expected 50)") expect.err(try(plotmo(lm.rhs.mat, all1=TRUE)), # still fails "predict returned the wrong length (got 1046 but expected 50)") earth1.rhs.mat <- earth(y_ ~ x_, linpreds=TRUE, thresh=0, penalty=-1) # degree1 cat("\nevimp(earth1.rhs.mat)\n") print(evimp(earth1.rhs.mat)) options(warn=2) expect.err(try(plotmo(earth.rhs.mat)), "the variable on the right side of the formula is a matrix or data.frame") expect.err(try(plotmo(earth.rhs.mat, all1=TRUE)), # still fails "the variable on the right side of the formula is a matrix or data.frame") options(warn=1) stopifnot(max(abs(sort(lm.rhs.mat$coeff) - sort(earth1.rhs.mat$coeff))) < 1e-12) stopifnot(sort(rownames(lm.rhs.mat$coeff)) == sort(rownames(earth1.rhs.mat$coeff))) x_nonames <- x_ colnames(x_nonames) <- NULL lm.rhs.nonames <- lm(y_ ~ x_nonames) print(summary(lm.rhs.nonames)) expect.err(try(plotmo(lm.rhs.nonames)), # Warning: the variable on the right side of the formula is a matrix or data.frame "predict returned the wrong length (got 1046 but expected 50)") expect.err(try(plotmo(lm.rhs.nonames, all1=TRUE)), # still fails "predict returned the wrong length (got 1046 but expected 50)") earth1.rhs.nonames <- earth(y_ ~ x_nonames, linpreds=TRUE, thresh=0, penalty=-1) # degree1 print(summary(earth1.rhs.nonames)) cat("\nevimp(earth1.rhs.nonames)\n") print(evimp(earth1.rhs.nonames)) options(warn=2) expect.err(try(plotmo(earth1.rhs.nonames)), # Warning: the variable on the right side of the formula is a matrix or data.frame "the variable on the right side of the formula is a matrix or data.frame") expect.err(try(plotmo(earth1.rhs.nonames, all1=TRUE)), # still fails "the variable on the right side of the formula is a matrix or data.frame") options(warn=1) stopifnot(max(abs(sort(lm.rhs.nonames$coeff) - sort(earth1.rhs.nonames$coeff))) < 1e-12) stopifnot(sort(rownames(lm.rhs.nonames$coeff)) == sort(rownames(earth1.rhs.nonames$coeff))) printf("\n=== test handling consecutive '-' in formula ===\n") options(warn=2) lm.consec.minus <- lm(Volume~.--Girth, data=trees) # note double -- expect.err(try(plotmo(lm.consec.minus)), "Consecutive '-' in formula may cause problems") earth.consec.minus <- earth(Volume~.--Girth, data=trees) # note double -- cat("\nsummary(earth.consec.minus)\n") print(summary(earth.consec.minus)) cat("\nevimp(earth.consec.minus)\n") print(evimp(earth.consec.minus)) expect.err(try(plotmo(earth.consec.minus)), "Consecutive '-' in formula may cause problems") options(warn=1) printf("\n=== test rpart() with spaced.bx ===\n") library(rpart.plot) rpart.mod <- rpart(`Survived = YES` ~ ., data=spaced.bx) printf("\nprint(rpart.rules(rpart.mod))\n") print(rpart.rules(rpart.mod)) set.seed(2020) plotmo(rpart.mod, do.par=2, degree1=c("sexmale", "pclass3rd"), degree2=2, pt.col="red") plotres(rpart.mod, do.par=0, which=c(1,3)) par(org.par) printf("\n=== tibble, class \"Date\", and ndiscrete ===\n") library(tibble) library(lubridate) tib1 <- tibble(y = c(1, 1, 2, 3), # even number of variables bool = c(F, F, F, T), date = c(ymd('2018-08-01'), ymd('2018-08-02'), ymd('2018-08-03'), ymd('2018-08-03'))) cat("class tib1$date: ", class(tib1$date), "\n") mod.tib1 <- lm(y ~ ., data = tib1) plotmo(mod.tib1, col.response=2, all2=TRUE, ticktype="d", do.par=2, caption="mod.tib1: Dates ndiscrete=default 5") plotmo(mod.tib1, col.response=2, degree1=0, all2=TRUE, ticktype="d", do.par=0, theta=-45) par(org.par) plotmo(mod.tib1, col.response=2, all2=TRUE, ticktype="d", do.par=2, ndiscrete=2, caption="mod.tib1: Dates ndiscrete=2") plotmo(mod.tib1, col.response=2, degree1=0, all2=TRUE, ticktype="d", do.par=0, theta=-45, ndiscrete=2) par(org.par) plotmo(mod.tib1, col.response=2, all2=TRUE, ticktype="d", do.par=2, ndiscr=1, caption="mod.tib1: Dates ndiscrete=1") plotmo(mod.tib1, col.response=2, degree1=0, all2=TRUE, ticktype="d", do.par=0, theta=-45, ndiscrete=2) par(org.par) tib2 <- tibble(y = c(1, 1, 2, 3, 4), # odd number of variables bool = c(F, F, F, T, T), date = c(ymd('2018-08-01'), ymd('2018-08-02'), ymd('2018-08-03'), ymd('2018-08-03'), ymd('2018-08-04'))) mod.tib2 <- lm(y ~ ., data = tib2) plotmo(mod.tib2, col.response=2, all2=TRUE, ticktype="d", do.par=2, caption="mod.tib2: Dates ndiscrete=default 5") plotmo(mod.tib2, col.response=2, degree1=0, all2=TRUE, ticktype="d", do.par=0, theta=-45) par(org.par) plotmo(mod.tib2, col.response=2, all2=TRUE, ticktype="d", do.par=2, ndiscrete=2, caption="mod.tib2: Dates ndiscrete=2") plotmo(mod.tib2, col.response=2, degree1=0, all2=TRUE, ticktype="d", do.par=0, theta=-45, ndiscrete=2) par(org.par) plotmo(mod.tib2, col.response=2, all2=TRUE, ticktype="d", do.par=2, ndiscr=1, caption="mod.tib2: Dates ndiscrete=1") plotmo(mod.tib2, col.response=2, degree1=0, all2=TRUE, ticktype="d", do.par=0, theta=-45, ndiscrete=2) par(org.par) source("test.epilog.R") plotmo/inst/slowtests/linmod.methods.R0000644000176200001440000000517613725307660017701 0ustar liggesusers# limod.methods.R: Additional method functions for the linmod example. # # See www.milbo.org/doc/modguide.pdf. # This software may be freely used. variable.names.linmod <- function(object, ...) { stopifnot(inherits(object, "linmod")) stop.if.dot.arg.used(...) names(coef(object)) } case.names.linmod <- function(object, ...) { stopifnot(inherits(object, "linmod")) stop.if.dot.arg.used(...) names(residuals(object)) } nobs.linmod <- function(object, use.fall.back = FALSE, ...) { stopifnot(inherits(object, "linmod")) stop.if.dot.arg.used(...) NROW(object$residuals) } deviance.linmod <- function(object, ...) { stopifnot(inherits(object, "linmod")) stop.if.dot.arg.used(...) sum(residuals(object)^2) } model.frame.linmod <- function(formula, ...) { stopifnot(inherits(formula, "linmod")) if(is.null(formula$terms)) # model built with linmod.default? stop("model.frame cannot be used on linmod models built without a formula") else model.frame.default(formula, ...) } model.matrix.linmod <- function(object, data = NULL, ...) { stopifnot(inherits(object, "linmod")) if(is.null(data)) data <- model.frame.linmod(object) model.matrix.default(object, data = data, ...) } logLik.linmod <- function(object, REML = FALSE, ...) { stopifnot(inherits(object, "linmod")) stop.if.dot.arg.used(...) stopifnot(!REML) # linmod does not save qr hence cannot do REML res <- object$residuals p <- object$rank n <- length(res) w <- rep.int(1, n) n0 <- n val <- .5* (sum(log(w)) - n * (log(2 * pi) + 1 - log(n) + log(sum(w*res^2)))) attr(val, "nall") <- n0 attr(val, "nobs") <- n attr(val, "df") <- p + 1 class(val) <- "logLik" val } estfun.linmod <- function (x, ...) # for sandwich package { stopifnot(inherits(x, "linmod")) stop.if.dot.arg.used(...) xmat <- model.matrix(x) res <- residuals(x) rval <- as.vector(res) * xmat attr(rval, "assign") <- NULL attr(rval, "contrasts") <- NULL return(rval) } plot.linmod <- function(x, main = NULL, ...) # dots are passed to plot() { stopifnot(inherits(x, "linmod")) call.as.char <- paste0(deparse(x$call, control = NULL, nlines = 5), sep = " ", collapse = " ") plot(fitted(x), residuals(x), xlab = "Fitted values", ylab = "Residuals", main = if(is.null(main)) substr(call.as.char, 1, 50) else main, ...) smooth <- lowess(fitted(x), residuals(x), f = .5) lines(smooth$x, smooth$y, col = 2) } plotmo/inst/slowtests/make.bat0000755000176200001440000000557114563607647016252 0ustar liggesusers@rem plotmo/inst/slowtests/make.bat @call test.plotmo.bat @if %errorlevel% NEQ 0 goto err @call test.printcall.bat @if %errorlevel% NEQ 0 goto err @call test.dots.bat @if %errorlevel% NEQ 0 goto err @call test.plotmo.dots.bat @if %errorlevel% NEQ 0 goto err @call test.plotmo.x.bat @if %errorlevel% NEQ 0 goto err @call test.plotmo.args.bat @if %errorlevel% NEQ 0 goto err @call test.degree.bat @if %errorlevel% NEQ 0 goto err @call test.modguide.bat @if %errorlevel% NEQ 0 goto err @call test.linmod.bat @if %errorlevel% NEQ 0 goto err @call test.fac.bat @if %errorlevel% NEQ 0 goto err @call test.plotmo3.bat @if %errorlevel% NEQ 0 goto err @call test.center.bat @if %errorlevel% NEQ 0 goto err @call test.plotres.bat @if %errorlevel% NEQ 0 goto err @call test.partdep.bat @if %errorlevel% NEQ 0 goto err @call test.unusual.vars.bat @if %errorlevel% NEQ 0 goto err @call test.non.earth.bat @if %errorlevel% NEQ 0 goto err @rem The following miscellaneous models are in alphabetical order @call test.c50.bat @if %errorlevel% NEQ 0 goto err @call test.caret.bat @if %errorlevel% NEQ 0 goto err @call test.gbm.bat @if %errorlevel% NEQ 0 goto err @call test.glmnet.bat @if %errorlevel% NEQ 0 goto err @call test.glmnetUtils.bat @if %errorlevel% NEQ 0 goto err @call test.mlr.bat @if %errorlevel% NEQ 0 goto err @call test.parsnip.bat @if %errorlevel% NEQ 0 goto err @call test.partykit.bat @if %errorlevel% NEQ 0 goto err @call test.pre.bat @if %errorlevel% NEQ 0 goto err @rem we also run the earth package tests in \a\r\earth\inst\slowtests\make.bat @cd \a\r\earth\inst\slowtests @if %errorlevel% NEQ 0 goto err @call make.bat @if %errorlevel% NEQ 0 goto err @cd \a\r\plotmo\inst\slowtests @goto done :err @echo ==== ERROR ==== :done @exit /B 0 plotmo/inst/slowtests/test.plotmo.x.R0000644000176200001440000002737213725307664017521 0ustar liggesusers# test.plotmo.x.R: test plotmo_x and related functions source("test.prolog.R") library(plotmo) library(earth) options(warn=1) # print warnings as they occur data(ozone1) data(etitanic) get.tit <- function() { tit <- etitanic pclass <- as.character(tit$pclass) # change the order of the factors so not alphabetical pclass[pclass == "1st"] <- "first" pclass[pclass == "2nd"] <- "class2" pclass[pclass == "3rd"] <- "classthird" tit$pclass <- factor(pclass, levels=c("class2", "classthird", "first")) # log age is so we have a continuous predictor even when model is age~. set.seed(2015) tit$logage <- log(tit$age) + rnorm(nrow(tit)) tit$parch <- NULL # by=12 gives us a small fast model with an additive and a interaction term tit <- tit[seq(1, nrow(etitanic), by=12), ] } X <- X1 <- X2 <- Y <- DF <- NULL get.data <- function() { X <<- matrix(c(1,2,3,4,5,6,7,8,9, 2,3,3,5,6,7,8,9,9), ncol=2) colnames(X) <- c("xx1", "xx2") X1 <<- X[,1] X2 <<- X[,2] Y <<- c(1,2,7,4,5,6,6,6,6) DF <<- data.frame(Y=Y, X1=X1, X2=X2) } stopifnot1 <- function(x, y){ xname <- deparse(substitute(x)) yname <- deparse(substitute(y)) if(!all(x == y)) stop(sprint("%s == %s failed\n", xname, yname, call.=FALSE)) printf("%s == %s passed\n", xname, yname) } printf("====== standard earth.formula model with a data frame\n") get.data() earth.form.df.dot <- earth(Y~., data=DF) plotmo(earth.form.df.dot, caption="test basic use of DF") printf("-- test basic use of DF\n") rv <- plotmo(earth.form.df.dot, trace=100) stopifnot1(rv, X) printf("-- test use same DF even when other variables change\n") get.data() earth.form.df.dot <- earth(Y~., data=DF) X1 <- "rubbish" rv <- plotmo(earth.form.df.dot, trace=100) stopifnot1(rv, X) printf("-- test detect that DF is now trashed\n") get.data() earth.form.df.dot <- earth(Y~., data=DF) DF <- "rubbish" X1 <- "rubbish" # DF is corrupt and will treated as NULL by plotmo, so make sure plotmo doesn't find the global X1 # invalid 'envir' argument of type 'character' expect.err(try(plotmo(earth.form.df.dot, trace=100)), "cannot get the original model predictors") # Removed this test because this no longer fails, because we get the formula using formula(object) # printf("-- DF is NULL so will get '.' in formula and no 'data' argument\n") # get.data() # earth.form.df.dot <- earth(Y~., data=DF) # DF <- NULL # # '.' in formula and no 'data' argument # expect.err(try(plotmo(earth.form.df.dot, trace=100)), "cannot get the original model predictors") printf("-- DF is NULL so will pick up X1 with same values from global environment\n") get.data() earth.form.df <- earth(Y~X1+X2, data=DF) DF <- NULL rv <- plotmo(earth.form.df, trace=100) stopifnot1(rv, X) printf("-- DF is NULL so will will pick up trashed X1 from global environment\n") earth.form.df <- earth(Y~X1+X2, data=DF) DF <- NULL X1 <- "rubbish" # variable lengths differ (found for 'X1') expect.err(try(plotmo(earth.form.df, trace=100)), "cannot get the original model predictors") printf("-- DF has only one column, so will pick up X1 from it and X2 from global environment\n") get.data() earth.form.df <- earth(Y~X1+X2, data=DF) DF <- data.frame(Y=Y, X1=X1) DF[1,2] <- 99 X2[1] <- 98 rv <- plotmo(earth.form.df, trace=100) stopifnot1(rv[1,1], 99) stopifnot1(rv[1,2], 98) printf("-- sanity check, make sure we are back to normal\n") get.data() earth.form.df <- earth(Y~X1+X2, data=DF) rv <- plotmo(earth.form.df, trace=100) stopifnot1(rv, X) printf("-- change the data frame, make sure we pick up the changed value\n") get.data() earth.form.df <- earth(Y~X1+X2, data=DF) DF[1,2] <- 99 rv <- plotmo(earth.form.df, trace=100) stopifnot1(rv[1,1], 99) printf("-- change order of columns in the data frame, should be ok\n") get.data() earth.form.df <- earth(Y~X1+X2, data=DF) DF <- data.frame(X2=X2, X1=X1) rv <- plotmo(earth.form.df, trace=100) stopifnot1(rv, X) printf("======= standard earth.formula model with a data frame and keepxy\n") get.data() earth.form.df.keepxy <- earth(Y~., data=DF, keepxy=TRUE) printf("-- test basic use of DF\n") rv <- plotmo(earth.form.df.keepxy, trace=100) stopifnot1(rv, X) printf("-- test use same DF even when other variables change\n") earth.form.df.keepxy <- earth(Y~., data=DF, keepxy=TRUE) X1 <- "rubbish" rv <- plotmo(earth.form.df.keepxy, trace=100) stopifnot1(rv, X) printf("-- DF is now trashed but it doesn't matter because keepxy=T\n") DF <- "rubbish" rv <- plotmo(earth.form.df.keepxy, trace=100) stopifnot1(rv, X) printf("-- DF is NULL but it doesn't matter because keepxy=T\n") get.data() earth.form.df.keepxy <- earth(Y~., data=DF, keepxy=TRUE) DF <- NULL rv <- plotmo(earth.form.df.keepxy, trace=100) stopifnot1(rv, X) printf("-- DF and X1 are NULL but it doesn't matter because keepxy=T\n") DF <- NULL X1 <- "rubbish" rv <- plotmo(earth.form.df.keepxy, trace=100) stopifnot1(rv, X) printf("-- sanity check, make sure we are back to normal\n") get.data() earth.form.df.keepxy <- earth(Y~., data=DF, keepxy=TRUE) rv <- plotmo(earth.form.df.keepxy, trace=100) stopifnot1(rv, X) printf("-- change the data frame, but it doesn't matter because keepxy=T\n") get.data() earth.form.df.keepxy <- earth(Y~., data=DF, keepxy=TRUE) DF[1,2] <- 99 rv <- plotmo(earth.form.df.keepxy, trace=100) stopifnot1(rv, X) printf("-- change order of columns in the data frame, should be ok\n") get.data() earth.form.df.keepxy <- earth(Y~., data=DF, keepxy=TRUE) DF <- data.frame(X2=X2, X1=X1) rv <- plotmo(earth.form.df.keepxy, trace=100) stopifnot1(rv, X) printf("======= standard lm model with a data frame but with model=FALSE\n") get.data() lm.form.df.model.false.with.dot <- lm(Y~., data=DF, model=FALSE) printf("-- test basic use of DF\n") rv <- plotmo(lm.form.df.model.false.with.dot, trace=100) stopifnot1(rv, X) printf("-- test use same DF even when other variables change\n") get.data() lm.form.df.model.false.with.dot <- lm(Y~., data=DF, model=FALSE) X1 <- "rubbish" rv <- plotmo(lm.form.df.model.false.with.dot, trace=100) stopifnot1(rv, X) printf("-- test detect that DF is now trashed\n") DF <- "rubbish" # invalid 'envir' argument of type 'character' expect.err(try(plotmo(lm.form.df.model.false.with.dot, trace=100)), "cannot get the original model predictors") printf("-- DF is NULL so will pick up X1 with same values from global environment\n") get.data() lm.form.df.model.false <- lm(Y~X1+X2, data=DF, model=FALSE) DF <- NULL rv <- plotmo(earth.form.df, trace=100) stopifnot1(rv, X) printf("-- DF is NULL so will will pick up trashed X1 from global environment\n") get.data() lm.form.df.model.false <- lm(Y~X1+X2, data=DF, model=FALSE) DF <- NULL X1 <- "rubbish" # variable lengths differ (found for 'X1') expect.err(try(plotmo(lm.form.df.model.false, trace=100)), "cannot get the original model predictors") printf("-- sanity check, make sure we are back to normal\n") get.data() lm.form.df.model.false <- lm(Y~X1+X2, data=DF, model=FALSE) rv <- plotmo(lm.form.df.model.false, trace=100) stopifnot1(rv, X) printf("-- change the data frame, make sure we pick up the changed value\n") get.data() lm.form.df.model.false <- lm(Y~X1+X2, data=DF, model=FALSE) DF[1,2] <- 99 rv <- plotmo(lm.form.df.model.false, trace=100) stopifnot1(rv[1,1], 99) printf("-- change order of columns in the data frame, should be ok\n") get.data() lm.form.df.model.false <- lm(Y~X1+X2, data=DF, model=FALSE) DF <- data.frame(X2=X2, X1=X1) rv <- plotmo(lm.form.df.model.false, trace=100) stopifnot1(rv, X) printf("======= standard lm with a data frame and model=TRUE (the default)\n") get.data() lm.form.df.with.dot <- lm(Y~., data=DF) printf("-- test basic use of DF\n") rv <- plotmo(lm.form.df.with.dot, trace=100) stopifnot1(rv, X) printf("-- test use same DF even when other variables change\n") get.data() lm.form.df.with.dot <- lm(Y~., data=DF) X1 <- "rubbish" rv <- plotmo(lm.form.df.with.dot, trace=100) stopifnot1(rv, X) printf("-- DF is now trashed but it doesn't matter because keepxy=T\n") DF <- "rubbish" rv <- plotmo(lm.form.df.with.dot, trace=100) stopifnot1(rv, X) printf("-- DF is NULL but it doesn't matter because keepxy=T\n") get.data() lm.form.df.with.dot <- lm(Y~., data=DF) DF <- NULL rv <- plotmo(lm.form.df.with.dot, trace=100) stopifnot1(rv, X) printf("-- DF and X1 are NULL but it doesn't matter because keepxy=T\n") DF <- NULL X1 <- "rubbish" rv <- plotmo(lm.form.df.with.dot, trace=100) stopifnot1(rv, X) printf("-- sanity check, make sure we are back to normal\n") get.data() lm.form.df.with.dot <- lm(Y~., data=DF) rv <- plotmo(lm.form.df.with.dot, trace=100) stopifnot1(rv, X) printf("-- change the data frame, but it doesn't matter because keepxy=T\n") get.data() lm.form.df.with.dot <- lm(Y~., data=DF) DF[1,2] <- 99 rv <- plotmo(lm.form.df.with.dot, trace=100) stopifnot1(rv, X) printf("-- change order of columns in the data frame, should be ok\n") get.data() lm.form.df.with.dot <- lm(Y~., data=DF) DF <- data.frame(X2=X2, X1=X1) rv <- plotmo(lm.form.df.with.dot, trace=100) stopifnot1(rv, X) printf("======= standard lm with a data frame and model=FALSE but x=TRUE\n") get.data() lm.form.df.model.false.x.true <- lm(Y~., data=DF, model=FALSE, x=TRUE) printf("-- test basic use of DF\n") rv <- plotmo(lm.form.df.model.false.x.true, trace=100) stopifnot1(rv, X) printf("-- test DF not available (shouldn't matter)\n") DF <- "rubbish" rv <- plotmo(lm.form.df.model.false.x.true, trace=100) stopifnot1(rv, X) printf("-- test $x trashed causes failure\n") get.data() lm.form.df.model.false.x.true <- lm(Y~., data=DF, model=FALSE, x=TRUE) DF <- "rubbish" X2 <- "rubbish1" lm.form.df.model.false.x.true[["x"]] <- "nonesuch" expect.err(try(plotmo(lm.form.df.model.false.x.true, trace=100)), "cannot get the original model predictors") printf("-- test ok with $x trashed but DF ok\n") # although with trace!=100 will get downstream failures in predict.lm, that's ok get.data() lm.form.df.model.false.x.true[["x"]] <- "nonesuch" # Warning: object$x may be corrupt rv <- plotmo(lm.form.df.model.false.x.true, trace=100) stopifnot1(rv, X) printf("-- test \"warning: object$x may be corrupt\", same as above but set options(warn=2)\n") options(warn=2) get.data() lm.form.df.model.false.x.true[["x"]] <- "nonesuch" # Warning: object$x may be corrupt expect.err(try(plotmo(lm.form.df.model.false.x.true, trace=100)), "x may be corrupt") options(warn=1) stopifnot1(rv, X) printf("====== strings in the data.frame\n") tit1 <- get.tit() tit1$char.pclass <- as.character(tit1$pclass) earth.survived.vs.pclass <- earth(survived~pclass, data=tit1, linpreds=TRUE) x.earth.survived.vs.pclass <- plotmo(earth.survived.vs.pclass, trace=100, linpreds=TRUE) stopifnot(is.factor(x.earth.survived.vs.pclass[[1]])) earth.survived.vs.char.pclass <- earth(survived~char.pclass, data=tit1) x.earth.survived.vs.char.pclass <- plotmo(earth.survived.vs.char.pclass, trace=100) stopifnot(is.factor(x.earth.survived.vs.char.pclass[[1]])) stopifnot(x.earth.survived.vs.pclass == x.earth.survived.vs.char.pclass) lm.survived.vs.pclass <- earth(survived~pclass, data=tit1, linpreds=TRUE) x.lm.survived.vs.pclass <- plotmo(lm.survived.vs.pclass, trace=100, linpreds=TRUE) stopifnot(is.factor(x.lm.survived.vs.pclass[[1]])) lm.survived.vs.char.pclass <- earth(survived~char.pclass, data=tit1) x.lm.survived.vs.char.pclass <- plotmo(lm.survived.vs.char.pclass, trace=100) stopifnot(is.factor(x.lm.survived.vs.char.pclass[[1]])) stopifnot(x.lm.survived.vs.pclass == x.lm.survived.vs.char.pclass) stopifnot(x.lm.survived.vs.pclass == x.earth.survived.vs.pclass) printf("-- test.plotmo.x done\n") source("test.epilog.R") plotmo/inst/slowtests/test.degree.bat0000755000176200001440000000156114563571565017540 0ustar liggesusers@rem test.degree.bat: test plotmo's degree1 and degree2 args with character arguments @echo test.degree.bat @"C:\PROGRA~1\R\R-4.3.2\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.degree.R @if %errorlevel% equ 0 goto good1: @echo R returned errorlevel %errorlevel%, see test.degree.Rout: @echo. @tail test.degree.Rout @echo test.degree.R @exit /B 1 :good1 mks.diff test.degree.Rout test.degree.Rout.save @if %errorlevel% equ 0 goto good2: @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.degree.save.ps @exit /B 1 :good2 @rem test.degree.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.degree.save.ps @if %errorlevel% equ 0 goto good3: @echo === Files are different === @exit /B 1 :good3 @rm -f test.degree.Rout @rm -f Rplots.ps @exit /B 0 plotmo/inst/slowtests/test.plotmo.args.R0000644000176200001440000001131513737415772020177 0ustar liggesusers# test.plotmo.args..R: test dot and other argument handling in plotmo source("test.prolog.R") library(earth) data(ozone1) options(warn=1) # print warnings as they occur options(warn=2) # treat warnings as errors lm.mod <- lm(O3~wind, data=ozone1) expect.err(try(plotmo(lm.mod, se=2, leve=.95)), "plotmo's 'se' argument is deprecated, please use 'level' instead") expect.err(try(plotmo(lm.mod, se=T)), "plotmo's 'se' argument is deprecated, please use 'level=.95' instead") expect.err(try(plotmo(lm.mod, se=.8)), "plotmo's 'se' argument is deprecated, please use 'level=.95' instead") expect.err(try(plotmo(lm.mod, level=2)), "level=2 is out of range, try level=.95") oz2 <- ozone1[1:40,] set.seed(2015) a <- earth(O3~temp+wind, dat=oz2, deg=2, nk=21, ncr=3, nfo=3, varmod.me="lm") expect.err(try(plotmo(a, lw=2, trace=1, thresh=.9, SHOWCALL=TRUE)), "predict.earth ignored argument 'lw'") options(warn=1) # test col.response and friends plotmo(a, col.response=2, pch.response=c(1, 2, 20), type2="co", SHOWCALL=TRUE) # pch.response tests back compat plotmo(a, pt.col=c(1,2,3), pt.pch=c(1, 2, 20), type2="im", SHOWCALL=TRUE) plotmo(a, pt.col=c(1,2,3), pt.pch=paste(1:nrow(oz2)), pt.cex=.8, type2="im", do.par=2, SHOWCALL=TRUE) plotmo(a, pt.col=c(1,2,3), pt.pch=paste(1:nrow(oz2)), pt.cex=.8, type2="co", degree1=0, do.par=F) par(org.par) plotmo(a, col=2, SHOWCALL=TRUE) # will cause red response points plotmo(a, pt.col=4, col=3, persp.col="pink", SHOWCALL=TRUE) # col now goes to lines # test cex and nrug and smooth plotmo(a, cex=.8, SHOWCALL=TRUE, nrug=-1, rug.col=2, rug.lwd=1, smooth.col=3, bty="n", col.lab="darkorange", xlab="an x label", cex.lab=1.2) # esoteric, but they work plotmo(a, SHOWCALL=TRUE, density.col=2, density.lty=2, smooth.col=3, smooth.f=.3, col="lightblue") plotmo(a, cex=1.2, SHOWCALL=TRUE, nrug="density") # test caption, grid, interval options plotmo(a, caption.col=3, caption.font=2, grid.col="pink", level=.8, SHOWCALL=TRUE) plotmo(a, caption.col=2, caption.font=2, caption.cex=.8, grid.col=TRUE, bty="n", level=.8, level.shade="lightblue", level.shade2="red", grid.lty=3, grid.lwd=4, grid.nx=NA, SHOWCALL=TRUE) # test overall plot args handled by par() and graphics args outside do.par par(mfrow=c(2,2), mar = c(3,3,3,1), mgp = c(1.5,.5,0), oma=c(0,0,4,0)) par(col.main="#456789") old.mar <- par("mar") old.mfcol <- par("mfcol") cat("before par: cex=", par("cex"), " col.main=", par("col.main"), " col.axis=", par("col.axis"), " mar=", par("mar"), " mfcol=", par("mfcol"), "\n", sep="") plotmo(a, mfcol=c(2,3), cex.main=1.4, oma=c(5,5,5,5), SHOWCALL=TRUE) plotmo(a, caption="no cex") plotmo(a, cex=1, caption="cex=1, plot should be identical to previous page") plotmo(a, cex=1.2, caption="cex=1.2") plotmo(a, do.par=FALSE, degree2=0, degree1=1, main="do.par=FALSE no cex", caption="a test graphics args with do.par=FALSE") plotmo(a, do.par=FALSE, degree2=0, degree1=1, cex=1, main="do.par=FALSE cex=1") plotmo(a, do.par=FALSE, degree2=0, degree1=1, cex=.8, main="do.par=FALSE cex=.8") plotmo(a, do.par=FALSE, degree2=0, degree1=1, cex=1.1, xlab="xlab", col.main=2, col.axis="blue", col.lab=3, font.lab=2, main="do.par=FALSE cex=1.1, col.main=2\ncol.axis=\"blue\", col.lab=3, font.lab=2") plotmo(a, do.par=FALSE, degree1=1, degree2=1, persp.ticktype="d", main="do.par=FALSE persp.ticktype=\"d\"") # all of these should have been restored cat("after par: cex=", par("cex"), " col.main=", par("col.main"), " col.axis=", par("col.axis"), " mar=", par("mar"), " mfcol=", par("mfcol"), "\n", sep="") stopifnot(par("col.main") == "#456789") stopifnot(par("mar") == old.mar) stopifnot(par("mfcol") == old.mfcol) par(col.main=1) # test aliasing of col with other args, and back compat of col.degree1 vs degree1.col data(etitanic) a20 <- earth(pclass ~ ., data=etitanic, degree=2) plotmo(a20, nresponse=1, col=2, col.degree1=3, persp.col="pink", SHOWCALL=1, degree1=1:2, degree2=1:2) plotmo(a20, nresponse=1, lty=2, persp.lty=1, SHOWCALL=1, degree1=1:2, degree2=1:2) # test "prednames." with a long predictor name data(trees) trees.with.long.predname <- trees trees.with.long.predname$a_quite_long_variable_name <- trees.with.long.predname$Girth trees.with.long.predname$Girth <- NULL mod <- earth(Volume~.,data=trees.with.long.predname) par(mfrow=c(3,2), mar = c(3,3,3,1), mgp = c(1.5,.5,0), oma=c(0,0,4,0)) plotmo(mod, do.par=FALSE) plotmo(mod, do.par=FALSE, prednames.abbreviate=FALSE) expect.err(try(plotmo(mod, do.par=FALSE, prednames.abbreviate=c(1,2))), "the prednames.abbreviate argument is not FALSE, TRUE, 0, or 1") plotmo(mod, do.par=FALSE, prednames.minlength=3) source("test.epilog.R") plotmo/inst/slowtests/test.mlr.R0000644000176200001440000003721514015545377016526 0ustar liggesusers# test.mlr.R: test the "mlr" package with plotmo and plotres # # TODO mlr is in maintenance mode, add mlr3 support to plotmo? # TODO generally, plotres residuals for WrappedModel prob models aren't right source("test.prolog.R") library(mlr) library(plotmo) library(rpart.plot) library(earth) # TODO following function is temporary until mlr package is updated train.with.call <- function(learner, task, subset=NULL, weights=NULL) { retval <- train(learner, task, subset, weights) retval$call <- match.call() retval } cat("==simple one variable regression model with earth ===============================\n") data(trees) trees1 <- trees[,c("Volume", "Girth")] task <- makeRegrTask(data=trees1, target="Volume") lrn <- makeLearner("regr.earth", degree=2) regr.earth.with.call = train.with.call(lrn, task) regr.earth = train(lrn, task) earth <- earth(Volume~., data=trees1, degree=2) # SHOWCALL is just a testing thing, so we can see who created the plot on the plot itself plotres(regr.earth.with.call, SHOWCALL=TRUE) plotres(regr.earth$learner.model, SHOWCALL=TRUE) plotres(earth, SHOWCALL=TRUE) plotmo(regr.earth.with.call, trace=1, SHOWCALL=TRUE) plotmo(regr.earth$learner.model, trace=1, SHOWCALL=TRUE) plotmo(earth, trace=1, SHOWCALL=TRUE) # compare partial dependence plots from mlr and plotmo packages set.seed(2018) plotmo(earth, pmethod="partdep", SHOWCALL=TRUE, col=2, pt.col="darkgray", grid.col="lightgray") set.seed(2018) pd <- generatePartialDependenceData(regr.earth, task, "Girth", n=c(50, NA)) print(plotPartialDependence(pd, data = getTaskData(task))) cat("==test error handling if original data is messed up===========================\n") par(mfrow=c(4,2), mar=c(1.5,2.5,4,1), oma=c(0,0,0,0)) colnames(trees1) <- c("nonesuch", "Volume") plotmo(regr.earth$learner.model, do.par=0, degree1=1, degree2=0, main='colnames(trees1) <- c("nonesuch", "Volume")') plotmo(regr.earth.with.call, do.par=0, degree1=1, degree2=0) par(org.par) expect.err(try(plotmo(earth, degree1=1, degree2=0)), "cannot get the original model predictors") cat("==regression model with randomForest (binary response)============================\n") library(randomForest) library(earth) # for etitanic data data(etitanic) set.seed(2018) # use a logical subset (since we test for numeric subset elsewhere) # use a small subset so we can see easily if subset is applied or ignored in plots train.subset <- rnorm(nrow(etitanic)) > 1 # 166 cases ((16% of 1046 cases)) printf("sum(train.subset) %g (%.0f%% of %g cases)\n", sum(train.subset), 100 * sum(train.subset) / nrow(etitanic), nrow(etitanic)) task.regr.rf <- makeRegrTask(data=etitanic, target="survived") lrn.regr.rf = makeLearner("regr.randomForest") set.seed(2018) regr.rf.with.call = train.with.call(lrn.regr.rf, task.regr.rf, subset=train.subset) set.seed(2018) rf <- randomForest(survived~., data=etitanic, subset=train.subset) # sanity check that the models are identical stopifnot(identical(predict(regr.rf.with.call$learner.model), predict(rf))) plotres(regr.rf.with.call, info=TRUE, SHOWCALL=TRUE) # plotres(regr.rf$learner.model, info=TRUE, SHOWCALL=TRUE) # Error: no formula in getCall(object) plotres(rf, info=TRUE, SHOWCALL=TRUE) set.seed(2018) # for repeatable jitter in points (specified with pt.col) plotmo(regr.rf.with.call, pt.col=2, SHOWCALL=TRUE) # plotmo(regr.rf$learner.model, trace=1, SHOWCALL=TRUE) # Error: no formula in getCall(object) set.seed(2018) plotmo(rf, pt.col=2, SHOWCALL=TRUE) # compare partial dependence plots set.seed(2018) plotmo(regr.rf.with.call, degree1="age", degree2=0, pmethod="partdep", grid.col="gray", col=2, pt.col="darkgray", SHOWCALL=TRUE) # function from randomForest package set.seed(2018) partialPlot(rf, pred.data=etitanic[train.subset,], x.var="age", n.pt=50, ylim=c(0, 1)) grid() # function from mlr package set.seed(2018) pd <- generatePartialDependenceData(regr.rf.with.call, task.regr.rf, "age", n=c(50, NA)) print(plotPartialDependence(pd, data = getTaskData(task.regr.rf))) plotmo(regr.rf.with.call, degree1="pclass", degree2=0, pmethod="partdep", SHOWCALL=TRUE) set.seed(2018) # function from randomForest package set.seed(2018) partialPlot(rf, pred.data=etitanic[train.subset,], x.var="pclass", n.pt=50, ylim=c(0, 1)) grid() # TODO following fails pd <- generatePartialDependenceData(regr.rf.with.call, task.regr.rf, "pclass", n=c(50, NA)) try(print(plotPartialDependence(pd, data = getTaskData(task.regr.rf)))) # Error: Discrete value supplied to continuous scale cat("==classification model with randomForest (binary response)======================\n") set.seed(2018) library(earth) # for etitanic data data(etitanic) etit <- etitanic etit$survived <- factor(etit$survived, labels=c("notsurvived", "survived")) task.classif.rf <- makeClassifTask(data=etit, target="survived") lrn.classif.rf <- makeLearner("classif.randomForest", predict.type="prob") set.seed(2018) classif.rf.with.call <- train.with.call(lrn.classif.rf, task.classif.rf, , subset=train.subset) set.seed(2018) rf <- randomForest(survived~., data=etit, method="class", subset=train.subset) # sanity check that the models are identical stopifnot(identical(predict(classif.rf.with.call$learner.model), predict(rf))) # TODO following causes Error: classif.earth: Setting parameter glm without available description object # lrn <- makeLearner("classif.earth", degree=2, glm=list(family=binomial)) # TODO residuals on WrappedModel don't match direct call to rf model set.seed(2018) # for repeatable jitter plotres(classif.rf.with.call, nresponse="prob.survived", SHOWCALL=TRUE, jitter=2) set.seed(2018) plotres(classif.rf.with.call$learner.model, type="prob", SHOWCALL=TRUE, jitter=2) set.seed(2018) plotres(rf, type="prob", SHOWCALL=TRUE, jitter=2) options(warn=2) # treat warnings as errors expect.err(try(plotmo(classif.rf.with.call)), "Defaulting to nresponse=1, see above messages") options(warn=1) set.seed(2018) # for repeatable jitter plotmo(classif.rf.with.call, SHOWCALL=TRUE, nresponse="prob.survived", pt.col=2, trace=2) set.seed(2018) plotmo(classif.rf.with.call$learner.model, SHOWCALL=TRUE, type="prob", pt.col=2) set.seed(2018) # note that in the following, get.y.shift.scale (in plotmo code) rescales the plotted y to 0..1 plotmo(rf, SHOWCALL=TRUE, type="prob", pt.col="gray") set.seed(2018) # in following graph, note that get.y.shift.scale doesn't rescale the plotted y because ylim=c(0,2) plotmo(rf, SHOWCALL=TRUE, type="prob", ylim=c(0,2), pt.col="gray") # compare partial dependence plots set.seed(2018) plotmo(rf, type="prob", degree1="pclass", degree2=0, pmethod="partdep", pt.col=2, SHOWCALL=TRUE) set.seed(2018) plotmo(rf, degree1="pclass", degree2=0, pmethod="partdep", pt.col=2, SHOWCALL=TRUE) set.seed(2018) # TODO following fails pd <- generatePartialDependenceData(classif.rf.with.call, task.classif.rf, "pclass", n=c(50, NA)) try(print(plotPartialDependence(pd, data = getTaskData(task.classif.rf)))) # Error: Discrete value supplied to continuous scale plotmo(rf, type="prob", nresponse="notsurvived", degree1="age", degree2=0, pmethod="partdep", ylim=c(.3,.75), nrug=TRUE, grid.col="gray") # looks plausible set.seed(2018) pd <- generatePartialDependenceData(classif.rf.with.call, task.classif.rf, "age", n=c(50, NA)) print(plotPartialDependence(pd, data = getTaskData(task.classif.rf))) cat("==examples from plotmo-notes.pdf ===============================================\n") #-- Regression model with mlr ------------------------------------------- library(mlr) library(plotmo) lrn <- makeLearner("regr.svm") fit1.with.call <- train.with.call(lrn, bh.task) fit1 <- train(lrn, bh.task) # generate partial dependence plots for all variables # we use "apartdep" and not "partdep" to save testing time plotmo(fit1.with.call, pmethod="apartdep") plotmo(fit1$learner.model, pmethod="apartdep") # generate partial dependence plot for just "lstat" set.seed(2018) # so slight jitter on pt.col points in plotmo doesn't change across test runs plotmo(fit1.with.call, degree1="lstat", # what predictor to plot degree2=0, # no interaction plots pmethod="partdep", # generate partial dependence plot pt.col=2, grid.col="gray", # optional bells and whistles nrug=TRUE) # rug ticks along the bottom set.seed(2018) # so slight jitter on pt.col points in plotmo doesn't change across test runs plotmo(fit1$learner.model, degree1="lstat", # what predictor to plot degree2=0, # no interaction plots pmethod="partdep", # generate partial dependence plot pt.col=2, grid.col="gray", # optional bells and whistles nrug=TRUE) # rug ticks along the bottom # compare to the function provided by the mlr package set.seed(2018) pd <- generatePartialDependenceData(fit1, bh.task, "lstat", n=c(50, NA)) print(plotPartialDependence(pd, data = getTaskData(bh.task))) # # TODO following fails: Error: Discrete value supplied to continuous scale # pd <- generatePartialDependenceData(fit1, bh.task, "chas", n=c(50, NA)) # plotPartialDependence(pd, data = getTaskData(bh.task)) #-- Classification model with mlr --------------------------------------- lrn.classif.rpart <- makeLearner("classif.rpart", predict.type = "prob", minsplit = 10) fit2.with.call <- train.with.call(lrn.classif.rpart, iris.task) fit2 <- train(lrn.classif.rpart, iris.task) # generate partial dependence plots for all variables # TODO plotmo can plot the response for only one class at a time plotmo(fit2.with.call, nresponse="prob.virginica", # what response to plot # type="prob", # type gets passed to predict.rpart pmethod="apartdep") # generate partial dependence plot plotmo(fit2$learner.model, nresponse="virginica", # what response to plot type="prob", # type gets passed to predict.rpart pmethod="apartdep") # generate partial dependence plot # generate partial dependence plot for just "Petal.Length" plotmo(fit2.with.call, degree1="Petal.Length", # what predictor to plot degree2=0, # no interaction plots nresponse="prob.virginica", # what response to plot # type="prob", # type gets passed to predict.rpart pmethod="apartdep") # generate partial dependence plot plotmo(fit2$learner.model, degree1="Petal.Length", # what predictor to plot degree2=0, # no interaction plots nresponse="virginica", # what response to plot type="prob", # type gets passed to predict.rpart pmethod="apartdep") # generate partial dependence plot # compare to the function provided by the mlr package set.seed(2018) pd <- generatePartialDependenceData(fit2, iris.task, "Petal.Length", n=c(50, NA)) print(plotPartialDependence(pd, data = getTaskData(iris.task))) cat("==lda example from mlr documentation, and plotmo error handling =================\n") set.seed(2018) data(iris) task.lda <- makeClassifTask(data=iris, target="Species") lrn.lda <- makeLearner("classif.lda") n <- nrow(iris) train.set <- sample(n, size=2/3*n) test.set <- setdiff(1:n, train.set) classif.lda.with.call <- train.with.call(lrn.lda, task.lda, subset=train.set) classif.lda <- train(lrn.lda, task.lda, subset=train.set) iris1 <- iris[train.set, ] library(MASS) lda <- lda(Species~., data=iris1) # expect.err(try(plotres(classif.lda.with.call)), "plotres does not (yet) support type=\"class\" for \"lda\" objects") expect.err(try(plotres(classif.lda$learner.model)), "plotres does not (yet) support type=\"class\" for \"lda\" objects") options(warn=2) # treat warnings as errors # expect.err(try(plotres(classif.lda.with.call, type="response")), "predict.lda returned multiple columns (see above) but nresponse is not specified") expect.err(try(plotres(classif.lda$learner.model, type="response")), "Defaulting to nresponse=1, see above messages") options(warn=1) expect.err(try(plotres(classif.lda.with.call, type="response", nresponse="nonesuch")), "nresponse=\"nonesuch\" is not allowed") expect.err(try(plotres(classif.lda$learner.model, type="response", nresponse="nonesuch")), "nresponse=\"nonesuch\" is not allowed") expect.err(try(plotres(classif.lda.with.call, type="response", nresponse=0)), "nresponse=0 but it should be at least 1") expect.err(try(plotres(classif.lda$learner.model, type="response", nresponse=0)), "nresponse=0 but it should be at least 1") expect.err(try(plotres(classif.lda.with.call, type="response", nresponse=99)), "nresponse is 99 but the number of columns is only 1") expect.err(try(plotres(classif.lda$learner.model, type="response", nresponse=99)), "nresponse is 99 but the number of columns is only 2") expect.err(try(plotmo(classif.lda)), "getCall(classif.lda) failed") expect.err(try(plotres(classif.lda)), "getCall(classif.lda) failed") # TODO residuals don't match plotres(classif.lda.with.call, SHOWCALL=TRUE, type="response") plotres(classif.lda$learner.model, SHOWCALL=TRUE, type="response", nresponse="LD2") plotres(lda, SHOWCALL=TRUE, type="response", nresponse="LD2") plotmo(classif.lda.with.call, SHOWCALL=TRUE) plotmo(classif.lda$learner.model, SHOWCALL=TRUE) plotmo(lda, SHOWCALL=TRUE) # # TODO plotPartialDependence and plotmo graphs below don't match # pd <- generatePartialDependenceData(classif.lda, task.lda, "Petal.Width", n=c(50, NA)) # TODO generates warnings # print(plotPartialDependence(pd, data = getTaskData(task.lda))) plotmo(classif.lda.with.call, degree1="Petal.Width", degree2=0, pmethod="partdep", do.par=FALSE) plotmo(classif.lda.with.call, SHOWCALL=TRUE, all2=TRUE, type="response") plotmo(classif.lda$learner.model, SHOWCALL=TRUE, all2=TRUE, type="class") plotmo(lda, SHOWCALL=TRUE, all2=TRUE, type="class") plotmo(classif.lda$learner.model, SHOWCALL=TRUE, all2=TRUE, type="response", nresponse="LD1") plotmo(lda, SHOWCALL=TRUE, all2=TRUE, type="response", nresponse="LD1") cat("==test recursive call to plotmo_prolog for learner.model===============\n") set.seed(2018) n <- 100 data <- data.frame( x1 = rnorm(n), x2 = rnorm(n), x3 = rnorm(n), x4 = rnorm(n), x5 = rnorm(n), x6 = rnorm(n), x7 = rnorm(n), x8 = rnorm(n), x9 = rnorm(n)) data$y <- sin(data$x3) + sin(data$x4) + 2 * cos(data$x5) set.seed(2018) library(gbm) # reference model gbm = gbm(y~., data=data, n.trees=300) plotmo(gbm, trace=-1, SHOWCALL=TRUE) set.seed(2018) task <- makeRegrTask(data=data, target="y") lrn <- makeLearner("regr.gbm", n.trees=300, keep.data=TRUE) regr.gbm = train.with.call(lrn, task) plotmo(regr.gbm, trace=-1, SHOWCALL=TRUE) set.seed(2018) lrn <- makeLearner("regr.gbm", n.trees=300) regr.gbm.nokeepdata = train.with.call(lrn, task) # expect message: use keep.data=TRUE in the call to gbm (cannot determine the variable importances) plotmo(regr.gbm.nokeepdata, trace=1, SHOWCALL=TRUE) plotres(regr.gbm, SHOWCALL=TRUE) cat("==example from makeClassificationViaRegressionWrapper help page ===============\n") # this tests that plotmo.prolog can access the learner.model at object$learner.model$next.model$learner.model set.seed(2018) lrn = makeLearner("regr.rpart") lrn = makeClassificationViaRegressionWrapper(lrn) ClassificationViaRegression = train.with.call(lrn, sonar.task, subset = 1:140) plotmo(ClassificationViaRegression, SHOWCALL=TRUE) source("test.epilog.R") plotmo/inst/slowtests/test.caret.Rout.save0000644000176200001440000003615214563614021020505 0ustar liggesusers> # test.caret.R: test plotmo on caret models > # > # TODO This is a minimal set of tests. > > source("test.prolog.R") > library(plotmo) Loading required package: Formula Loading required package: plotrix > library(earth) > library(caret) Loading required package: ggplot2 Loading required package: lattice > data(ozone1) > data(etitanic) > dopar <- function(nrows, ncols, caption = "") + { + cat(" ", caption, "\n") + par(mfrow=c(nrows, ncols)) + par(oma = c(0, 0, 3, 0)) + par(mar = c(3, 3, 1.7, 0.5)) + par(mgp = c(1.6, 0.6, 0)) + par(cex = 0.7) + } > set.seed(2010) > caret.earth.mod <- train(O3~., data=ozone1, method="earth", + tuneGrid=data.frame(degree=2, nprune=10)) > # SHOWCALL is just a testing thing, so we can see who created the plot on the plot itself > plotmo(caret.earth.mod, trace=1, SHOWCALL=TRUE) plotmo.prolog(object$finalModel) succeeded (caret model) stats::predict(train.object, data.frame[3,9], type="raw") stats::fitted(object=train.object) got model response from model.frame(O3 ~ vh + wind + humidity + temp + ib..., data=call$data, na.action="na.fail") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > plotmo(caret.earth.mod$finalModel, trace=1, SHOWCALL=TRUE) stats::predict(earth.object, NULL, type="response") stats::fitted(object=earth.object) got model response from object$y plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > plotres(caret.earth.mod, trace=1, SHOWCALL=TRUE) plotmo.prolog(object$finalModel) succeeded (caret model) residuals() was unsuccessful, will use predict() instead stats::predict(train.object, data.frame[3,9], type="raw") stats::fitted(object=train.object) got model response from model.frame(O3 ~ vh + wind + humidity + temp + ib..., data=call$data, na.action="na.fail") training rsq 0.81 > # plotres(caret.earth.mod$finalModel, trace=1, SHOWCALL=TRUE) > > set.seed(2015) > bag <- bagEarth(O3~., data=ozone1, degree=2, B=3) > print(bag$fit) $Resample1 Selected 13 of 19 terms, and 7 of 9 predictors Termination condition: Reached nk 21 Importance: temp, humidity, ibt, doy, vis, dpg, wind, vh-unused, ... Number of terms at each degree of interaction: 1 4 8 GCV 10.06481 RSS 2726.679 GRSq 0.8269797 RSq 0.8570949 $Resample2 Selected 15 of 21 terms, and 7 of 9 predictors Termination condition: Reached nk 21 Importance: temp, ibh, humidity, doy, vh, dpg, wind, ibt-unused, ... Number of terms at each degree of interaction: 1 6 8 GCV 14.07142 RSS 3685.688 GRSq 0.7976107 RSq 0.8383817 $Resample3 Selected 16 of 21 terms, and 8 of 9 predictors Termination condition: Reached nk 21 Importance: temp, ibt, humidity, doy, vis, dpg, vh, ibh, wind-unused Number of terms at each degree of interaction: 1 7 8 GCV 12.3789 RSS 3187.464 GRSq 0.8064265 RSq 0.8480394 > # pairs are plotted correctly (I think) > plotmo(bag, type="response", trace=1, SHOWCALL=TRUE) stats::predict(bagEarth.object, data.frame[3,9], type="response") stats::fitted(object=bagEarth.object) fitted() was unsuccessful, will use predict() instead assuming "O3" in the model.frame is the response, because terms(object) did not return the terms assuming "O3" in the model.frame is the response, because terms(object) did not return the terms got model response from model.frame(O3 ~ ., data=call$data, na.action="na.fail") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > plotres(bag, type="response", trace=1, SHOWCALL=TRUE) stats::residuals(object=bagEarth.object, type="response") residuals() was unsuccessful, will use predict() instead stats::predict(bagEarth.object, data.frame[3,9], type="response") stats::fitted(object=bagEarth.object) fitted() was unsuccessful, will use predict() instead assuming "O3" in the model.frame is the response, because terms(object) did not return the terms assuming "O3" in the model.frame is the response, because terms(object) did not return the terms got model response from model.frame(O3 ~ ., data=call$data, na.action="na.fail") assuming "O3" in the model.frame is the response, because terms(object) did not return the terms training rsq 0.83 > > set.seed(2015) > a.bag1 <- bagEarth(trees[,-3], trees[,3], degree=2, B = 3) > plotmo(a.bag1, trace=1, SHOWCALL=TRUE, all2=TRUE, caption="bagEarth, trees") stats::predict(bagEarth.object, data.frame[3,2], type="response") stats::fitted(object=bagEarth.object) fitted() was unsuccessful, will use predict() instead got model response from getCall(object)$y plotmo grid: Girth Height 12.9 76 > plotres(a.bag1, trace=1, SHOWCALL=TRUE) stats::residuals(object=bagEarth.object, type="response") residuals() was unsuccessful, will use predict() instead stats::predict(bagEarth.object, data.frame[3,2], type="response") stats::fitted(object=bagEarth.object) fitted() was unsuccessful, will use predict() instead got model response from getCall(object)$y training rsq 0.98 > > # trace=1 to display "Fixed rank deficient bx by removing 1 term" messages > set.seed(2015) > a.bag3 <- bagEarth(survived~., data=etitanic, degree=2, B=3, trace=1) x[1046,7] with colnames pclass1st pclass2nd pclass3rd sexmale age sibsp parch y[1046,1] with colname subY, and values 0, 0, 0, 0, 1, 1, 1, 0, 0, 0,... weights: no weights (because all weights equal) Forward pass term 1, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20 Reached nk 21 After forward pass GRSq 0.435 RSq 0.472 Prune backward penalty 3 nprune null: selected 10 of 15 terms, and 6 of 7 preds After pruning pass GRSq 0.444 RSq 0.468 x[1046,7] with colnames pclass1st pclass2nd pclass3rd sexmale age sibsp parch y[1046,1] with colname subY, and values 0, 0, 1, 1, 1, 0, 0, 0, 1, 1,... weights: no weights (because all weights equal) Forward pass term 1, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20 Reached nk 21 After forward pass GRSq 0.385 RSq 0.434 Prune backward penalty 3 nprune null: selected 12 of 18 terms, and 6 of 7 preds After pruning pass GRSq 0.402 RSq 0.433 x[1046,7] with colnames pclass1st pclass2nd pclass3rd sexmale age sibsp parch y[1046,1] with colname subY, and values 1, 1, 0, 1, 1, 1, 0, 1, 0, 0,... weights: no weights (because all weights equal) Forward pass term 1, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20 Reached nk 21 After forward pass GRSq 0.451 RSq 0.487 Prune backward penalty 3 nprune null: selected 13 of 15 terms, and 6 of 7 preds After pruning pass GRSq 0.456 RSq 0.487 > plotmo(a.bag3, clip=F, caption="bagEarth, etitanic", trace=1, SHOWCALL=TRUE) stats::predict(bagEarth.object, data.frame[3,7], type="response") stats::fitted(object=bagEarth.object) fitted() was unsuccessful, will use predict() instead assuming "survived" in the model.frame is the response, because terms(object) did not return the terms assuming "survived" in the model.frame is the response, because terms(object) did not return the terms got model response from model.frame(survived ~ ., data=call$data, na.action="na.fail") plotmo grid: pclass1st pclass2nd pclass3rd sexmale age sibsp parch 0 0 0 1 28 0 0 > plotres(a.bag3, clip=F, trace=1, SHOWCALL=TRUE) stats::residuals(object=bagEarth.object, type="response") residuals() was unsuccessful, will use predict() instead stats::predict(bagEarth.object, data.frame[3,7], type="response", clip=FALSE) stats::fitted(object=bagEarth.object) fitted() was unsuccessful, will use predict() instead assuming "survived" in the model.frame is the response, because terms(object) did not return the terms assuming "survived" in the model.frame is the response, because terms(object) did not return the terms got model response from model.frame(survived ~ ., data=call$data, na.action="na.fail") assuming "survived" in the model.frame is the response, because terms(object) did not return the terms training rsq 0.44 > > # following based on example by Max Kuhn on stackoverflow > etit <- etitanic > etit$survived <- factor(ifelse(etit$survived == 1, "yes", "no"), + levels = c("yes", "no")) > set.seed(2015) > caret.earth.mod2 <- train(survived ~ ., + data = etit, + method = "earth", + tuneGrid = data.frame(degree = 2, nprune = 9), + trControl = trainControl(method = "none", + classProbs = TRUE)) > # Following gives expected warning (because factors in caret-earth model) > # Warning: Cannot determine which variables to plot (use all1=TRUE?) > plotmo(caret.earth.mod2, trace=1, SHOWCALL=TRUE) plotmo.prolog(object$finalModel) succeeded (caret model) stats::predict(train.object, data.frame[3,5], type="raw") stats::fitted(object=train.object) got model response from model.frame(survived ~ pclass + sex + age + sibsp..., data=call$data, na.action="na.fail") Warning: Cannot determine which variables to plot (use all1=TRUE?) ncol(x) 5 < nrow(modvars) 6 colnames(x)=c(pclass,sex,age,sibsp,parch) rownames(modvars)=c(pclass2nd,pclass3rd,sexmale,age,sibsp,parch) plotmo grid: pclass sex age sibsp parch 3rd male 28 0 0 > # changed Sep 2020: following with all2=2 generates the same plot as above (because with warning, above defaults to all2=TRUE) > plotmo(caret.earth.mod2, trace=1, all2=TRUE, SHOWCALL=TRUE, caption="caret.earth.mod2: all2=2") plotmo.prolog(object$finalModel) succeeded (caret model) stats::predict(train.object, data.frame[3,5], type="raw") stats::fitted(object=train.object) got model response from model.frame(survived ~ pclass + sex + age + sibsp..., data=call$data, na.action="na.fail") Warning: Cannot determine which variables to plot (use all1=TRUE?) ncol(x) 5 < nrow(modvars) 6 colnames(x)=c(pclass,sex,age,sibsp,parch) rownames(modvars)=c(pclass2nd,pclass3rd,sexmale,age,sibsp,parch) plotmo grid: pclass sex age sibsp parch 3rd male 28 0 0 > plotres(caret.earth.mod2, trace=1, SHOWCALL=TRUE) plotmo.prolog(object$finalModel) succeeded (caret model) residuals() was unsuccessful, will use predict() instead stats::predict(train.object, data.frame[3,5], type="raw") stats::fitted(object=train.object) got model response from model.frame(survived ~ pclass + sex + age + sibsp..., data=call$data, na.action="na.fail") training rsq 0.21 > > # Sep 2020: test with a logical variable (check that get.earth.vars.for.plotmo strips "sexTRUE" to "sex") > # following should be exactly the same model as caret.earth.mod2 except for the variable naming for sex > etit.bool <- etitanic > etit.bool$survived <- factor(ifelse(etit.bool$survived == 1, "yes", "no"), + levels = c("yes", "no")) > etit.bool$sex <- etit.bool$sex == "male" # to bool > set.seed(2015) # same random seed as above (may not be necessary) > caret.earth.boolfac <- train(survived ~ ., + data = etit.bool, + method = "earth", + tuneGrid = data.frame(degree = 2, nprune = 9), + trControl = trainControl(method = "none", + classProbs = TRUE)) > print(summary(caret.earth.boolfac)) Call: earth(x=matrix[1046,6], y=factor.object, keepxy=TRUE, glm=list(family=function.object, maxit=100), degree=2, nprune=9) GLM coefficients no (Intercept) -2.9135260 pclass3rd 5.0300560 sexTRUE 3.1856245 h(age-32) 0.0375715 pclass2nd * sexTRUE 1.7680945 pclass3rd * sexTRUE -1.2226954 pclass3rd * h(4-sibsp) -0.6186527 sexTRUE * h(16-age) -0.2418140 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 1414.62 1045 892.794 1038 0.369 908.8 5 1 Earth selected 8 of 17 terms, and 5 of 6 predictors (nprune=9) Termination condition: Reached nk 21 Importance: sexTRUE, pclass3rd, pclass2nd, age, sibsp, parch-unused Number of terms at each degree of interaction: 1 3 4 Earth GCV 0.1404529 RSS 141.7629 GRSq 0.4197106 RSq 0.4389834 > > plotmo(caret.earth.boolfac, trace=0, SHOWCALL=TRUE) # Warning: Cannot determine which variables to plot (use all1=TRUE?) Warning: Cannot determine which variables to plot (use all1=TRUE?) ncol(x) 5 < nrow(modvars) 6 colnames(x)=c(pclass,sex,age,sibsp,parch) rownames(modvars)=c(pclass2nd,pclass3rd,sexTRUE,age,sibsp,parch) plotmo grid: pclass sex age sibsp parch 3rd TRUE 28 0 0 > # changed Sep 2020: following with all1=TRUE, all2=TRUE generates the same plot as above > plotmo(caret.earth.boolfac, trace=0, all1=TRUE, all2=TRUE, SHOWCALL=TRUE, caption="caret.earth.mod2: all1=T, all2=T") plotmo grid: pclass sex age sibsp parch 3rd TRUE 28 0 0 > > data(ozone1) > set.seed(2020) > a <- train(O3 ~ ., data = ozone1, method = "earth", + tuneGrid = data.frame(degree = 2, nprune = 14)) > plotmo(a, trace=1, SHOWCALL=TRUE) plotmo.prolog(object$finalModel) succeeded (caret model) stats::predict(train.object, data.frame[3,9], type="raw") stats::fitted(object=train.object) got model response from model.frame(O3 ~ vh + wind + humidity + temp + ib..., data=call$data, na.action="na.fail") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > plotres(a, trace=1, SHOWCALL=TRUE) plotmo.prolog(object$finalModel) succeeded (caret model) residuals() was unsuccessful, will use predict() instead stats::predict(train.object, data.frame[3,9], type="raw") stats::fitted(object=train.object) got model response from model.frame(O3 ~ vh + wind + humidity + temp + ib..., data=call$data, na.action="na.fail") training rsq 0.83 > > cat("=== method=\"svmRadial\" (S4 model wrapped in an S3 model) ===\n") === method="svmRadial" (S4 model wrapped in an S3 model) === > data(trees) > set.seed(2019) > library(kernlab) Attaching package: 'kernlab' The following object is masked from 'package:ggplot2': alpha > mod <- train(Girth~., data=trees, method="svmRadial", + trControl=trainControl(method="cv", number=2), + tuneLength=2, preProcess = c("center", "scale")) > plotres(mod, info=TRUE) > set.seed(2020) > plotmo(mod, pt.col=2, all2=TRUE, pmethod="partdep") calculating partdep for Height calculating partdep for Volume calculating partdep for Height:Volume 01234567890 > > source("test.epilog.R") plotmo/inst/slowtests/make.README.R0000644000176200001440000000041013725307662016612 0ustar liggesusers# create README.html from README.md # the paths below assume that this file is in the plotmo/inst/slowtests directory library(rpart.plot) library(rmarkdown) rmarkdown::render("../../README.md", output_dir="../../.#") if(!interactive()) q(runLast=FALSE) plotmo/inst/slowtests/test.unusual.vars.Rout.save0000644000176200001440000023145414567065443022073 0ustar liggesusers> # test.unusual.vars.R: test unusual variable names, and unusual formulas > # > # This file was initially created for plotmo 3.6.0 (Sep 2020) > # ALso tests the naken() func introduced in plotmo 3.6.0 and earth 5.2.0 (Sep 2020) > > source("test.prolog.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix > data(ozone1) > data(etitanic) > options(warn=1) # print warnings as they occur > > check.naken <- function(s, expected, trace=0) + { + nude <- plotmo:::naken.formula.string(s, trace=trace) + printf("%-60.60s %-s\n", s, nude) + stopifnot(nude == expected) + } > printf("=== check naken.formula.string\n") === check naken.formula.string > > # edge cases > check.naken("", "") > check.naken(" ", "") > check.naken("y~", "y ~ ") y~ y ~ > check.naken("y~ ", "y ~ ") y~ y ~ > check.naken("y ~ ", "y ~ ") y ~ y ~ > check.naken("y ~ ", "y ~ ") y ~ y ~ > check.naken(" y ~ ", "y ~ ") y ~ y ~ > check.naken("[", "[", trace=2) naked formula is the same [ [ > check.naken("`", "`", trace=2) naked formula is the same ` ` > # standard formulas > check.naken("x", "x") x x > check.naken("x1", "x1") x1 x1 > check.naken("y ~ x1 : x2 + x3", "y ~ x1 + x2 + x3", trace=2) naked formula is y ~ x1 + x2 + x3 y ~ x1 : x2 + x3 y ~ x1 + x2 + x3 > check.naken("y ~ x1 + x2 - x3", "y ~ x1 + x2 + x3", trace=2) # TODO "-" is treated as a "+" naked formula is y ~ x1 + x2 + x3 y ~ x1 + x2 - x3 y ~ x1 + x2 + x3 > check.naken("y ~ .-x3", "y ~ . + x3") y ~ .-x3 y ~ . + x3 > check.naken("cbind(damage, 6-damage)~temp", "cbind(damage, 6-damage) ~ temp", trace=2) naked formula is the same cbind(damage, 6-damage)~temp cbind(damage, 6-damage) ~ temp > check.naken("depIndex~q_4 + q_2102+q_2104 +q_3105+ q_3106", "depIndex ~ q_4 + q_2102 + q_2104 + q_3105 + q_3106") depIndex~q_4 + q_2102+q_2104 +q_3105+ q_3106 depIndex ~ q_4 + q_2102 + q_2104 + q_3105 + q_3106 > check.naken("doy ~ (vh+wind+humidity)^2", "doy ~ vh + wind + humidity") doy ~ (vh+wind+humidity)^2 doy ~ vh + wind + humidity > check.naken("doy ~ s(wind) + s(humidity,wind) + s(vh)", "doy ~ wind + humidity + vh") doy ~ s(wind) + s(humidity,wind) + s(vh) doy ~ wind + humidity + vh > check.naken("log(doy) ~ I(vh*wind) + I(humidity*temp)+log(doy)", "log(doy) ~ vh + wind + humidity + temp + doy") log(doy) ~ I(vh*wind) + I(humidity*temp)+log(doy) log(doy) ~ vh + wind + humidity + temp + doy > check.naken("log(doy)~vh+wind+humidity+I(wind*humidity)+temp+log(ibh)", "log(doy) ~ vh + wind + humidity + temp + ibh", trace=2) naked formula is log(doy) ~ vh + wind + humidity + temp + ibh log(doy)~vh+wind+humidity+I(wind*humidity)+temp+log(ibh) log(doy) ~ vh + wind + humidity + temp + ibh > check.naken("O3 ~ s(humidity)+s(temp)+s(ibt)+s(temp,ibt)", "O3 ~ humidity + temp + ibt") O3 ~ s(humidity)+s(temp)+s(ibt)+s(temp,ibt) O3 ~ humidity + temp + ibt > check.naken("Ozone^(1/3) ~ lo(Solar.R) + lo(Wind, Temp)", "Ozone^(1/3) ~ Solar.R + Wind + Temp") Ozone^(1/3) ~ lo(Solar.R) + lo(Wind, Temp) Ozone^(1/3) ~ Solar.R + Wind + Temp > check.naken("Volume~(Girth*Height2)-Height", "Volume ~ Girth + Height2 + Height") Volume~(Girth*Height2)-Height Volume ~ Girth + Height2 + Height > check.naken("y ~ s(x) + s(x,z1)", "y ~ x + z1") y ~ s(x) + s(x,z1) y ~ x + z1 > check.naken("y~s(x0,x1,k=12)+s(x2)+s(x3,k=20,fx=20)", "y ~ x0 + x1 + x2 + x3") y~s(x0,x1,k=12)+s(x2)+s(x3,k=20,fx=20) y ~ x0 + x1 + x2 + x3 > check.naken("y~x[,1]+x[,2]", "y ~ x[,1] + x[,2]") y~x[,1]+x[,2] y ~ x[,1] + x[,2] > check.naken("y~x[,1]+x[,my.list$j]", "y ~ x[,1] + x[,my.list$j]") y~x[,1]+x[,my.list$j] y ~ x[,1] + x[,my.list$j] > check.naken("y~x[,i]+x[,2]", "y ~ x[,i] + x[,2]") y~x[,i]+x[,2] y ~ x[,i] + x[,2] > check.naken("Salary~Hitters[,1]", "Salary ~ Hitters[,1]", trace=2) naked formula is the same Salary~Hitters[,1] Salary ~ Hitters[,1] > check.naken("Salary~Hitters[,-1]", "Salary ~ Hitters[,-1]", trace=2) naked formula is the same Salary~Hitters[,-1] Salary ~ Hitters[,-1] > check.naken("Salary~Hitters[,c(1,2)]", "Salary ~ Hitters[,c(1,2)]", trace=2) naked formula is the same Salary~Hitters[,c(1,2)] Salary ~ Hitters[,c(1,2)] > check.naken("Salary~Hitters[,1:2]", "Salary ~ Hitters[,1:2]") Salary~Hitters[,1:2] Salary ~ Hitters[,1:2] > check.naken("Salary~Hitters[,c(1,2)]", "Salary ~ Hitters[,c(1,2)]", trace=2) naked formula is the same Salary~Hitters[,c(1,2)] Salary ~ Hitters[,c(1,2)] > # nested brackets > check.naken("y ~ x1[[2]] + x1[[3]]", "y ~ x1[[2]] + x1[[3]]") y ~ x1[[2]] + x1[[3]] y ~ x1[[2]] + x1[[3]] > check.naken("y[ , 1 ] ~ x1[[2]]", "y[ , 1 ] ~ x1[[2]]") y[ , 1 ] ~ x1[[2]] y[ , 1 ] ~ x1[[2]] > check.naken("y ~ x0[,nonesuch1 + x1[nsuch2^2 + 3 ]]", "y ~ x0[,nonesuch1 + x1[nsuch2^2 + 3 ]]") y ~ x0[,nonesuch1 + x1[nsuch2^2 + 3 ]] y ~ x0[,nonesuch1 + x1[nsuch2^2 + 3 ]] > check.naken("y ~ x0[1,x2[3]] + x4[[5]] + x6[ x7[, 8], x9[ ,x10[11] ], drop=x12[13]]", "y ~ x0[1,x2[3]] + x4[[5]] + x6[ x7[, 8], x9[ ,x10[11] ], drop=x12[13]]") y ~ x0[1,x2[3]] + x4[[5]] + x6[ x7[, 8], x9[ ,x10[11] ], dro y ~ x0[1,x2[3]] + x4[[5]] + x6[ x7[, 8], x9[ ,x10[11] ], drop=x12[13]] > # backquotes > check.naken("y ~ `a b c10` + `def`", "y ~ `a b c10` + `def`") y ~ `a b c10` + `def` y ~ `a b c10` + `def` > check.naken("`y` ~ `a b c10` + `def` + s(sqrt(`x 1`))", "`y` ~ `a b c10` + `def` + `x 1`") `y` ~ `a b c10` + `def` + s(sqrt(`x 1`)) `y` ~ `a b c10` + `def` + `x 1` > # without a response > check.naken("x1 + x[,1] + `x3`", "x1 + x[,1] + `x3`") x1 + x[,1] + `x3` x1 + x[,1] + `x3` > check.naken("Salary~Hitters[,c(1,2)]+sqrt(x)", "Salary ~ Hitters[,c(1,2)] + x") Salary~Hitters[,c(1,2)]+sqrt(x) Salary ~ Hitters[,c(1,2)] + x > check.naken("Salary~Hitters[,c(1,2)]+sqrt(x)+x99", "Salary ~ Hitters[,c(1,2)] + x + x99") Salary~Hitters[,c(1,2)]+sqrt(x)+x99 Salary ~ Hitters[,c(1,2)] + x + x99 > check.naken("Salary~x1+x2+`x6`+x3", "Salary ~ x1 + x2 + `x6` + x3") Salary~x1+x2+`x6`+x3 Salary ~ x1 + x2 + `x6` + x3 > check.naken("x[,c(1,2)] + x[,3]", "x[,c(1,2)] + x[,3]") x[,c(1,2)] + x[,3] x[,c(1,2)] + x[,3] > check.naken("x[,1] + x[,2] + x[,3] + x[,29] + x[,-14]", "x[,1] + x[,2] + x[,3] + x[,29] + x[,-14]") x[,1] + x[,2] + x[,3] + x[,29] + x[,-14] x[,1] + x[,2] + x[,3] + x[,29] + x[,-14] > check.naken("x[,c(1,2)] + x[,3] + x[,5:6] + x[,-1]", "x[,c(1,2)] + x[,3] + x[,5:6] + x[,-1]") x[,c(1,2)] + x[,3] + x[,5:6] + x[,-1] x[,c(1,2)] + x[,3] + x[,5:6] + x[,-1] > check.naken("log(y) ~ x9 + ns(x2,4) + s(x3,x4,df=4) + x5:sqrt(x6)", "log(y) ~ x9 + x2 + x3 + x4 + x5 + x6") log(y) ~ x9 + ns(x2,4) + s(x3,x4,df=4) + x5:sqrt(x6) log(y) ~ x9 + x2 + x3 + x4 + x5 + x6 > check.naken("log(y) ~ x9 + sqrt(x6) + ns(x2,4) + s(x3,x4,df=4) + x5", "log(y) ~ x9 + x6 + x2 + x3 + x4 + x5") log(y) ~ x9 + sqrt(x6) + ns(x2,4) + s(x3,x4,df=4) + x5 log(y) ~ x9 + x6 + x2 + x3 + x4 + x5 > check.naken("x[,1] + sqrt(x2) + 2.34e6 + 1", "x[,1] + x2 + 1") x[,1] + sqrt(x2) + 2.34e6 + 1 x[,1] + x2 + 1 > > printf("\n=== test problem in lm() formula with -nonesuch ===\n") === test problem in lm() formula with -nonesuch === > > # Using "-nonesuch" in a "." formula (where nonesuch is a non-existent variable name) > # causes the following error in stats::terms.formula (called via model.frame.default) > # Error in terms.formula(formula, data = data) : (converted from warning) > # 'varlist' has changed (from nvar=3) to new 4 after EncodeVars() -- should no longer happen! > options(warn=2) # treat warnings as errors > expect.err(try(lm(formula = Volume ~ . - nonesuch, data=trees)), + "'varlist' has changed (from nvar=3) to new 4 after EncodeVars() -- should no longer happen!") Error in terms.formula(formula, data = data) : (converted from warning) 'varlist' has changed (from nvar=3) to new 4 after EncodeVars() -- should no longer happen! Got expected error from try(lm(formula = Volume ~ . - nonesuch, data = trees)) > options(warn=1) # print warnings as they occur > > printf("\n=== test variables names with spaces in them ===\n") === test variables names with spaces in them === > spaced.trees <- trees > stopifnot(colnames(spaced.trees) == c("Girth", "Height", "Volume")) # sanity check > colnames(spaced.trees) <- c("Girth extra", "Height 999", "Volume") # put spaces in the names > > lm.spaced.trees <- lm(Volume~., data=spaced.trees) > options(warn=2) > expect.err(try(plotmo(lm.spaced.trees)), + "Cannot determine which variables to plot in degree2 plots") Error : (converted from warning) Cannot determine which variables to plot in degree2 plots (use all2=TRUE?) Confused by variable name "`Girth extra`" Got expected error from try(plotmo(lm.spaced.trees)) > options(warn=1) > plotmo(lm.spaced.trees) # warning, but still plots (no degree2 plots) Warning: Cannot determine which variables to plot in degree2 plots (use all2=TRUE?) Confused by variable name "`Girth extra`" plotmo grid: Girth extra Height 999 12.9 76 > plotmo(lm.spaced.trees, all2=TRUE) # no warning plotmo grid: Girth extra Height 999 12.9 76 > > earth.spaced.trees <- earth(Volume~. , data=spaced.trees, degree=2) > plotmo(earth.spaced.trees) plotmo grid: Girth extra Height 999 12.9 76 > cat("\nevimp(earth.spaced.trees)\n") evimp(earth.spaced.trees) > print(evimp(earth.spaced.trees)) nsubsets gcv rss `Girth extra` 3 100.0 100.0 `Height 999` 1 10.9 11.9 > > printf("\n=== test non standard variable names and use of earth's bx matrix ===\n") === test non standard variable names and use of earth's bx matrix === > emod <- earth(survived~., data=etitanic, degree=2) > plotmo(emod) plotmo grid: pclass sex age sibsp parch 3rd male 28 0 0 > cat("\nevimp(emod)\n") evimp(emod) > print(evimp(emod)) nsubsets gcv rss sexmale 7 100.0 100.0 pclass3rd 6 56.4 58.4 pclass2nd 5 46.3 48.4 age 4 38.0 40.2 sibsp 3 26.6 29.2 > bx <- emod$bx > bx.df <- as.data.frame(bx[,-1]) # -1 to drop intercept > bx.df$survived <- etitanic$survived > # following gsub make it a bit easier to see what's going on > # because the next call to earth also creates hinge functions > # (so we end up with nested hinge functions) > colnames(bx.df) <- gsub("h(", "H(", colnames(bx.df), fixed=TRUE) > lm.bx <- lm(survived ~ ., data=bx.df) > set.seed(2020) > earth.bx <- earth(survived ~ ., data=bx.df, degree=2) > printf("\nsummary(earth.bx):\n") summary(earth.bx): > print(summary(earth.bx)) Call: earth(formula=survived~., data=bx.df, degree=2) coefficients (Intercept) 2.05782826 sexmale -0.60749103 pclass3rd -1.27902837 pclass2nd * sexmale -0.23995151 pclass3rd * sexmale 0.25312923 h(4-sexmale * H(16-age)) -0.20886491 h(2-pclass3rd * H(4-sibsp)) -0.14508261 pclass3rd * h(5-sexmale * H(16-age)) 0.09290713 h(pclass3rd * H(4-sibsp)-2) * h(1-H(age-32)) 0.07452385 Selected 9 of 17 terms, and 7 of 7 predictors Termination condition: Reached nk 21 Importance: sexmale, pclass3rd, `sexmale*H(16-age)`, `pclass2nd*sexmale`, ... Number of terms at each degree of interaction: 1 6 2 GCV 0.1385367 RSS 139.1493 GRSq 0.4276272 RSq 0.4493265 > printf("\nevimp(earth.bx):\n") evimp(earth.bx): > print(evimp(earth.bx)) nsubsets gcv rss sexmale 8 100.0 100.0 pclass3rd 7 57.5 59.7 `sexmale*H(16-age)` 5 39.5 42.0 `pclass2nd*sexmale` 5 39.5 42.0 `pclass3rd*sexmale` 4 35.7 38.0 `pclass3rd*H(4-sibsp)` 4 30.5 33.3 `H(age-32)` 3 24.9 27.6 > plot(earth.bx, info=TRUE) > plotmo(lm.bx) # Warning: Cannot determine which variables to plot in degree2 plots Warning: Cannot determine which variables to plot in degree2 plots (use all2=TRUE?) Confused by variable name "`sexmale*H(16-age)`" plotmo grid: sexmale pclass3rd sexmale*H(16-age) pclass2nd*sexmale 1 0 0 0 pclass3rd*H(4-sibsp) pclass3rd*sexmale H(age-32) 0 0 0 > plotmo(lm.bx, all2=TRUE, SHOWCALL=TRUE) plotmo grid: sexmale pclass3rd sexmale*H(16-age) pclass2nd*sexmale 1 0 0 0 pclass3rd*H(4-sibsp) pclass3rd*sexmale H(age-32) 0 0 0 > plotmo(earth.bx, pmethod="partdep", trace=2) plotmo trace 2: plotmo(object=earth.bx, pmethod="partdep", trace=2) --get.model.env for object with class earth object call is earth(formula=survived~., data=bx.df, degree=2) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.bx' --plotmo_x for earth object get.object.x: object$x is NULL (and it has no colnames) object call is earth(formula=survived~., data=bx.df, degree=2) get.x.from.model.frame: formula(object) is survived ~ sexmale + pclass3rd + `sexmale*H(16-age)` + `p... naked formula is the same formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) object$data is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names sexmale pclass3rd sexmale*H(16-age) pclass2nd*sexmale pclass3rd*H(4-sibsp) pclass3rd*sexmale H(ag... na.action(object) is "na.fail" stats::model.frame(survived ~ sexmale + pclass3rd + `sex..., data=call$data, na.action="na.fail") x=model.frame[,-1] is usable and has column names sexmale pclass3rd sexmale*H(16-age) pclass2nd*sexmale pclass3rd*H(4-sibsp) pclass3rd*sexmale H(ag... setting check.naked=FALSE because backtick in formula plotmo_x returned[1046,7]: sexmale pclass3rd sexmale*H(16-age) pclass2nd*sexmale pclass3rd*H(4-sibsp) 1 0 0 0.0000 0 0 2 1 0 15.0833 0 0 3 0 0 0.0000 0 0 ... 1 0 0.0000 0 0 1046 1 1 0.0000 0 4 pclass3rd*sexmale H(age-32) 1 0 0 2 0 0 3 0 0 ... 0 0 1046 1 0 ----Metadata: plotmo_predict with nresponse=NULL and newdata=NULL calling predict.earth with NULL newdata stats::predict(earth.object, NULL, type="response") predict returned[1046,1]: survived 1 0.9322034 2 1.1601720 3 0.9322034 ... 0.3247124 1046 0.2025618 predict after processing with nresponse=NULL is [1046,1]: survived 1 0.9322034 2 1.1601720 3 0.9322034 ... 0.3247124 1046 0.2025618 ----Metadata: plotmo_fitted with nresponse=NULL stats::fitted(object=earth.object) fitted(object) returned[1046,1]: survived 1 0.9322034 2 1.1601720 3 0.9322034 ... 0.3247124 1046 0.2025618 fitted(object) after processing with nresponse=NULL is [1046,1]: survived 1 0.9322034 2 1.1601720 3 0.9322034 ... 0.3247124 1046 0.2025618 ----Metadata: plotmo_y with nresponse=NULL --plotmo_y with nresponse=NULL for earth object get.object.y: object$y is NULL (and it has no colnames) object call is earth(formula=survived~., data=bx.df, degree=2) get.y.from.model.frame: formula(object) is survived ~ sexmale + pclass3rd + `sexmale*H(16-age)` + `p... formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) object$data is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names sexmale pclass3rd sexmale*H(16-age) pclass2nd*sexmale pclass3rd*H(4-sibsp) pclass3rd*sexmale H(ag... na.action(object) is "na.fail" stats::model.frame(survived ~ sexmale + pclass3rd + `sex..., data=call$data, na.action="na.fail") y=model.frame[,1] is usable and has column name survived plotmo_y returned[1046,1]: survived 1 1 2 1 3 0 ... 0 1046 0 plotmo_y after processing with nresponse=NULL is [1046,1]: survived 1 1 2 1 3 0 ... 0 1046 0 converted nresponse=NA to nresponse=1 nresponse=1 (was NA) ncol(fitted) 1 ncol(predict) 1 ncol(y) 1 ----Metadata: plotmo_y with nresponse=1 --plotmo_y with nresponse=1 for earth object get.object.y: object$y is NULL (and it has no colnames) object call is earth(formula=survived~., data=bx.df, degree=2) get.y.from.model.frame: formula(object) is survived ~ sexmale + pclass3rd + `sexmale*H(16-age)` + `p... formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) object$data is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names sexmale pclass3rd sexmale*H(16-age) pclass2nd*sexmale pclass3rd*H(4-sibsp) pclass3rd*sexmale H(ag... na.action(object) is "na.fail" stats::model.frame(survived ~ sexmale + pclass3rd + `sex..., data=call$data, na.action="na.fail") y=model.frame[,1] is usable and has column name survived got model response from model.frame(survived ~ sexmale + pclass3rd + `sex..., data=call$data, na.action="na.fail") plotmo_y returned[1046,1]: survived 1 1 2 1 3 0 ... 0 1046 0 plotmo_y after processing with nresponse=1 is [1046,1]: survived 1 1 2 1 3 0 ... 0 1046 0 got response name "survived" from yhat got resp.levs from object$levels response levels: 0 1 ----Metadata: done number of x values: sexmale 2 pclass3rd 2 sexmale*H(16-age) 24 pclass2nd*sexm... ----plotmo_singles for earth object singles: 1 sexmale, 2 pclass3rd, 3 sexmale*H(16-age), 4 pclass2nd*sexmale, 5 pclass3rd*H(4-sibsp), 6 pclass3rd*sexmale ----plotmo_pairs for earth object pairs: [,1] [,2] [1,] "2 pclass3rd" "3 sexmale*H(16-age)" [2,] "5 pclass3rd*H(4-sibsp)" "7 H(age-32)" graphics::par(mfrow=c(3,3), mgp=c(1.5,0.4,0), tcl=-0.3, font.main=2, mar=c(3,2,1.2,0.8), oma=c(0,0,3,0), cex.main=1.2, cex.lab=1, cex.axis=1, cex=0.66) ----Figuring out ylim --get.ylim.by.dummy.plots --plot.degree1(draw.plot=FALSE) degree1 plot1 (pmethod "partdep") variable sexmale calculating partdep for sexmale newdata[2092,7]: sexmale pclass3rd sexmale*H(16-age) pclass2nd*sexmale 1 0 0 0.0000 0 2 0 0 15.0833 0 3 0 0 0.0000 0 ... 0 0 0.0000 0 1046.1 1 1 0.0000 0 pclass3rd*H(4-sibsp) pclass3rd*sexmale H(age-32) 1 0 0 0 2 0 0 0 3 0 0 0 ... 0 0 0 1046.1 4 1 0 stats::predict(earth.object, data.frame[2092,7], type="response") predict returned[2092,1]: survived 1 0.9322034 2 1.7676630 3 0.9322034 ... 0.9322034 2092 0.2025618 predict after processing with nresponse=1 is [2092,1]: survived 1 0.9322034 2 1.7676630 3 0.9322034 ... 0.9322034 2092 0.2025618 Reducing trace level for subsequent degree1 plots degree1 plot2 (pmethod "partdep") variable pclass3rd calculating partdep for pclass3rd degree1 plot3 (pmethod "partdep") variable sexmale*H(16-age) calculating partdep for sexmale*H(16-age) degree1 plot4 (pmethod "partdep") variable pclass2nd*sexmale calculating partdep for pclass2nd*sexmale degree1 plot5 (pmethod "partdep") variable pclass3rd*H(4-sibsp) calculating partdep for pclass3rd*H(4-sibsp) degree1 plot6 (pmethod "partdep") variable pclass3rd*sexmale calculating partdep for pclass3rd*sexmale --plot.degree2(draw.plot=FALSE) degree2 plot1 (pmethod "partdep") variables pclass3rd:sexmale*H(16-age) calculating partdep for pclass3rd:sexmale*H(16-age) 1234newdata[20920,7]: sexmale pclass3rd sexmale*H(16-age) pclass2nd*sexmale 1 0 0 0.0000 0 2 1 0 0.0000 0 3 0 0 0.0000 0 ... 1 0 0.0000 0 1046.19 1 0 15.6667 0 pclass3rd*H(4-sibsp) pclass3rd*sexmale H(age-32) 1 0 0 0 2 0 0 0 3 0 0 0 ... 0 0 0 1046.19 4 1 0 stats::predict(earth.object, data.frame[20920,7], type="response") predict returned[20920,1]: survived 1 0.9322034 2 0.3247124 3 0.9322034 ... 0.3247124 20920 1.8525142 predict after processing with nresponse=1 is [20920,1]: survived 1 0.9322034 2 0.3247124 3 0.9322034 ... 0.3247124 20920 1.8525142 56790 Reducing trace level for subsequent degree2 plots degree2 plot2 (pmethod "partdep") variables pclass3rd*H(4-sibsp):H(age-32) calculating partdep for pclass3rd*H(4-sibsp):H(age-32) 1newdata[20920,7]: sexmale pclass3rd sexmale*H(16-age) pclass2nd*sexmale 1 0 0 0.0000 0 2 1 0 15.0833 0 3 0 0 0.0000 0 ... 1 0 0.0000 0 1046.19 1 1 0.0000 0 pclass3rd*H(4-sibsp) pclass3rd*sexmale H(age-32) 1 0 0 0 2 0 0 0 3 0 0 0 ... 0 0 0 1046.19 0 1 48 stats::predict(earth.object, data.frame[20920,7], type="response") predict returned[20920,1]: survived 1 0.9322034 2 1.1601720 3 0.9322034 ... 0.3247124 20920 -0.2366511 predict after processing with nresponse=1 is [20920,1]: survived 1 0.9322034 2 1.1601720 3 0.9322034 ... 0.3247124 20920 -0.2366511 234567890 --done get.ylim.by.dummy.plots ylim c(-0.04329, 1.607) clip TRUE --plot.degree1(draw.plot=TRUE) graphics::plot.default(x=c(0,0.5,0.5,1), y=c(0.7904,0.7904...), type="n", main="1 sexmale", xlab="", ylab="", xaxt="s", yaxt="s", xlim=c(-0.1,1.1), ylim=c(-0.0433,1.607)) --plot.degree2(draw.plot=TRUE) persp(pclass3rd:sexmale*H(16-age)) theta 55 persp(pclass3rd*H(4-sibsp):H(age-32)) theta 235 > > printf("\n=== put spaces into the column names of bx (for both response and predictors) ===\n") === put spaces into the column names of bx (for both response and predictors) === > spaced.bx <- bx.df > colnames(spaced.bx) <- gsub("-", " - ", colnames(spaced.bx), fixed=TRUE) > colnames(spaced.bx)[colnames(spaced.bx) == "survived"] <- "Survived = YES" > printf("\nhead(spaced.bx):\n") head(spaced.bx): > print(head(spaced.bx)) sexmale pclass3rd sexmale*H(16 - age) pclass2nd*sexmale 1 0 0 0.0000 0 2 1 0 15.0833 0 3 0 0 0.0000 0 4 1 0 0.0000 0 5 0 0 0.0000 0 6 1 0 0.0000 0 pclass3rd*H(4 - sibsp) pclass3rd*sexmale H(age - 32) Survived = YES 1 0 0 0 1 2 0 0 0 1 3 0 0 0 0 4 0 0 0 0 5 0 0 0 0 6 0 0 16 1 > > lm.spaced.bx <- lm(`Survived = YES` ~ ., data=spaced.bx) > > set.seed(2020) > earth.spaced.bx <- earth(`Survived = YES` ~ ., data=spaced.bx, degree=2, trace=.5, + nfold=4, ncross=3, varmod.method="lm", pmethod="cv") Preliminary model with pmethod="backward": GRSq 0.428 RSq 0.449 nterms 9 CV fold 1.1 CVRSq 0.402 n.oof 779 26% n.infold.nz 320 41% n.oof.nz 107 40% CV fold 1.2 CVRSq 0.424 n.oof 785 25% n.infold.nz 320 41% n.oof.nz 107 41% CV fold 1.3 CVRSq 0.418 n.oof 786 25% n.infold.nz 320 41% n.oof.nz 107 41% CV fold 1.4 CVRSq 0.433 n.oof 788 25% n.infold.nz 321 41% n.oof.nz 106 41% CV fold 2.1 CVRSq 0.470 n.oof 784 25% n.infold.nz 320 41% n.oof.nz 107 41% CV fold 2.2 CVRSq 0.417 n.oof 775 26% n.infold.nz 320 41% n.oof.nz 107 39% CV fold 2.3 CVRSq 0.412 n.oof 787 25% n.infold.nz 320 41% n.oof.nz 107 41% CV fold 2.4 CVRSq 0.421 n.oof 792 24% n.infold.nz 321 41% n.oof.nz 106 42% CV fold 3.1 CVRSq 0.385 n.oof 777 26% n.infold.nz 320 41% n.oof.nz 107 40% CV fold 3.2 CVRSq 0.429 n.oof 792 24% n.infold.nz 320 40% n.oof.nz 107 42% CV fold 3.3 CVRSq 0.461 n.oof 780 25% n.infold.nz 320 41% n.oof.nz 107 40% CV fold 3.4 CVRSq 0.377 n.oof 789 25% n.infold.nz 321 41% n.oof.nz 106 41% CV all CVRSq 0.421 n.infold.nz 427 41% Final model with pmethod="cv": GRSq 0.425 RSq 0.452 nterms selected by cv 11 varmod method="lm" rmethod="hc12" lambda=1 exponent=1 conv=1 clamp=0.1 minspan=-3: iter weight.ratio coefchange% (Intercept) `Survived = YES` 1 2.2 0.00 0.31 -0.074 2 3.7 36.00 0.33 -0.122 3 5.3 14.02 0.34 -0.151 4 6.5 6.60 0.35 -0.168 5 7.3 3.21 0.35 -0.176 6 7.8 1.57 0.36 -0.181 7 8.0 0.76 0.36 -0.183 > printf("\nsummary(earth.spaced.bx):\n") summary(earth.spaced.bx): > print(summary(earth.spaced.bx)) Call: earth(formula=`Survived=YES`~., data=spaced.bx, pmethod="cv", trace=0.5, degree=2, nfold=4, ncross=3, varmod.method="lm") coefficients (Intercept) 2.01771627 sexmale -0.56066394 pclass3rd -1.25089642 pclass2nd * sexmale -0.26729133 pclass3rd * sexmale 0.20879448 h(4-sexmale * H(16 - age)) -0.20186359 h(2-pclass3rd * H(4 - sibsp)) -0.13902926 sexmale * h(H(age - 32)-6) -0.00607253 pclass3rd * h(5-sexmale * H(16 - age)) 0.08709723 h(pclass3rd * H(4 - sibsp)-2) * h(H(age - 32)-1) 0.00242931 h(pclass3rd * H(4 - sibsp)-2) * h(1-H(age - 32)) 0.08048994 Selected 11 of 17 terms, and 7 of 7 predictors (pmethod="cv") Termination condition: Reached nk 21 Importance: sexmale, pclass3rd, `sexmale*H(16 - age)`, `pclass2nd*sexmale`, ... Number of terms at each degree of interaction: 1 6 4 GRSq 0.4251614 RSq 0.4523366 mean.oof.RSq 0.4245627 (sd 0.0258) pmethod="backward" would have selected: 9 terms 7 preds, GRSq 0.4276272 RSq 0.4493265 mean.oof.RSq 0.4224044 varmod: method "lm" min.sd 0.0354 iter.rsq 0.070 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) 0.4476988 0.0176523 4 Survived = YES -0.2293581 0.0258681 11 mean smallest largest ratio 95% prediction interval 1.387928 0.6949522 1.966296 2.829398 68% 80% 90% 95% response values in prediction interval 69 75< 84< 93< > printf("\nevimp(earth.spaced.bx):\n") evimp(earth.spaced.bx): > print(evimp(earth.spaced.bx)) nsubsets gcv rss sexmale 10 100.0 100.0 pclass3rd 9 57.2 60.0 `sexmale*H(16 - age)` 7 38.8 42.6 `pclass2nd*sexmale` 7 38.8 42.6 `pclass3rd*sexmale` 6 35.0 38.7 `pclass3rd*H(4 - sibsp)` 6 29.7 34.2 `H(age - 32)` 5 23.8 28.7 > > set.seed(2020) > earth.glm.spaced.bx <- earth(`Survived = YES` ~ ., data=spaced.bx, degree=2, trace=.5, + glm=list(family="binomial"), + nfold=4, ncross=3, varmod.method="lm", pmethod="cv") Preliminary model with pmethod="backward": GRSq 0.428 RSq 0.449 nterms 9 CV fold 1.1 CVRSq 0.402 n.oof 779 26% n.infold.nz 320 41% n.oof.nz 107 40% CV fold 1.2 CVRSq 0.424 n.oof 785 25% n.infold.nz 320 41% n.oof.nz 107 41% CV fold 1.3 CVRSq 0.418 n.oof 786 25% n.infold.nz 320 41% n.oof.nz 107 41% CV fold 1.4 CVRSq 0.433 n.oof 788 25% n.infold.nz 321 41% n.oof.nz 106 41% CV fold 2.1 CVRSq 0.470 n.oof 784 25% n.infold.nz 320 41% n.oof.nz 107 41% CV fold 2.2 CVRSq 0.417 n.oof 775 26% n.infold.nz 320 41% n.oof.nz 107 39% CV fold 2.3 CVRSq 0.412 n.oof 787 25% n.infold.nz 320 41% n.oof.nz 107 41% CV fold 2.4 CVRSq 0.421 n.oof 792 24% n.infold.nz 321 41% n.oof.nz 106 42% CV fold 3.1 CVRSq 0.385 n.oof 777 26% n.infold.nz 320 41% n.oof.nz 107 40% CV fold 3.2 CVRSq 0.429 n.oof 792 24% n.infold.nz 320 40% n.oof.nz 107 42% CV fold 3.3 CVRSq 0.461 n.oof 780 25% n.infold.nz 320 41% n.oof.nz 107 40% CV fold 3.4 CVRSq 0.377 n.oof 789 25% n.infold.nz 321 41% n.oof.nz 106 41% CV all CVRSq 0.421 n.infold.nz 427 41% Final model with pmethod="cv": GRSq 0.425 RSq 0.452 nterms selected by cv 11 varmod method="lm" rmethod="hc12" lambda=1 exponent=1 conv=1 clamp=0.1 minspan=-3: iter weight.ratio coefchange% (Intercept) `Survived = YES` 1 2.2 0.00 0.31 -0.074 2 3.7 36.00 0.33 -0.122 3 5.3 14.02 0.34 -0.151 4 6.5 6.60 0.35 -0.168 5 7.3 3.21 0.35 -0.176 6 7.8 1.57 0.36 -0.181 7 8.0 0.76 0.36 -0.183 > printf("\nsummary(earth.glm.spaced.bx):\n") summary(earth.glm.spaced.bx): > print(summary(earth.glm.spaced.bx)) Call: earth(formula=`Survived=YES`~., data=spaced.bx, pmethod="cv", trace=0.5, glm=list(family="binomial"), degree=2, nfold=4, ncross=3, varmod.method="lm") GLM coefficients `Survived = YES` (Intercept) 9.8189944 sexmale -3.0197582 pclass3rd -8.5391964 pclass2nd * sexmale -1.9328478 pclass3rd * sexmale 1.2008915 h(4-sexmale * H(16 - age)) -1.4278190 h(2-pclass3rd * H(4 - sibsp)) -0.7433398 sexmale * h(H(age - 32)-6) -0.0441700 pclass3rd * h(5-sexmale * H(16 - age)) 0.7564144 h(pclass3rd * H(4 - sibsp)-2) * h(H(age - 32)-1) 0.0091406 h(pclass3rd * H(4 - sibsp)-2) * h(1-H(age - 32)) 0.5068265 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 1414.62 1045 873.999 1035 0.382 896 6 1 Earth selected 11 of 17 terms, and 7 of 7 predictors (pmethod="cv") Termination condition: Reached nk 21 Importance: sexmale, pclass3rd, `sexmale*H(16 - age)`, `pclass2nd*sexmale`, ... Number of terms at each degree of interaction: 1 6 4 Earth GRSq 0.4251614 RSq 0.4523366 mean.oof.RSq 0.4245627 (sd 0.0258) pmethod="backward" would have selected: 9 terms 7 preds, GRSq 0.4276272 RSq 0.4493265 mean.oof.RSq 0.4224044 varmod: method "lm" min.sd 0.0354 iter.rsq 0.070 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) 0.4476988 0.0176523 4 Survived = YES -0.2293581 0.0258681 11 mean smallest largest ratio 95% prediction interval 1.387928 0.6949522 1.966296 2.829398 68% 80% 90% 95% response values in prediction interval 69 75< 84< 93< > printf("\nevimp(earth.glm.spaced.bx):\n") evimp(earth.glm.spaced.bx): > print(evimp(earth.glm.spaced.bx)) nsubsets gcv rss sexmale 10 100.0 100.0 pclass3rd 9 57.2 60.0 `sexmale*H(16 - age)` 7 38.8 42.6 `pclass2nd*sexmale` 7 38.8 42.6 `pclass3rd*sexmale` 6 35.0 38.7 `pclass3rd*H(4 - sibsp)` 6 29.7 34.2 `H(age - 32)` 5 23.8 28.7 > > options(warn=2) > expect.err(try(plotmo(lm.spaced.bx)), + "Cannot determine which variables to plot in degree2 plots") Error : (converted from warning) Cannot determine which variables to plot in degree2 plots (use all2=TRUE?) Confused by variable name "`sexmale*H(16 - age)`" Got expected error from try(plotmo(lm.spaced.bx)) > options(warn=1) > > plotmo(lm.spaced.bx, do.par=2, SHOWCALL=TRUE) Warning: Cannot determine which variables to plot in degree2 plots (use all2=TRUE?) Confused by variable name "`sexmale*H(16 - age)`" plotmo grid: sexmale pclass3rd sexmale*H(16 - age) pclass2nd*sexmale 1 0 0 0 pclass3rd*H(4 - sibsp) pclass3rd*sexmale H(age - 32) 0 0 0 > plotres(lm.spaced.bx, do.par=0, which=c(1, 3)) > par(org.par) > > plotmo(earth.spaced.bx, degree1="sexmale", do.par=2, level=.8, SHOWCALL=TRUE) plotmo grid: sexmale pclass3rd sexmale*H(16 - age) pclass2nd*sexmale 1 0 0 0 pclass3rd*H(4 - sibsp) pclass3rd*sexmale H(age - 32) 0 0 0 > plot(earth.spaced.bx, do.par=0, which=c(1, 3), info=TRUE, level=.8, type="earth") > par(org.par) > > plot(earth.spaced.bx, versus="b:", info=TRUE, level=.8, type="earth", SHOWCALL=TRUE) > > # following should be the same as previous page (since type="earth") > plotmo(earth.glm.spaced.bx, degree1="sexmale", do.par=2, level=.8, type="earth", SHOWCALL=TRUE) plotmo grid: sexmale pclass3rd sexmale*H(16 - age) pclass2nd*sexmale 1 0 0 0 pclass3rd*H(4 - sibsp) pclass3rd*sexmale H(age - 32) 0 0 0 > plot(earth.glm.spaced.bx, do.par=0, which=1, info=TRUE, level=.8, type="earth") > # $$ TODO Following shouldn't cause Warning: Internal inconsistency: p$fit - fitted != 0 > # No warning if don't use glm=list(family="binomial") in call to earth > options(warn=2) > expect.err(try(plot(earth.glm.spaced.bx, do.par=0, which=3, info=TRUE, level=.8, type="earth")), + "Internal inconsistency: p$fit != fitted") Error : (converted from warning) Internal inconsistency: p$fit != fitted Workaround: no 'glm' arg in call to earth, or no 'level' arg n call to plotres Got expected error from try(plot(earth.glm.spaced.bx, do.par = 0, which = 3, info = TRUE, level = 0.8, type = "earth")) > options(warn=1) > plot(earth.glm.spaced.bx, do.par=0, which=3, info=TRUE, level=.8, type="earth") Warning: Internal inconsistency: p$fit != fitted Workaround: no 'glm' arg in call to earth, or no 'level' arg n call to plotres > par(org.par) > > expect.err(try(plotmo(earth.glm.spaced.bx, level=.8)), + "predict.earth: with earth-glm models, use type=\"earth\" when using the interval argument") plotmo grid: sexmale pclass3rd sexmale*H(16 - age) pclass2nd*sexmale 1 0 0 0 pclass3rd*H(4 - sibsp) pclass3rd*sexmale H(age - 32) 0 0 0 Error : predict.earth: with earth-glm models, use type="earth" when using the interval argument Got expected error from try(plotmo(earth.glm.spaced.bx, level = 0.8)) > > plotmo(earth.glm.spaced.bx, degree1="sexmale", do.par=2, SHOWCALL=TRUE) plotmo grid: sexmale pclass3rd sexmale*H(16 - age) pclass2nd*sexmale 1 0 0 0 pclass3rd*H(4 - sibsp) pclass3rd*sexmale H(age - 32) 0 0 0 > plot(earth.glm.spaced.bx, do.par=0, which=c(1, 3), info=TRUE) > par(org.par) > > printf("\n=== test combinations of variables in formula ===\n") === test combinations of variables in formula === > > vdata <- data.frame( + resp = 1:13, + bool = c(F, F, F, F, F, T, T, T, T, T, T, T, T), + ord = ordered(c("ORD1", "ORD1", "ORD1", + "ORD1", "ORD1", "ORD1", + "ORD3", "ORD3", "ORD3", + "ORD2", "ORD2", "ORD2", "ORD2"), + levels=c("ORD1", "ORD3", "ORD2")), + fac = as.factor(c("FAC1", "FAC1", "FAC1", + "FAC2", "FAC2", "FAC2", + "FAC3", "FAC3", "FAC3", + "FAC1", "FAC2", "FAC3", "FAC3")), + str = c("STR1", "STR1", "STR1", # WILL BE TREATED LIKE A FACTOR + "STR2", "STR2", "STR2", + "STR3", "STR3", "STR3", + "STR3", "STR3", "STR3", "STR3"), + num = c(1, 3, 2, 3, 4, 5, 6, 4, 5, 6.5, 3, 6, 5), # 7 unique values (but one is non integral) + sqrt_num = sqrt(c(1, 3, 2, 3, 4, 5, 6, 4, 5, 6.5, 3, 6, 5)), + int = c(1L, 1L, 3L, 3L, 4L, 4L, 3L, 5L, 3L, 6L, 7L, 8L, 10L), # 8 unique values + date = as.Date( + c("2018-08-01", "2018-08-02", "2018-08-03", + "2018-08-04", "2018-08-05", "2018-08-06", + "2018-08-07", "2018-08-08", "2018-08-08", + "2018-08-08", "2018-08-10", "2018-08-11", "2018-08-11")), + date_num = as.numeric(as.Date( + c("2018-08-01", "2018-08-02", "2018-08-03", + "2018-08-04", "2018-08-05", "2018-08-06", + "2018-08-07", "2018-08-08", "2018-08-08", + "2018-08-08", "2018-08-10", "2018-08-11", "2018-08-11")))) > > vdata$off <- (1:nrow(vdata)) / nrow(vdata) > > resp2 <- 13:1 > > vweights <- rep(1, length.out=nrow(vdata)) > vweights[1] <- 2 > > set.seed(2020) > lognum.bool.ord.off <- earth(resp ~ log(num) + bool + ord + offset(off), degree=2, weights=vweights, + data=vdata, pmethod="none", varmod.method="lm", + nfold=2, ncross=3, + trace=1) x[13,4] with colnames log(num) boolTRUE ord.L ord.Q y[13,1] with colname resp, and values 0.9231, 1.846, 2.769, 3.692, ... weights[13]: 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 Forward pass term 1, 2, 4, 6, 8 GRSq -Inf at 7 terms, 5 terms used After forward pass GRSq -in RSq 0.966 Prune none penalty 3 nprune null: selected 5 of 5 terms, and 3 of 4 preds After pruning pass GRSq -0.732 RSq 0.952 CV fold 1.1 CVRSq -0.476 n.oof 6 54% n.infold.nz 6 100% n.oof.nz 7 100% CV fold 1.2 CVRSq 0.823 n.oof 7 46% n.infold.nz 7 100% n.oof.nz 6 100% CV fold 2.1 CVRSq -0.622 n.oof 6 54% n.infold.nz 6 100% n.oof.nz 7 100% CV fold 2.2 CVRSq 0.816 n.oof 7 46% n.infold.nz 7 100% n.oof.nz 6 100% CV fold 3.1 CVRSq 0.559 n.oof 6 54% n.infold.nz 6 100% n.oof.nz 7 100% CV fold 3.2 CVRSq 0.698 n.oof 7 46% n.infold.nz 7 100% n.oof.nz 6 100% CV all CVRSq 0.300 n.infold.nz 13 100% varmod method="lm" rmethod="hc12" lambda=1 exponent=1 conv=1 clamp=0.1 minspan=-3: iter weight.ratio coefchange% (Intercept) resp 1 1.6 0.00 1.76 0.045 2 2.2 39.64 1.55 0.076 3 2.9 19.19 1.40 0.098 4 3.5 12.21 1.29 0.115 5 4.1 8.66 1.21 0.127 6 4.6 6.50 1.15 0.137 7 5.0 5.05 1.10 0.145 8 5.5 4.02 1.06 0.152 9 5.8 3.25 1.03 0.157 10 6.1 2.66 1.00 0.162 11 6.4 2.19 0.98 0.165 12 6.7 1.82 0.97 0.168 13 6.9 1.52 0.95 0.171 14 7.1 1.28 0.94 0.173 15 7.3 1.08 0.93 0.175 16 7.4 0.91 0.92 0.176 > > printf("summary(lognum.bool.ord.off)\n") summary(lognum.bool.ord.off) > print(summary(lognum.bool.ord.off)) Call: earth(formula=resp~log(num)+bool+ord+offset(off), data=vdata, weights=vweights, pmethod="none", trace=1, degree=2, nfold=2, ncross=3, varmod.method="lm") coefficients (Intercept) 6.273213 boolTRUE 1.111403 h(-7.85046e-17-ord.L) -7.600147 h(ord.L- -7.85046e-17) 4.568998 log(num) * h(-7.85046e-17-ord.L) 3.100021 Selected 5 of 5 terms, and 3 of 4 predictors (pmethod="none") Termination condition: GRSq -Inf at 5 terms Importance: ord.L, log(num), boolTRUE, ord.Q-unused Offset: off with values 0.07692308, 0.1538462, 0.2307692, 0.3076923, 0.3... Weights: 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 Number of terms at each degree of interaction: 1 3 1 GCV 28.70012 RSS 8.830806 GRSq -0.7319038 RSq 0.9518916 CVRSq 0.2995745 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 2.33 sd 0.52 nvars 1.00 sd 0.00 CVRSq sd MaxErr sd 0.3 0.666 -6 3.53 varmod: method "lm" min.sd 0.27 iter.rsq 0.204 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) 1.151190 0.759983 66 resp 0.220811 0.131375 59 mean smallest largest ratio 95% prediction interval 10.57312 5.357389 14.56643 2.718942 68% 80% 90% 95% response values in prediction interval 100 100 100 100 > cat("\nevimp(lognum.bool.ord.off)\n") evimp(lognum.bool.ord.off) > print(evimp(lognum.bool.ord.off)) nsubsets gcv rss ord.L 4 -73.4 100.0 log(num) 2 -98.7 30.8 boolTRUE 1 -100.0 6.6 > > plotmo(lognum.bool.ord.off, do.par=2, level=.8, SHOWCALL=TRUE) Note: the offset in the formula is not plotted (use all1=TRUE to plot the offset, or use trace=-1 to silence this message) plotmo grid: num bool ord off 4 TRUE ORD1 0.5384615 > plot(lognum.bool.ord.off, which=1, do.par=0) > par(org.par) > > num.fac.sqrt.num.ord.bool <- earth(resp ~ num + int + fac + offset(off) + sqrt(num) + ord:bool - int, + data=vdata, pmethod="none", trace=1) x[13,10] with colnames num facFAC2 facFAC3 sqrt(num) ordORD1:boolFALSE ordORD3:b... y[13,1] with colname resp, and values 0.9231, 1.846, 2.769, 3.692, ... Forward pass term 1, 2, 4, 6, 8, 10 GRSq -Inf at 9 terms, 6 terms used After forward pass GRSq -in RSq 0.979 Prune none penalty 2 nprune null: selected 6 of 6 terms, and 4 of 10 preds After pruning pass GRSq 0.045 RSq 0.973 > plotmo(num.fac.sqrt.num.ord.bool, SHOWCALL=TRUE) Note: the offset in the formula is not plotted (use all1=TRUE to plot the offset, or use trace=-1 to silence this message) plotmo grid: num int fac off ord bool 4 4 FAC3 0.5384615 ORD1 TRUE > cat("\nevimp(num.fac.sqrt.num.ord.bool)\n") evimp(num.fac.sqrt.num.ord.bool) > print(evimp(num.fac.sqrt.num.ord.bool)) nsubsets gcv rss ordORD1:boolFALSE 4 25.3 100.0 ordORD2:boolTRUE 4 -87.6 52.9 num 3 -100.0 30.0 facFAC3 3 -100.0 30.0 > > printf("\n=== unusual formulas, compare to lm ===\n") === unusual formulas, compare to lm === > > lm1 <- lm(resp~ord+sqrt(as.numeric(fac)) + num+sqrt(num / 2)+I(2 * int)+date, data = vdata) > > # same formula terms as lm1 but in different order > earth1 <- earth(resp~sqrt(as.numeric(fac)) + ord + date + num + sqrt(.5 * num)+I(int / .5), + data = vdata, linpreds=TRUE, thresh=0, penalty=-1) > cat("\nevimp(earth1)\n") evimp(earth1) > print(evimp(earth1)) nsubsets gcv rss date 7 100.0 100.0 sqrt(as.numeric(fac)) 5 10.8 10.8 ord.L 5 5.3 5.3 num 4 3.6 3.6 I(int/0.5) 4 3.6 3.6 ord.Q 2 0.0 0.0 sqrt(0.5 * num) 1 0.0 0.0 > plotmo(lm1, SHOWCALL=TRUE) plotmo grid: ord fac num int date ORD1 FAC3 4 4 2018-08-07 > plotmo(earth1, SHOWCALL=TRUE) plotmo grid: fac ord date num int FAC3 ORD1 2018-08-07 4 4 > stopifnot(max(abs(sort(lm1$coef) - sort(earth1$coef))) < 1e-10) > stopifnot((summary(lm1)$r.squared - earth1$rsq) < 1e-10) > stopifnot(max(abs(predict(lm1, newdata=vdata[5,,drop=FALSE]) - predict(earth1, newdata=vdata[5,,drop=FALSE]))) < 1e-10) > > fac.sqrt <- earth(resp~sqrt(num)+fac, data = vdata, linpreds=TRUE, thresh=0, penalty=-1) > fac.sqrt_ <- earth(resp~sqrt_num+fac, data = vdata, linpreds=TRUE, thresh=0, penalty=-1) > cat("\nevimp(fac.sqrt)\n") evimp(fac.sqrt) > print(evimp(fac.sqrt)) nsubsets gcv rss sqrt(num) 3 100.0 100.0 facFAC3 2 37.4 37.4 facFAC2 1 18.4 18.4 > cat("\nevimp(fac.sqrt_)\n") evimp(fac.sqrt_) > print(evimp(fac.sqrt_)) nsubsets gcv rss sqrt_num 3 100.0 100.0 facFAC3 2 37.4 37.4 facFAC2 1 18.4 18.4 > # as.vector to remove names (which are slightly different: sqrt(num) vs sqrt_num > stopifnot(identical(as.vector(fac.sqrt$coef), as.vector(fac.sqrt_$coef))) > > newdata.extra <- vdata[3:5,] # extra variables unused in the model > newdata.extra$extra <- sqrt(newdata.extra[,1]) > cat("\ncolnames(newdata.extra):", paste(colnames(newdata.extra)), "\n") colnames(newdata.extra): resp bool ord fac str num sqrt_num int date date_num off extra > > newd <- vdata[3:5,c("num", "fac")] # only variables used in the formula model > newd_ <- vdata[3:5,c("num", "sqrt_num", "fac")] # only variables used in the xy model > > stopifnot(identical(predict(fac.sqrt, newdata=newdata.extra), predict(fac.sqrt_, newdata=newd_))) > stopifnot(identical(predict(fac.sqrt, newdata=newd), predict(fac.sqrt_, newdata=newd_))) > stopifnot(identical(predict(fac.sqrt, newdata=newd), predict(fac.sqrt_, newdata=newd_))) > stopifnot(identical(predict(fac.sqrt, newdata=newd), predict(fac.sqrt_, newdata=newd_))) > > stopifnot(max(abs(predict(fac.sqrt, newdata=newdata.extra) - predict(fac.sqrt_, newdata=newdata.extra))) < 1e-10) > stopifnot(max(abs(predict(fac.sqrt, newdata=newdata.extra) - predict(fac.sqrt_, newdata=newdata.extra))) < 1e-10) > > printf("\n=== two response model ===\n") === two response model === > > vdata.2resp <- vdata > resp2 <- 13:1 > vdata.2resp$resp2 <- resp2 > > earth.2resp <- earth(resp+resp2~num+sqrt(num), data=vdata.2resp, weights=vweights, trace=1, + linpreds=TRUE, thresh=0, penalty=-1) Using class "Formula" because lhs of formula has terms separated by "+" x[13,2] with colnames num sqrt(num) y[13,2] with colnames resp resp2 weights[13]: 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 Forward pass term 1, 2, 4, 6 No new term increases RSq (perhaps reached numerical limits) at 5 terms, 3 terms used After forward pass GRSq 0.584 RSq 0.584 Prune backward penalty -1 nprune null: selected 3 of 3 terms, and 2 of 2 preds After pruning pass GRSq 0.584 RSq 0.584 > printf("\nsummary(earth.2resp)\n") summary(earth.2resp) > print(summary(earth.2resp)) Call: earth(formula=resp+resp2~num+sqrt(num), data=vdata.2resp, weights=vweights, trace=1, linpreds=TRUE, thresh=0, penalty=-1) resp resp2 (Intercept) -6.0874826 20.0874826 num -0.3162815 0.3162815 sqrt(num) 7.2649780 -7.2649780 Selected 3 of 3 terms, and 2 of 2 predictors Termination condition: No new term increases RSq at 3 terms Importance: sqrt(num), num Weights: 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 Number of terms at each degree of interaction: 1 2 (additive model) GCV RSS GRSq RSq resp 6.899683 89.69588 0.5836398 0.5836398 resp2 6.899683 89.69588 0.5836398 0.5836398 All 13.799366 179.39176 0.5836398 0.5836398 > cat("\nevimp(earth.2resp)\n") evimp(earth.2resp) > print(evimp(earth.2resp)) nsubsets gcv rss sqrt(num) 2 100.0 100.0 num 1 2.4 2.4 > par(mfrow = c(2, 2), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0), oma=c(0,0,4,0)) > # for formula models, plotmo plots a sinle plot for the effect of num > plotmo(earth.2resp, nresp=1, do.par=0, main="earth.2resp nresp1") > title <- paste( + "two-response model: resp+resp2~num+sqrt(num)\n", + "the top row is for earth.formula models: the combined effect of num and sqrt(num) is plotted together\n", + "the bottom row is for an earth.default model: num and sqrt(num) are plotted separately") > title(title, outer=TRUE, cex=.6) > plotmo(earth.2resp, nresp=2, do.par=0, main="earth.2resp nresp2") > > # put two response data mats into matrix form for earth.default and for lm > xmat <- vdata[,c("num", "sqrt_num"), drop=FALSE] > colnames(xmat) <- c("num", "sqrt(num)") > xmat <- as.matrix(xmat) > ymat <- vdata[, "resp", drop=FALSE] > ymat$resp2 <- resp2 > ymat <- as.matrix(ymat) > earthxy.2resp <- earth(xmat, ymat, weights=vweights, trace=1, + linpreds=TRUE, thresh=0, penalty=-1) x[13,2] with colnames num sqrt(num) y[13,2] with colnames resp resp2 weights[13]: 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 Forward pass term 1, 2, 4, 6 No new term increases RSq (perhaps reached numerical limits) at 5 terms, 3 terms used After forward pass GRSq 0.584 RSq 0.584 Prune backward penalty -1 nprune null: selected 3 of 3 terms, and 2 of 2 preds After pruning pass GRSq 0.584 RSq 0.584 > printf("\nsummary(earthxy.2resp)\n") summary(earthxy.2resp) > print(summary(earthxy.2resp)) Call: earth(x=xmat, y=ymat, weights=vweights, trace=1, linpreds=TRUE, thresh=0, penalty=-1) resp resp2 (Intercept) -6.0874826 20.0874826 num -0.3162815 0.3162815 sqrt(num) 7.2649780 -7.2649780 Selected 3 of 3 terms, and 2 of 2 predictors Termination condition: No new term increases RSq at 3 terms Importance: sqrt(num), num Weights: 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 Number of terms at each degree of interaction: 1 2 (additive model) GCV RSS GRSq RSq resp 6.899683 89.69588 0.5836398 0.5836398 resp2 6.899683 89.69588 0.5836398 0.5836398 All 13.799366 179.39176 0.5836398 0.5836398 > cat("\nevimp(earthxy.2resp)\n") evimp(earthxy.2resp) > print(evimp(earthxy.2resp)) nsubsets gcv rss sqrt(num) 2 100.0 100.0 num 1 2.4 2.4 > # for xy models, plotmo plots a separate plots for the effect of num and sqrt(num) > plotmo(earthxy.2resp, nresp=1, do.par=0) plotmo grid: num sqrt(num) 4 2 > # plotmo(earthxy.2resp, nresp=2, do.par=0) > stopifnot(identical(earth.2resp$coeff, earthxy.2resp$coeff)) > > lm.2resp <- lm(ymat~xmat, weights=vweights) > printf("\nsummary(lm.2resp)\n") summary(lm.2resp) > print(summary(lm.2resp)) Response resp : Call: lm(formula = resp ~ xmat, weights = vweights) Weighted Residuals: Min 1Q Median 3Q Max -3.5470 -2.1773 -0.3788 0.8227 5.4530 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) -6.0875 10.4903 -0.580 0.575 xmatnum -0.3163 3.4983 -0.090 0.930 xmatsqrt(num) 7.2650 12.4500 0.584 0.572 Residual standard error: 2.995 on 10 degrees of freedom Multiple R-squared: 0.5836, Adjusted R-squared: 0.5004 F-statistic: 7.009 on 2 and 10 DF, p-value: 0.01251 Response resp2 : Call: lm(formula = resp2 ~ xmat, weights = vweights) Weighted Residuals: Min 1Q Median 3Q Max -5.4530 -0.8227 0.3788 2.1773 3.5470 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 20.0875 10.4903 1.915 0.0845 . xmatnum 0.3163 3.4983 0.090 0.9297 xmatsqrt(num) -7.2650 12.4500 -0.584 0.5725 --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 2.995 on 10 degrees of freedom Multiple R-squared: 0.5836, Adjusted R-squared: 0.5004 F-statistic: 7.009 on 2 and 10 DF, p-value: 0.01251 > options(warn=2) # treat warnings as errors > expect.err(try(plotmo(lm.2resp, nresp=1)), + "the variable on the right side of the formula is a matrix or data.frame") Error : (converted from warning) the variable on the right side of the formula is a matrix or data.frame plotmo often cannot process such variables Got expected error from try(plotmo(lm.2resp, nresp = 1)) > options(warn=1) # print warnings as they occur > > # check that lm and earth coeffs are the same > # need order() below because coeffs appear in different row order in the coeff mat > earth.2resp.order <- order(earth.2resp$coeff[,1]) > lm.order <- order(lm.2resp$coeff[,1]) > stopifnot(max(abs(earth.2resp$coeff[earth.2resp.order] - lm.2resp$coeff[lm.order])) < 1e-10) > > printf("\n=== test glm() with spaced.bx ===\n") === test glm() with spaced.bx === > > # glm requires response to be a factor (or two columns) > spaced.bx.fac <- spaced.bx > spaced.bx.fac$`surv fac` <- factor(ifelse(spaced.bx$`Survived = YES`, "yes", "no"), levels = c("yes", "no")) > spaced.bx.fac$`Survived = YES` <- NULL > glm.spaced.bx <- glm(`surv fac` ~ ., data=spaced.bx.fac, family="binomial") > printf("summary(glm.spaced.bx):\n") summary(glm.spaced.bx): > print(summary(glm.spaced.bx)) Call: glm(formula = `surv fac` ~ ., family = "binomial", data = spaced.bx.fac) Coefficients: Estimate Std. Error z value Pr(>|z|) (Intercept) -2.91353 0.28320 -10.288 < 2e-16 *** sexmale 3.18562 0.31478 10.120 < 2e-16 *** pclass3rd 5.03006 0.56669 8.876 < 2e-16 *** `sexmale*H(16 - age)` -0.24181 0.03646 -6.632 3.31e-11 *** `pclass2nd*sexmale` 1.76809 0.32676 5.411 6.27e-08 *** `pclass3rd*H(4 - sibsp)` -0.61865 0.13506 -4.581 4.64e-06 *** `pclass3rd*sexmale` -1.22270 0.39291 -3.112 0.00186 ** `H(age - 32)` 0.03757 0.01178 3.189 0.00143 ** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 (Dispersion parameter for binomial family taken to be 1) Null deviance: 1414.62 on 1045 degrees of freedom Residual deviance: 892.79 on 1038 degrees of freedom AIC: 908.79 Number of Fisher Scoring iterations: 5 > plotmo(glm.spaced.bx, do.par=2) Warning: Cannot determine which variables to plot in degree2 plots (use all2=TRUE?) Confused by variable name "`sexmale*H(16 - age)`" plotmo grid: sexmale pclass3rd sexmale*H(16 - age) pclass2nd*sexmale 1 0 0 0 pclass3rd*H(4 - sibsp) pclass3rd*sexmale H(age - 32) 0 0 0 > plotres(glm.spaced.bx, which=3, do.par=0, info=TRUE, main="plotres(glm.spaced.bx,which=3") > # TODO why is Residuals-Vs-Fitted plot different for plotres and plot for glm models? > plot(glm.spaced.bx, which=1, caption="plot(glm.spaced.bx, which=1)") > par(org.par) > plotmo(glm.spaced.bx, all2=TRUE, degree2=c("sexmale", "pclass"), SHOW.CALL=TRUE, do.par=2) plotmo grid: sexmale pclass3rd sexmale*H(16 - age) pclass2nd*sexmale 1 0 0 0 pclass3rd*H(4 - sibsp) pclass3rd*sexmale H(age - 32) 0 0 0 > plotmo(glm.spaced.bx, degree1=0, all2=TRUE, degree2=c("sexmale", "age"), do.par=0) > par(org.par) # TODO I think plot(glm.spaced.bx) doesn't restore the graphics params? > > printf("\n=== test formulas which have a rhs variable which a matrix ===\n") === test formulas which have a rhs variable which a matrix === > # This also tests that earth's naming of variables is the same as lm for such rhs variables > # > # TODO plotmo fails when rhs variable is a matrix --- would be nice to fix that > > x_ <- etitanic[,"age",drop=FALSE] > x_$pclass <- etitanic$pclass > x_$pclass <- as.numeric(etitanic$pclass) > x_ <- as.matrix(x_) > y_ <- as.matrix(as.numeric(etitanic[,"survived"])) > > earthxy.rhs.mat <- earth(x_, y_, degree=2, trace=1) x[1046,2] with colnames age pclass y[1046,1] with colname y_, and values 1, 1, 0, 0, 0, 1, 1, 0, 1, 0,... Forward pass term 1, 2, 4, 6, 8, 10 RSq changed by less than 0.001 at 9 terms (DeltaRSq 0.00055) After forward pass GRSq 0.120 RSq 0.162 Prune backward penalty 3 nprune null: selected 6 of 9 terms, and 2 of 2 preds After pruning pass GRSq 0.137 RSq 0.158 > print(summary(earthxy.rhs.mat)) Call: earth(x=x_, y=y_, trace=1, degree=2) coefficients (Intercept) 0.47789359 h(18-age) 0.03051719 h(age-18) -0.00609975 h(2-pclass) 0.28092736 h(pclass-2) -0.16376873 h(23-age) * h(pclass-2) -0.01570789 Selected 6 of 9 terms, and 2 of 2 predictors Termination condition: RSq changed by less than 0.001 at 9 terms Importance: pclass, age Number of terms at each degree of interaction: 1 4 1 GCV 0.2088003 RSS 212.8039 GRSq 0.1373292 RSq 0.1578438 > cat("\nevimp(earthxy.rhs.mat)\n") evimp(earthxy.rhs.mat) > print(evimp(earthxy.rhs.mat)) nsubsets gcv rss pclass 5 100.0 100.0 age 4 66.0 69.3 > cat("\nearthxy.rhs.mat$modvars\n") earthxy.rhs.mat$modvars > print(earthxy.rhs.mat$modvars) age pclass age 1 0 pclass 0 1 > plotmo(earthxy.rhs.mat, SHOWCALL=TRUE) # ok plotmo grid: age pclass 28 2 > > earth.rhs.mat <- earth(y_ ~ x_, degree=2, trace=1) x[1046,2] with colnames x_age x_pclass y[1046,1] with colname y_, and values 1, 1, 0, 0, 0, 1, 1, 0, 1, 0,... Forward pass term 1, 2, 4, 6, 8, 10 RSq changed by less than 0.001 at 9 terms (DeltaRSq 0.00055) After forward pass GRSq 0.120 RSq 0.162 Prune backward penalty 3 nprune null: selected 6 of 9 terms, and 2 of 2 preds After pruning pass GRSq 0.137 RSq 0.158 > print(summary(earth.rhs.mat)) Call: earth(formula=y_~x_, trace=1, degree=2) coefficients (Intercept) 0.47789359 h(18-x_age) 0.03051719 h(x_age-18) -0.00609975 h(2-x_pclass) 0.28092736 h(x_pclass-2) -0.16376873 h(23-x_age) * h(x_pclass-2) -0.01570789 Selected 6 of 9 terms, and 2 of 2 predictors Termination condition: RSq changed by less than 0.001 at 9 terms Importance: x_pclass, x_age Number of terms at each degree of interaction: 1 4 1 GCV 0.2088003 RSS 212.8039 GRSq 0.1373292 RSq 0.1578438 > cat("\nevimp(earth.rhs.mat)\n") evimp(earth.rhs.mat) > print(evimp(earth.rhs.mat)) nsubsets gcv rss x_pclass 5 100.0 100.0 x_age 4 66.0 69.3 > cat("\nearth.rhs.mat$modvars\n") earth.rhs.mat$modvars > print(earth.rhs.mat$modvars) x_age x_pclass x_ 1 1 > stopifnot(max(abs(earthxy.rhs.mat$coeff - earth.rhs.mat$coeff)) < 1e-15) > expect.err(try(plotmo(earth.rhs.mat)), # Warning: the variable on the right side of the formula is a matrix or data.frame + "model.frame.default could not interpret the data passed to get.earth.x from model.matrix.earth from predict.earth") Warning: the variable on the right side of the formula is a matrix or data.frame plotmo often cannot process such variables Warning: Cannot determine which variables to plot (use all1=TRUE?) single.names=c(x_,x_,x_,x_) colnames(x)=c(age,pclass) stats::predict(earth.object, data.frame[50,2], type="response") Error : model.frame.default could not interpret the data passed to get.earth.x from model.matrix.earth from predict.earth (actual.nrows=1046 expected.nrows=50 fitted.nrows=1046) Got expected error from try(plotmo(earth.rhs.mat)) > expect.err(try(plotmo(earth.rhs.mat, all1=TRUE)), # still fails + "model.frame.default could not interpret the data passed to get.earth.x from model.matrix.earth from predict.earth") Warning: the variable on the right side of the formula is a matrix or data.frame plotmo often cannot process such variables stats::predict(earth.object, data.frame[50,2], type="response") Error : model.frame.default could not interpret the data passed to get.earth.x from model.matrix.earth from predict.earth (actual.nrows=1046 expected.nrows=50 fitted.nrows=1046) Got expected error from try(plotmo(earth.rhs.mat, all1 = TRUE)) > > lm.rhs.mat <- lm(y_ ~ x_) > print(summary(lm.rhs.mat)) Call: lm(formula = y_ ~ x_) Residuals: Min 1Q Median 3Q Max -0.9113 -0.3505 -0.1995 0.4395 1.0350 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 1.167193 0.062574 18.653 < 2e-16 *** x_age -0.007626 0.001070 -7.125 1.94e-12 *** x_pclass -0.240589 0.018334 -13.123 < 2e-16 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 0.4553 on 1043 degrees of freedom Multiple R-squared: 0.1444, Adjusted R-squared: 0.1427 F-statistic: 87.98 on 2 and 1043 DF, p-value: < 2.2e-16 > expect.err(try(plotmo(lm.rhs.mat)), # Warning: the variable on the right side of the formula is a matrix or data.frame + "predict returned the wrong length (got 1046 but expected 50)") Warning: the variable on the right side of the formula is a matrix or data.frame plotmo often cannot process such variables Warning: 'newdata' had 50 rows but variables found have 1046 rows Error : predict returned the wrong length (got 1046 but expected 50) Got expected error from try(plotmo(lm.rhs.mat)) > expect.err(try(plotmo(lm.rhs.mat, all1=TRUE)), # still fails + "predict returned the wrong length (got 1046 but expected 50)") Warning: the variable on the right side of the formula is a matrix or data.frame plotmo often cannot process such variables Warning: 'newdata' had 50 rows but variables found have 1046 rows Error : predict returned the wrong length (got 1046 but expected 50) Got expected error from try(plotmo(lm.rhs.mat, all1 = TRUE)) > earth1.rhs.mat <- earth(y_ ~ x_, linpreds=TRUE, thresh=0, penalty=-1) # degree1 > cat("\nevimp(earth1.rhs.mat)\n") evimp(earth1.rhs.mat) > print(evimp(earth1.rhs.mat)) nsubsets gcv rss x_pclass 2 100.0 100.0 x_age 1 53.7 53.7 > options(warn=2) > expect.err(try(plotmo(earth.rhs.mat)), + "the variable on the right side of the formula is a matrix or data.frame") Error : (converted from warning) the variable on the right side of the formula is a matrix or data.frame plotmo often cannot process such variables Got expected error from try(plotmo(earth.rhs.mat)) > expect.err(try(plotmo(earth.rhs.mat, all1=TRUE)), # still fails + "the variable on the right side of the formula is a matrix or data.frame") Error : (converted from warning) the variable on the right side of the formula is a matrix or data.frame plotmo often cannot process such variables Got expected error from try(plotmo(earth.rhs.mat, all1 = TRUE)) > options(warn=1) > stopifnot(max(abs(sort(lm.rhs.mat$coeff) - sort(earth1.rhs.mat$coeff))) < 1e-12) > stopifnot(sort(rownames(lm.rhs.mat$coeff)) == sort(rownames(earth1.rhs.mat$coeff))) > > x_nonames <- x_ > colnames(x_nonames) <- NULL > lm.rhs.nonames <- lm(y_ ~ x_nonames) > print(summary(lm.rhs.nonames)) Call: lm(formula = y_ ~ x_nonames) Residuals: Min 1Q Median 3Q Max -0.9113 -0.3505 -0.1995 0.4395 1.0350 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 1.167193 0.062574 18.653 < 2e-16 *** x_nonames1 -0.007626 0.001070 -7.125 1.94e-12 *** x_nonames2 -0.240589 0.018334 -13.123 < 2e-16 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 0.4553 on 1043 degrees of freedom Multiple R-squared: 0.1444, Adjusted R-squared: 0.1427 F-statistic: 87.98 on 2 and 1043 DF, p-value: < 2.2e-16 > expect.err(try(plotmo(lm.rhs.nonames)), # Warning: the variable on the right side of the formula is a matrix or data.frame + "predict returned the wrong length (got 1046 but expected 50)") Warning: the variable on the right side of the formula is a matrix or data.frame plotmo often cannot process such variables Warning: 'newdata' had 50 rows but variables found have 1046 rows Error : predict returned the wrong length (got 1046 but expected 50) Got expected error from try(plotmo(lm.rhs.nonames)) > expect.err(try(plotmo(lm.rhs.nonames, all1=TRUE)), # still fails + "predict returned the wrong length (got 1046 but expected 50)") Warning: the variable on the right side of the formula is a matrix or data.frame plotmo often cannot process such variables Warning: 'newdata' had 50 rows but variables found have 1046 rows Error : predict returned the wrong length (got 1046 but expected 50) Got expected error from try(plotmo(lm.rhs.nonames, all1 = TRUE)) > earth1.rhs.nonames <- earth(y_ ~ x_nonames, linpreds=TRUE, thresh=0, penalty=-1) # degree1 > print(summary(earth1.rhs.nonames)) Call: earth(formula=y_~x_nonames, linpreds=TRUE, thresh=0, penalty=-1) coefficients (Intercept) 1.16719336 x_nonames1 -0.00762624 x_nonames2 -0.24058942 Selected 3 of 3 terms, and 2 of 2 predictors Termination condition: No new term increases RSq at 3 terms Importance: x_nonames2, x_nonames1 Number of terms at each degree of interaction: 1 2 (additive model) GCV 0.2067034 RSS 216.2118 GRSq 0.1443571 RSq 0.1443571 > cat("\nevimp(earth1.rhs.nonames)\n") evimp(earth1.rhs.nonames) > print(evimp(earth1.rhs.nonames)) nsubsets gcv rss x_nonames2 2 100.0 100.0 x_nonames1 1 53.7 53.7 > options(warn=2) > expect.err(try(plotmo(earth1.rhs.nonames)), # Warning: the variable on the right side of the formula is a matrix or data.frame + "the variable on the right side of the formula is a matrix or data.frame") Error : (converted from warning) the variable on the right side of the formula is a matrix or data.frame plotmo often cannot process such variables Got expected error from try(plotmo(earth1.rhs.nonames)) > expect.err(try(plotmo(earth1.rhs.nonames, all1=TRUE)), # still fails + "the variable on the right side of the formula is a matrix or data.frame") Error : (converted from warning) the variable on the right side of the formula is a matrix or data.frame plotmo often cannot process such variables Got expected error from try(plotmo(earth1.rhs.nonames, all1 = TRUE)) > options(warn=1) > stopifnot(max(abs(sort(lm.rhs.nonames$coeff) - sort(earth1.rhs.nonames$coeff))) < 1e-12) > stopifnot(sort(rownames(lm.rhs.nonames$coeff)) == sort(rownames(earth1.rhs.nonames$coeff))) > > printf("\n=== test handling consecutive '-' in formula ===\n") === test handling consecutive '-' in formula === > > options(warn=2) > lm.consec.minus <- lm(Volume~.--Girth, data=trees) # note double -- > expect.err(try(plotmo(lm.consec.minus)), + "Consecutive '-' in formula may cause problems") Error : (converted from warning) Consecutive '-' in formula may cause problems Formula: (Girth + Height) - -Girth Got expected error from try(plotmo(lm.consec.minus)) > earth.consec.minus <- earth(Volume~.--Girth, data=trees) # note double -- > cat("\nsummary(earth.consec.minus)\n") summary(earth.consec.minus) > print(summary(earth.consec.minus)) Call: earth(formula=Volume~.--Girth, data=trees) coefficients (Intercept) 29.0599535 h(14.2-Girth) -3.4198062 h(Girth-14.2) 6.2295143 h(Height-75) 0.5813644 Selected 4 of 5 terms, and 2 of 2 predictors Termination condition: RSq changed by less than 0.001 at 5 terms Importance: Girth, Height Number of terms at each degree of interaction: 1 3 (additive model) GCV 11.25439 RSS 209.1139 GRSq 0.959692 RSq 0.9742029 > cat("\nevimp(earth.consec.minus)\n") evimp(earth.consec.minus) > print(evimp(earth.consec.minus)) nsubsets gcv rss Girth 3 100.0 100.0 Height 1 10.7 11.5 > expect.err(try(plotmo(earth.consec.minus)), + "Consecutive '-' in formula may cause problems") Error : (converted from warning) Consecutive '-' in formula may cause problems Formula: (Girth + Height) - -Girth Got expected error from try(plotmo(earth.consec.minus)) > options(warn=1) > > printf("\n=== test rpart() with spaced.bx ===\n") === test rpart() with spaced.bx === > > library(rpart.plot) Loading required package: rpart > rpart.mod <- rpart(`Survived = YES` ~ ., data=spaced.bx) > printf("\nprint(rpart.rules(rpart.mod))\n") print(rpart.rules(rpart.mod)) > print(rpart.rules(rpart.mod)) Survived = YES 0.062 when sexmale is 1 & pclass3rd is 1 & sexmale*H(16 - age) >= 6.5 & pclass3rd*H(4 - sibsp) < 2 0.082 when sexmale is 1 & sexmale*H(16 - age) < 6.5 & pclass2nd*sexmale is 1 0.150 when sexmale is 1 & pclass3rd is 1 & sexmale*H(16 - age) < 6.5 & pclass2nd*sexmale is 0 0.338 when sexmale is 1 & pclass3rd is 0 & sexmale*H(16 - age) < 6.5 & pclass2nd*sexmale is 0 0.474 when sexmale is 0 & pclass3rd is 1 0.769 when sexmale is 1 & pclass3rd is 1 & sexmale*H(16 - age) >= 6.5 & pclass3rd*H(4 - sibsp) >= 2 0.932 when sexmale is 0 & pclass3rd is 0 1.000 when sexmale is 1 & pclass3rd is 0 & sexmale*H(16 - age) >= 6.5 > set.seed(2020) > plotmo(rpart.mod, do.par=2, degree1=c("sexmale", "pclass3rd"), degree2=2, pt.col="red") plotmo grid: sexmale pclass3rd sexmale*H(16 - age) pclass2nd*sexmale 1 0 0 0 pclass3rd*H(4 - sibsp) pclass3rd*sexmale H(age - 32) 0 0 0 > plotres(rpart.mod, do.par=0, which=c(1,3)) > par(org.par) > > printf("\n=== tibble, class \"Date\", and ndiscrete ===\n") === tibble, class "Date", and ndiscrete === > > library(tibble) > library(lubridate) Attaching package: 'lubridate' The following objects are masked from 'package:base': date, intersect, setdiff, union > tib1 <- tibble(y = c(1, 1, 2, 3), # even number of variables + bool = c(F, F, F, T), + date = c(ymd('2018-08-01'), ymd('2018-08-02'), ymd('2018-08-03'), + ymd('2018-08-03'))) > cat("class tib1$date: ", class(tib1$date), "\n") class tib1$date: Date > mod.tib1 <- lm(y ~ ., data = tib1) > plotmo(mod.tib1, col.response=2, all2=TRUE, ticktype="d", do.par=2, caption="mod.tib1: Dates ndiscrete=default 5") plotmo grid: bool date FALSE 2018-08-02 > plotmo(mod.tib1, col.response=2, degree1=0, all2=TRUE, ticktype="d", do.par=0, theta=-45) > par(org.par) > > plotmo(mod.tib1, col.response=2, all2=TRUE, ticktype="d", do.par=2, ndiscrete=2, caption="mod.tib1: Dates ndiscrete=2") plotmo grid: bool date FALSE 2018-08-02 > plotmo(mod.tib1, col.response=2, degree1=0, all2=TRUE, ticktype="d", do.par=0, theta=-45, ndiscrete=2) > par(org.par) > > plotmo(mod.tib1, col.response=2, all2=TRUE, ticktype="d", do.par=2, ndiscr=1, caption="mod.tib1: Dates ndiscrete=1") plotmo grid: bool date FALSE 2018-08-02 > plotmo(mod.tib1, col.response=2, degree1=0, all2=TRUE, ticktype="d", do.par=0, theta=-45, ndiscrete=2) > par(org.par) > > tib2 <- tibble(y = c(1, 1, 2, 3, 4), # odd number of variables + bool = c(F, F, F, T, T), + date = c(ymd('2018-08-01'), ymd('2018-08-02'), ymd('2018-08-03'), + ymd('2018-08-03'), ymd('2018-08-04'))) > mod.tib2 <- lm(y ~ ., data = tib2) > plotmo(mod.tib2, col.response=2, all2=TRUE, ticktype="d", do.par=2, caption="mod.tib2: Dates ndiscrete=default 5") plotmo grid: bool date FALSE 2018-08-03 > plotmo(mod.tib2, col.response=2, degree1=0, all2=TRUE, ticktype="d", do.par=0, theta=-45) > par(org.par) > > plotmo(mod.tib2, col.response=2, all2=TRUE, ticktype="d", do.par=2, ndiscrete=2, caption="mod.tib2: Dates ndiscrete=2") plotmo grid: bool date FALSE 2018-08-03 > plotmo(mod.tib2, col.response=2, degree1=0, all2=TRUE, ticktype="d", do.par=0, theta=-45, ndiscrete=2) > par(org.par) > > plotmo(mod.tib2, col.response=2, all2=TRUE, ticktype="d", do.par=2, ndiscr=1, caption="mod.tib2: Dates ndiscrete=1") plotmo grid: bool date FALSE 2018-08-03 > plotmo(mod.tib2, col.response=2, degree1=0, all2=TRUE, ticktype="d", do.par=0, theta=-45, ndiscrete=2) > par(org.par) > > source("test.epilog.R") plotmo/inst/slowtests/test.linmod.bat0000755000176200001440000000147014563571565017566 0ustar liggesusers@rem test.linmod.bat: test example S3 model in linmod.R @echo test.linmod.bat @"C:\PROGRA~1\R\R-4.3.2\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.linmod.R @if %errorlevel% equ 0 goto good1: @echo R returned errorlevel %errorlevel%, see test.linmod.Rout: @echo. @tail test.linmod.Rout @echo test.linmod.R @exit /B 1 :good1 mks.diff test.linmod.Rout test.linmod.Rout.save @if %errorlevel% equ 0 goto good2: @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.linmod.save.ps @exit /B 1 :good2 @rem test.linmod.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.linmod.save.ps @if %errorlevel% equ 0 goto good3: @echo === Files are different === @exit /B 1 :good3 @rm -f test.linmod.Rout @rm -f Rplots.ps @exit /B 0 plotmo/inst/slowtests/test.dots.bat0000755000176200001440000000143514563571565017256 0ustar liggesusers@rem test.dots.R: test handling of dots arguments @echo test.dots.bat @"C:\PROGRA~1\R\R-4.3.2\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.dots.R @if %errorlevel% equ 0 goto good1: @echo R returned errorlevel %errorlevel%, see test.dots.Rout: @echo. @tail test.dots.Rout @echo test.dots.R @exit /B 1 :good1 mks.diff test.dots.Rout test.dots.Rout.save @if %errorlevel% equ 0 goto good2: @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.dots.save.ps @exit /B 1 :good2 @rem test.dots.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.dots.save.ps @if %errorlevel% equ 0 goto good3: @echo === Files are different === @exit /B 1 :good3 @rm -f test.dots.Rout @rm -f Rplots.ps @exit /B 0 plotmo/inst/slowtests/test.fac.R0000644000176200001440000002721013727235376016463 0ustar liggesusers# test.fac.R: test factor plotting in plotmo. This also tests swapxy, xflip, and yflip # Stephen Milborrow, Berea Mar 2011 source("test.prolog.R") library(plotmo) library(earth) library(rpart) data(ozone1) data(etitanic) cat("==test plotmo with factors==\n") test.fac.with.rpart <- function(ngrid2=20) { et <- etitanic col.response <- as.numeric(et$sex)+2 et$pclass.fac <- et$pclass et$parch.int <- et$parch parch.fac <- et$parch parch.fac[parch.fac >= 3] <- 3 # use non alphabetically sorted factor levels et$parch.fac <- factor(parch.fac, labels=c( "levz", "lev1", "lev2", "levf")) et$pclass.num <- as.numeric(et$pclass) et$pclass <- et$sex <- et$age <- et$sibsp <- et$parch <- NULL cat("names(et):", names(et), "\n") # survived pclass.fac parch.int parch.fac pclass.num old.par <- par(no.readonly=TRUE) on.exit(par(old.par)) par(mfrow=c(4,5)) par(mar = c(2, 2, 3, 0.5), cex=.6) # numeric x numeric a2 <- rpart(survived ~ pclass.num+parch.int, data=et) set.seed(145) plotmo(a2, do.par=F, type2="im", degree1=2, col.response=col.response, pt.cex=.3) set.seed(145) plotmo(a2, do.par=F, type2="con", degree1=NA, col.response=col.response, pt.cex=.3) set.seed(145) plotmo(a2, do.par=F, type2="persp", degree1=NA, ngrid2=40, persp.theta=NA, persp.ticktype="d", cex.lab=.8, persp.ntick=2) # factor x numeric a3 <- rpart(survived ~ pclass.fac+parch.int, data=et) set.seed(145) plotmo(a3, do.par=F, type2="im", col.response=col.response, pt.cex=.3) set.seed(145) plotmo(a3, do.par=F, type2="con", degree1=NA, col.response=col.response, pt.cex=.3) set.seed(145) plotmo(a3, do.par=F, type2="persp", degree1=NA, ngrid2=40, persp.theta=NA, persp.ticktype="d", persp.border=NA, cex.lab=.8, persp.ntick=2) # numeric x factor a4 <- rpart(survived ~ pclass.num+parch.fac, data=et) set.seed(145) plotmo(a4, do.par=F, type2="im", tra=1, col.response=col.response, pt.cex=.3) set.seed(145) plotmo(a4, do.par=F, type2="con", degree1=NA, col.response=col.response, pt.cex=.3) set.seed(145) plotmo(a4, do.par=F, type2="persp", degree1=NA, ngrid2=40, persp.theta=NA, persp.ticktype="d", persp.border=NA, cex.lab=.8, persp.ntick=2) # factor x factor a5 <- rpart(survived ~ pclass.fac+parch.fac, data=et) set.seed(145) plotmo(a5, do.par=F, type2="im", nrug=TRUE, col.response=col.response, pt.cex=.3) set.seed(145) plotmo(a5, do.par=F, type2="con", degree1=NA, col.response=col.response, pt.cex=.3) set.seed(145) plotmo(a5, do.par=F, type2="persp", degree1=NA, ngrid2=40, persp.theta=NA, persp.ticktype="d", persp.border=NA, cex.lab=.8, persp.ntick=2) # test ndiscrete par(mfrow=c(3,5)) par(mar = c(2, 2, 3, 0.5), cex=.6) plotmo(a2, do.par=F, type2="persp", degree1=2, ndiscrete=0, main="ndiscrete=0", persp.theta=NA, persp.ticktype="d", persp.ntick=2, col.response=col.response, pt.cex=.3) plotmo(a2, do.par=F, type2="im", degree1=NA, ndiscrete=0) plotmo(a2, do.par=F, type2="con", degree1=NA, ndiscrete=0) plotmo(a2, do.par=F, type2="persp", degree1=2, degree2=NA, ndiscrete=0, main="center", center=TRUE, col.response=col.response, pt.cex=.3) plotmo(a2, do.par=F, type2="persp", degree1=2, ndiscrete=3, main="ndiscrete=3", persp.theta=NA, persp.ticktype="d", persp.ntick=2, col.response=col.response, pt.cex=.3) plotmo(a2, do.par=F, type2="im", degree1=NA, ndiscrete=3) plotmo(a2, do.par=F, type2="con", degree1=NA, ndiscrete=3) plotmo(a2, do.par=F, type2="persp", degree1=2, degree2=NA, ndiscrete=3, main="center", center=TRUE, col.response=col.response, pt.cex=.3) plotmo(a2, do.par=F, type2="persp", degree1=2, ndiscrete=10, main="ndiscrete=10", persp.theta=NA, persp.ticktype="d", persp.ntick=2, col.response=col.response, pt.cex=.3) plotmo(a2, do.par=F, type2="im", degree1=NA, ndiscrete=10) plotmo(a2, do.par=F, type2="con", degree1=NA, ndiscrete=10) plotmo(a2, do.par=F, type2="persp", degree1=2, degree2=NA, ndiscrete=10, main="center", center=TRUE, col.response=col.response, pt.cex=.3) } test.fac.with.rpart() cat("==test plotmo swapxy with factors==\n") test.swapxy.with.rpart <- function(ngrid2=20) { et <- etitanic[c(1:50,300:350,600:650),] col.response <- as.numeric(et$sex)+2 et$pclass.fac <- et$pclass et$parch.int <- et$parch parch.fac <- et$parch parch.fac[parch.fac > 2] <- 2 # use non alphabetically sorted factor levels et$parch.fac <- factor(parch.fac, labels=c("lev.zero", "lev.one", "lev.two.or.more")) print(et$parch.fac) et$pclass.num <- as.numeric(et$pclass) et$pclass <- et$sex <- et$age <- et$sibsp <- et$parch <- NULL cat("names(et):", names(et), "\n") # survived pclass.fac parch.int parch.fac pclass.num old.par <- par(no.readonly=TRUE) on.exit(par(old.par)) par(mfrow=c(4,4)) par(mar = c(2, 3, 5, 0.5), cex=.6) # factor x factor a5 <- rpart(survived ~ pclass.fac+parch.fac, data=et) for(swapxy in c(F,T)) { for(xflip in c(F,T)) for(yflip in c(F,T)) { set.seed(145) plotmo(a5, do.par=F, type2="im", degree1=NA, swapxy=swapxy, xflip=xflip, yflip=yflip, main=paste("swapxy=", swapxy, "\nxflip=", xflip, "\nyflip=", yflip), col.response=col.response, pt.cex=3, pt.pch=".") set.seed(145) plotmo(a5, do.par=F, type2="con", degree1=NA, swapxy=swapxy, xflip=xflip, yflip=yflip, main=paste("swapxy=", swapxy, "\nxflip=", xflip, "\nyflip=", yflip), col.response=col.response, pt.cex=.3) } } par(mfrow=c(2,2)) set.seed(146) plotmo(a5, do.par=F, type2="persp", degree1=NA, swapxy=FALSE, main=paste("swapxy=", FALSE), ngrid2=40, persp.theta=145, persp.ticktype="d", cex.lab=.8, persp.ntick=5) set.seed(146) plotmo(a5, do.par=F, type2="persp", degree1=NA, swapxy=TRUE, main=paste("swapxy=", TRUE), ngrid2=40, persp.theta=145, persp.ticktype="d", cex.lab=.8, persp.ntick=5) set.seed(146) plotmo(a5, do.par=F, type2="im", degree1=2, swapxy=FALSE, main=paste("swapxy=", FALSE)) } test.swapxy.with.rpart() aflip <- earth(O3~vh + wind + humidity + temp, data=ozone1, degree=2) col.response<- ifelse(ozone1$O3 == 38, "red", "pink") # test xflip arg, degree1 plots par(mfrow=c(2,2)) set.seed(102) plotmo(aflip, degree1=1:2, degree2=0, do.par=F, col.response=col.response, nrug=-1, ylab="O3", smooth.col="gray") plotmo(aflip, degree1=1:2, degree2=F, do.par=F, col.response=col.response, nrug=-1, ylab="O3", xflip=T, main="xflip=TRUE, degree1 plots", , smooth.col="gray") col.response<- ifelse(ozone1$O3 == 1, "green", "pink") # test flip args, type2=persp par(mfrow=c(2,2)) plotmo(aflip, degree1=0, degree2=2, do.par=F, persp.ticktype="d") plotmo(aflip, degree1=0, degree2=2, do.par=F, persp.tickt="d", swapxy=T, main="swapxy=TRUE") plot(0, 0, type="n", axes=FALSE, xlab="", ylab="") plot(0, 0, type="n", axes=FALSE, xlab="", ylab="") # test swapxy args, type2=image par(mfrow=c(3,3)) plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="im", col.response=col.response, main="test swapxy on image plots\nreference plot") plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="im", col.response=col.response, swapxy=T, main="swapxy=T") plot(0, 0, type="n", axes=FALSE, xlab="", ylab="") plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="im", col.response=col.response, xflip=T, main="xflip=T") plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="im", col.response=col.response, yflip=T, main="yflip=T") plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="im", col.response=col.response, xflip=T, yflip=T, main="xflip=T, yflip=T") plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="im", col.response=col.response, swapxy=T, xflip=T, main="swapxy=T, xflip=T") plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="im", col.response=col.response, swapxy=T, yflip=T, main="swapxy=T, yflip=T") plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="im", col.response=col.response, swapxy=T, xflip=T, yflip=T, main="swapxy=T, xflip=T, yflip=T") # test flip args, type2=contour plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="con", col.response=col.response, main="test flip on contour plots\nreference plot") plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="con", col.response=col.response, swapxy=T) plot(0, 0, type="n", axes=FALSE, xlab="", ylab="") plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="con", col.response=col.response, xflip=T) plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="con", col.response=col.response, yflip=T) plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="con", col.response=col.response, xflip=T, yflip=T) plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="con", col.response=col.response, swapxy=T, xflip=T) plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="con", col.response=col.response, swapxy=T, yflip=T) plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="con", col.response=col.response, swapxy=T, xflip=T, yflip=T) # ordered factor cat("==test plotmo with ordered factor==\n") par(mfcol=c(2,2)) par(mar=c(3, 3, 3, 1)) par(mgp=c(1.5, .5, 0)) a <- lm(height~., data=Loblolly) termplot(a, partial.resid=T, rug=T, terms=2, main="Seed is an ordered factor") # compare to termplot plotmo(a, do.par=F, col.resp="gray", nrug=T, all2=T) #--------------------------------------------------------------------------- # test ndiscrete with integer and non integer predictors, with missing values par(mfcol=c(2,4)) par(mar=c(3, 3, 3, 1)) par(mgp=c(1.5, .5, 0)) et <- etitanic et$var <- et$parch et$var[et$var==1] <- 0 # want a "hole" in var's value, for testing et$var[1:3] <- 6 cat("table(et$var):") print(table(et$var)) cat("\n") a <- earth(survived~var+age, data=et, degree=2, pm="none") plotmo(a, trace=FALSE, ndiscrete=0, main="integral var\n(var levels are 0 2 3 4 5 6)\nndiscrete=0", cex.lab=.8, do.par=F, smooth.col="indianred", persp.ticktype="d", clip=F, degree1=0, persp.theta=40) plotmo(a, ndiscrete=0, do.par=F, smooth.col="indianred", ylim=c(-.5,1), degree2=0, degree1=1) #------------ plotmo(a, ndiscrete=10, main="integral var\nndiscrete=10", cex.lab=.8, do.par=F, smooth.col="indianred", persp.ticktype="d", clip=F, degree1=0, persp.theta=40) plotmo(a, trace=0, ndiscrete=10, do.par=F, smooth.col="indianred", ylim=c(-.5,1), degree2=0, degree1=1) #------------ et$var <- et$var / 2 cat("table(et$var):") print(table(et$var)) cat("\n") a <- earth(survived~var+age, data=et, degree=2, pm="none") plotmo(a, ndiscrete=0, main="integral var\n(var levels are 0 1 1.5 2 2.5 3)\nndiscrete=0", cex.lab=.8, do.par=F, smooth.col="indianred", persp.ticktype="d", clip=F, degree1=0, persp.theta=40) plotmo(a, ndiscrete=0, do.par=F, smooth.col="indianred", ylim=c(-.5,1), degree2=0, degree1=1) #------------ plotmo(a, ndiscrete=10, main="non integral var\nndiscrete=10", cex.lab=.8, do.par=F, smooth.col="indianred", persp.ticktype="d", clip=F, degree1=0, persp.theta=40) plotmo(a, ndiscrete=10, do.par=F, smooth.col="indianred", ylim=c(-.5,1), degree2=0, degree1=1) source("test.epilog.R") plotmo/inst/slowtests/test.glmnetUtils.Rout.save0000644000176200001440000002615214563614021021715 0ustar liggesusers> # test.glmnet.R: glmnetUtils tests for plotmo and plotres > > source("test.prolog.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix > library(glmnetUtils) > data(ozone1) > data(etitanic) > get.tit <- function() # abbreviated titanic data + { + tit <- etitanic + pclass <- as.character(tit$pclass) + # change the order of the factors so not alphabetical + pclass[pclass == "1st"] <- "first" + pclass[pclass == "2nd"] <- "class2" + pclass[pclass == "3rd"] <- "classthird" + tit$pclass <- factor(pclass, levels=c("class2", "classthird", "first")) + # log age is so we have a continuous predictor even when model is age~. + set.seed(2015) + tit$logage <- log(tit$age) + rnorm(nrow(tit)) + tit$parch <- NULL + # by=12 gives us a small fast model with an additive and a interaction term + tit <- tit[seq(1, nrow(etitanic), by=12), ] + } > plotmores <- function(object, ..., trace=0, SHOWCALL=TRUE, title.extra="", ncol=2) { + old.par <- par(no.readonly=TRUE) + on.exit(par(old.par)) + par(mfrow=c(2,ncol)) + caption <- paste(deparse(substitute(object)), collapse=" ") + call <- match.call(expand.dots=TRUE) + call <- strip.space(paste(deparse(substitute(call)), collapse=" ")) + call <- gsub(",", ", ", call) + call <- paste(title.extra, call, sep="") + printf("%s\n", call) + # plotmo on glmnet mods is boring but we test it anyway + plotres(object, trace=trace, SHOWCALL=SHOWCALL, do.par=FALSE, which=c(1,3), ...) + title(paste("\n", call), outer=TRUE) + plotmo(object, trace=trace, SHOWCALL=SHOWCALL, do.par=FALSE, ...) + } > tit <- get.tit() > set.seed(2015) > xmat <- as.matrix(tit[,c(2,5,6)]) > agedata <- data.frame(tit[,4], xmat) > colnames(agedata) <- c("age", "survived", "sibsp", "logage") > set.seed(2015) > mod.glmnet.xmat <- glmnet(xmat, tit[,4]) # tit[,4] is age > plotres(mod.glmnet.xmat) > plotmo(mod.glmnet.xmat) plotmo grid: survived sibsp logage 0 0 3.06991 > plotmores(mod.glmnet.xmat, predict.s=2.5) plotmores(object=mod.glmnet.xmat, predict.s=2.5) plotmo grid: survived sibsp logage 0 0 3.06991 > > mod.glmnet.agedata <- glmnet(age~., data=agedata) > expect.err(try(plotres(mod.glmnet.agedata)), "for this plot, glmnet.formula must be called with use.model.frame=TRUE") Error : for this plot, glmnet.formula must be called with use.model.frame=TRUE Got expected error from try(plotres(mod.glmnet.agedata)) > mod.glmnet.agedata <- glmnet(age~., data=agedata, use.model.frame=TRUE) > plotmores(mod.glmnet.agedata, predict.s=2.5) plotmores(object=mod.glmnet.agedata, predict.s=2.5) plotmo grid: survived sibsp logage 0 0 3.06991 > > set.seed(2015) > mod.cv.glmnet.xmat <- cv.glmnet(xmat, tit[,4], nfolds=3) > > cat("==Test plotmo trace=1 and lambda.min\n") ==Test plotmo trace=1 and lambda.min > plotmores(mod.cv.glmnet.xmat, predict.s="lambda.min", trace=1, ncol=3) plotmores(object=mod.cv.glmnet.xmat, predict.s="lambda.min", trace=1, ncol=3) stats::residuals(object=cv.glmnet.object, type="response") residuals() was unsuccessful, will use predict() instead stats::predict(cv.glmnet.object, matrix[3,3], type="response", s="lambda.min") stats::fitted(object=cv.glmnet.object) fitted() was unsuccessful, will use predict() instead got model response from getCall(object)$y graphics::plot(cv.glmnet.object) training rsq 0.29 stats::predict(cv.glmnet.object, matrix[3,3], type="response", s="lambda.min") stats::fitted(object=cv.glmnet.object) fitted() was unsuccessful, will use predict() instead got model response from getCall(object)$y plotmo grid: survived sibsp logage 0 0 3.06991 > > set.seed(2015) > mod.cv.glmnet.agedata <- cv.glmnet(age~., data=agedata) > expect.err(try(plotres(mod.cv.glmnet.agedata)), "for this plot, cv.glmnet.formula must be called with use.model.frame=TRUE") Error : for this plot, cv.glmnet.formula must be called with use.model.frame=TRUE Got expected error from try(plotres(mod.cv.glmnet.agedata)) > set.seed(2015) > mod.cv.glmnet.agedata <- cv.glmnet(age~., data=agedata, use.model.frame=TRUE) > cat("==Test lambda.min\n") ==Test lambda.min > plotmores(mod.cv.glmnet.agedata, predict.s="lambda.min", trace=1, ncol=3) plotmores(object=mod.cv.glmnet.agedata, predict.s="lambda.min", trace=1, ncol=3) stats::residuals(object=cv.glmnet.formula.object, type="response") residuals() was unsuccessful, will use predict() instead stats::predict(cv.glmnet.formula.object, data.frame[3,3], type="response", s="lambda.min") stats::fitted(object=cv.glmnet.formula.object) fitted() was unsuccessful, will use predict() instead got model response from model.frame(age ~ survived + sibsp + logage, data=call$data, na.action="na.omit") graphics::plot(cv.glmnet.formula.object) training rsq 0.33 stats::predict(cv.glmnet.formula.object, data.frame[3,3], type="response", s="lambda.min") stats::fitted(object=cv.glmnet.formula.object) fitted() was unsuccessful, will use predict() instead got model response from model.frame(age ~ survived + sibsp + logage, data=call$data, na.action="na.omit") plotmo grid: survived sibsp logage 0 0 3.06991 > > printf("======== binomial model\n") ======== binomial model > > set.seed(2016) > n <- 50 > p <- 4 > xx <- matrix(rnorm(n*p), n, p) > colnames(xx) <- paste("x", 1:ncol(xx), sep="") > yy <- ifelse(xx[,1] + xx[,2] + rnorm(n) > .5, TRUE, FALSE) > print(cov(xx, yy)) [,1] x1 0.19664644 x2 0.19303946 x3 0.11937700 x4 0.03037754 > yy <- factor(yy) > dataxy <- data.frame(yy, xx) > binomial.mod <- glmnet(xx, yy, family="binomial") > plotmores(binomial.mod, ncol=3) plotmores(object=binomial.mod, ncol=3) plotmo grid: x1 x2 x3 x4 -0.2965405 -0.03311923 0.2416254 0.01017809 > binomial.mod.form <- glmnet(yy~., data=dataxy, family="binomial", use.model.frame=TRUE) > plotmores(binomial.mod.form, ncol=3) plotmores(object=binomial.mod.form, ncol=3) plotmo grid: x1 x2 x3 x4 -0.2965405 -0.03311923 0.2416254 0.01017809 > par(org.par) > > printf("======== glmnet family=\"mgaussian\"\n") ======== glmnet family="mgaussian" > set.seed(2015) > p <- 10 > n <- 30 > xx <- cbind((1:n)/n, matrix(rnorm(n*(p-1)),n,p-1)) > colnames(xx) <- paste0("x", 1:p) > # ymultresp <- cbind(rowSums(xx[,1:5]^3), rowSums(xx[,5:p]^3), 1:n) > set.seed(1) > ymultresp <- cbind(xx[,1]+.001*rnorm(n), rowSums(xx[,2:5]^3), rnorm(n)) > glmnet.mgaussian <- glmnet(xx, ymultresp, family="mgaussian") > plotres(glmnet.mgaussian, nresponse=1, SHOWCALL=TRUE, which=c(1:3), do.par=2, info=1) > # manually calculate the residuals > plot(x=predict(glmnet.mgaussian, newx=xx, s=0)[,1,1], + y=ymultresp[,1] - predict(glmnet.mgaussian, newx=xx, s=0)[,1,1], + pch=20, xlab="Fitted", ylab="Residuals", + main="Manually calculated residuals, nresponse=1, s=0") > abline(h=0, col="gray") > par(org.par) > > # # TODO is glmnet mgaussian supported with a formula interface? > # dataxy <- data.frame(ymultresp, xx) > # colnames(dataxy) <- c("y1", "y2", "y3", "x1", "x2", "x3", "x4", "x5", "x5", "x6", "x7", "x8", "x9", "x10") > # glmnet.mgaussian.form <- glmnet(xx, ymultresp, family="mgaussian") > # plotres(glmnet.mgaussian.form, nresponse=1, SHOWCALL=TRUE, which=c(1:3), do.par=2, info=1) > > par(mfrow=c(2,3), mar=c(3,3,3,.5), oma=c(0,0,3,0), mgp=c(1.5,0.4,0), tcl=-0.3) > > data(trees) > set.seed(2015) > # variable with a long name > x50 <- cbind(trees[,1:2], Girth12345678901234567890=rnorm(nrow(trees))) > mod.with.long.name <- glmnet(data.matrix(x50),data.matrix(trees$Volume)) > plotmores(mod.with.long.name, ncol=3) plotmores(object=mod.with.long.name, ncol=3) plotmo grid: Girth Height Girth12345678901234567890 12.9 76 0.004544606 > data.x50 <- data.frame(trees$Volume, x50) > colnames(data.x50) <- c("Volume", "Girth", "Height", "Girth12345678901234567890") > mod.with.long.name.form <- glmnet(Volume~., data=data.x50, use.model.frame=TRUE) > plotmores(mod.with.long.name.form, ncol=3) plotmores(object=mod.with.long.name.form, ncol=3) plotmo grid: Girth Height Girth12345678901234567890 12.9 76 0.004544606 > par(org.par) > > #-- make sure that we can work with all families > > set.seed(2016) > par(mfrow=c(3,3), mar=c(3,3,3,1)) > n <- 100 > p <- 4 > xx <- matrix(rnorm(n*p), n, p) > g2 <- sample(1:2, n, replace=TRUE) > data.xg2 <- data.frame(g2, xx) > for(family in c("gaussian","binomial","poisson")) { + title.extra <- paste(family, ": ") + mod <- glmnet(xx,g2,family=family) + plotmores(mod, xvar="lambda", ncol=3, title.extra=title.extra) + title.extra <- paste("formula", family, ": ") + mod.form <- glmnet(g2~., data.xg2, family=family, use.model.frame=TRUE) + plotmores(mod.form, xvar="lambda", ncol=3, title.extra=title.extra) + } gaussian : plotmores(object=mod, xvar="lambda", title.extra=title.extra, ncol=3) plotmo grid: x1 x2 x3 x4 -0.2662071 0.1805768 0.03613807 0.2422419 formula gaussian : plotmores(object=mod.form, xvar="lambda", title.extra=title.extra, ncol=3) plotmo grid: X1 X2 X3 X4 -0.2662071 0.1805768 0.03613807 0.2422419 binomial : plotmores(object=mod, xvar="lambda", title.extra=title.extra, ncol=3) plotmo grid: x1 x2 x3 x4 -0.2662071 0.1805768 0.03613807 0.2422419 formula binomial : plotmores(object=mod.form, xvar="lambda", title.extra=title.extra, ncol=3) plotmo grid: X1 X2 X3 X4 -0.2662071 0.1805768 0.03613807 0.2422419 poisson : plotmores(object=mod, xvar="lambda", title.extra=title.extra, ncol=3) plotmo grid: x1 x2 x3 x4 -0.2662071 0.1805768 0.03613807 0.2422419 formula poisson : plotmores(object=mod.form, xvar="lambda", title.extra=title.extra, ncol=3) plotmo grid: X1 X2 X3 X4 -0.2662071 0.1805768 0.03613807 0.2422419 > par(org.par) > # cox > library(plotmo) > n <- 100 > p <- 20 > nzc <- trunc(p/10) > set.seed(2016) > beta <- rnorm(nzc) > x7 <- matrix(rnorm(n*p), n, p) > beta <- rnorm(nzc) > fx <- x7[,seq(nzc)] %*% beta/3 > hx <- exp(fx) > ty <- rexp(n, hx) > tcens <- rbinom(n=n, prob=.3, size=1)# censoring indicator > yy <- cbind(time=ty, status=1-tcens) # yy=Surv(ty,1-tcens) with library(survival) > glmnet.cox <- glmnet(x=x7, y=yy, family="cox") > plotmores(glmnet.cox, ncol=3, degree1=1:4) plotmores(object=glmnet.cox, degree1=1:4, ncol=3) plotmo grid: x1 x2 x3 x4 x5 x6 -0.2662071 0.1805768 0.1144668 0.2262892 0.1050429 -0.02858422 x7 x8 x9 x10 x11 x12 x13 -0.0799275 0.08172409 -0.107284 0.2036831 0.08643651 -0.0435986 0.1664937 x14 x15 x16 x17 x18 x19 x20 -0.003946797 -0.1313896 0.1714765 0.2209166 -0.2018331 -0.1230542 -0.04088624 > par(org.par) > # TODO formula interface not tested for cox models > > source("test.epilog.R") plotmo/inst/slowtests/test.fac.Rout.save0000644000176200001440000004213514563614021020136 0ustar liggesusers> # test.fac.R: test factor plotting in plotmo. This also tests swapxy, xflip, and yflip > # Stephen Milborrow, Berea Mar 2011 > > source("test.prolog.R") > library(plotmo) Loading required package: Formula Loading required package: plotrix > library(earth) > library(rpart) > data(ozone1) > data(etitanic) > > cat("==test plotmo with factors==\n") ==test plotmo with factors== > test.fac.with.rpart <- function(ngrid2=20) + { + et <- etitanic + + col.response <- as.numeric(et$sex)+2 + et$pclass.fac <- et$pclass + et$parch.int <- et$parch + parch.fac <- et$parch + parch.fac[parch.fac >= 3] <- 3 + # use non alphabetically sorted factor levels + et$parch.fac <- factor(parch.fac, labels=c( "levz", "lev1", "lev2", "levf")) + et$pclass.num <- as.numeric(et$pclass) + et$pclass <- et$sex <- et$age <- et$sibsp <- et$parch <- NULL + cat("names(et):", names(et), "\n") # survived pclass.fac parch.int parch.fac pclass.num + + old.par <- par(no.readonly=TRUE) + on.exit(par(old.par)) + par(mfrow=c(4,5)) + par(mar = c(2, 2, 3, 0.5), cex=.6) + + # numeric x numeric + a2 <- rpart(survived ~ pclass.num+parch.int, data=et) + set.seed(145) + plotmo(a2, do.par=F, type2="im", degree1=2, + col.response=col.response, pt.cex=.3) + set.seed(145) + plotmo(a2, do.par=F, type2="con", degree1=NA, + col.response=col.response, pt.cex=.3) + set.seed(145) + plotmo(a2, do.par=F, type2="persp", degree1=NA, + ngrid2=40, persp.theta=NA, persp.ticktype="d", cex.lab=.8, persp.ntick=2) + + # factor x numeric + a3 <- rpart(survived ~ pclass.fac+parch.int, data=et) + set.seed(145) + plotmo(a3, do.par=F, type2="im", + col.response=col.response, pt.cex=.3) + set.seed(145) + plotmo(a3, do.par=F, type2="con", degree1=NA, + col.response=col.response, pt.cex=.3) + + set.seed(145) + plotmo(a3, do.par=F, type2="persp", degree1=NA, + ngrid2=40, persp.theta=NA, persp.ticktype="d", persp.border=NA, cex.lab=.8, persp.ntick=2) + + # numeric x factor + a4 <- rpart(survived ~ pclass.num+parch.fac, data=et) + set.seed(145) + plotmo(a4, do.par=F, type2="im", tra=1, + col.response=col.response, pt.cex=.3) + set.seed(145) + plotmo(a4, do.par=F, type2="con", degree1=NA, + col.response=col.response, pt.cex=.3) + set.seed(145) + plotmo(a4, do.par=F, type2="persp", degree1=NA, + ngrid2=40, persp.theta=NA, persp.ticktype="d", persp.border=NA, cex.lab=.8, persp.ntick=2) + + # factor x factor + a5 <- rpart(survived ~ pclass.fac+parch.fac, data=et) + set.seed(145) + plotmo(a5, do.par=F, type2="im", nrug=TRUE, + col.response=col.response, pt.cex=.3) + set.seed(145) + plotmo(a5, do.par=F, type2="con", degree1=NA, + col.response=col.response, pt.cex=.3) + set.seed(145) + plotmo(a5, do.par=F, type2="persp", degree1=NA, + ngrid2=40, persp.theta=NA, persp.ticktype="d", persp.border=NA, cex.lab=.8, persp.ntick=2) + + # test ndiscrete + par(mfrow=c(3,5)) + par(mar = c(2, 2, 3, 0.5), cex=.6) + + plotmo(a2, do.par=F, type2="persp", degree1=2, ndiscrete=0, main="ndiscrete=0", + persp.theta=NA, persp.ticktype="d", persp.ntick=2, + col.response=col.response, pt.cex=.3) + plotmo(a2, do.par=F, type2="im", degree1=NA, ndiscrete=0) + plotmo(a2, do.par=F, type2="con", degree1=NA, ndiscrete=0) + plotmo(a2, do.par=F, type2="persp", degree1=2, degree2=NA, ndiscrete=0, main="center", center=TRUE, + col.response=col.response, pt.cex=.3) + + plotmo(a2, do.par=F, type2="persp", degree1=2, ndiscrete=3, main="ndiscrete=3", + persp.theta=NA, persp.ticktype="d", persp.ntick=2, + col.response=col.response, pt.cex=.3) + plotmo(a2, do.par=F, type2="im", degree1=NA, ndiscrete=3) + plotmo(a2, do.par=F, type2="con", degree1=NA, ndiscrete=3) + plotmo(a2, do.par=F, type2="persp", degree1=2, degree2=NA, ndiscrete=3, main="center", center=TRUE, + col.response=col.response, pt.cex=.3) + + plotmo(a2, do.par=F, type2="persp", degree1=2, ndiscrete=10, main="ndiscrete=10", + persp.theta=NA, persp.ticktype="d", persp.ntick=2, + col.response=col.response, pt.cex=.3) + plotmo(a2, do.par=F, type2="im", degree1=NA, ndiscrete=10) + plotmo(a2, do.par=F, type2="con", degree1=NA, ndiscrete=10) + plotmo(a2, do.par=F, type2="persp", degree1=2, degree2=NA, ndiscrete=10, main="center", center=TRUE, + col.response=col.response, pt.cex=.3) + } > test.fac.with.rpart() names(et): survived pclass.fac parch.int parch.fac pclass.num plotmo grid: pclass.num parch.int 2 0 plotmo grid: pclass.fac parch.int 3rd 0 stats::predict(rpart.object, data.frame[3,2], type="vector") stats::fitted(object=rpart.object) fitted() was unsuccessful, will use predict() instead got model response from model.frame(survived ~ pclass.num + parch.fac, data=call$data, na.action="na.pass") plotmo grid: pclass.num parch.fac 2 levz plotmo grid: pclass.fac parch.fac 3rd levz plotmo grid: pclass.num parch.int 2 0 Warning: forcing clip=FALSE because center=TRUE (a limitation of the current implementation) plotmo grid: pclass.num parch.int 2 0 plotmo grid: pclass.num parch.int 2 0 Warning: forcing clip=FALSE because center=TRUE (a limitation of the current implementation) plotmo grid: pclass.num parch.int 2 0 plotmo grid: pclass.num parch.int 2 0 Warning: forcing clip=FALSE because center=TRUE (a limitation of the current implementation) plotmo grid: pclass.num parch.int 2 0 > cat("==test plotmo swapxy with factors==\n") ==test plotmo swapxy with factors== > test.swapxy.with.rpart <- function(ngrid2=20) + { + et <- etitanic[c(1:50,300:350,600:650),] + + col.response <- as.numeric(et$sex)+2 + et$pclass.fac <- et$pclass + et$parch.int <- et$parch + parch.fac <- et$parch + parch.fac[parch.fac > 2] <- 2 + # use non alphabetically sorted factor levels + et$parch.fac <- factor(parch.fac, labels=c("lev.zero", "lev.one", "lev.two.or.more")) + print(et$parch.fac) + et$pclass.num <- as.numeric(et$pclass) + et$pclass <- et$sex <- et$age <- et$sibsp <- et$parch <- NULL + cat("names(et):", names(et), "\n") # survived pclass.fac parch.int parch.fac pclass.num + + old.par <- par(no.readonly=TRUE) + on.exit(par(old.par)) + par(mfrow=c(4,4)) + par(mar = c(2, 3, 5, 0.5), cex=.6) + + # factor x factor + a5 <- rpart(survived ~ pclass.fac+parch.fac, data=et) + for(swapxy in c(F,T)) { + for(xflip in c(F,T)) + for(yflip in c(F,T)) { + set.seed(145) + plotmo(a5, do.par=F, type2="im", degree1=NA, + swapxy=swapxy, xflip=xflip, yflip=yflip, + main=paste("swapxy=", swapxy, "\nxflip=", xflip, "\nyflip=", yflip), + col.response=col.response, pt.cex=3, + pt.pch=".") + set.seed(145) + plotmo(a5, do.par=F, type2="con", degree1=NA, + swapxy=swapxy, xflip=xflip, yflip=yflip, + main=paste("swapxy=", swapxy, "\nxflip=", xflip, "\nyflip=", yflip), + col.response=col.response, pt.cex=.3) + } + } + par(mfrow=c(2,2)) + set.seed(146) + plotmo(a5, do.par=F, type2="persp", degree1=NA, + swapxy=FALSE, main=paste("swapxy=", FALSE), + ngrid2=40, persp.theta=145, persp.ticktype="d", cex.lab=.8, persp.ntick=5) + set.seed(146) + plotmo(a5, do.par=F, type2="persp", degree1=NA, + swapxy=TRUE, main=paste("swapxy=", TRUE), + ngrid2=40, persp.theta=145, persp.ticktype="d", cex.lab=.8, persp.ntick=5) + set.seed(146) + plotmo(a5, do.par=F, type2="im", degree1=2, + swapxy=FALSE, main=paste("swapxy=", FALSE)) + } > test.swapxy.with.rpart() [1] lev.zero lev.two.or.more lev.two.or.more lev.two.or.more [5] lev.two.or.more lev.zero lev.zero lev.zero [9] lev.zero lev.zero lev.zero lev.zero [13] lev.zero lev.zero lev.zero lev.one [17] lev.one lev.zero lev.zero lev.one [21] lev.one lev.zero lev.zero lev.zero [25] lev.zero lev.zero lev.zero lev.zero [29] lev.zero lev.zero lev.zero lev.zero [33] lev.zero lev.zero lev.zero lev.one [37] lev.zero lev.zero lev.zero lev.zero [41] lev.zero lev.zero lev.zero lev.zero [45] lev.zero lev.one lev.one lev.zero [49] lev.zero lev.zero lev.zero lev.one [53] lev.one lev.one lev.two.or.more lev.zero [57] lev.zero lev.zero lev.zero lev.zero [61] lev.zero lev.zero lev.two.or.more lev.one [65] lev.one lev.zero lev.zero lev.zero [69] lev.zero lev.zero lev.zero lev.two.or.more [73] lev.one lev.one lev.zero lev.zero [77] lev.zero lev.zero lev.zero lev.zero [81] lev.zero lev.one lev.two.or.more lev.zero [85] lev.zero lev.zero lev.zero lev.zero [89] lev.two.or.more lev.one lev.one lev.zero [93] lev.zero lev.zero lev.one lev.zero [97] lev.two.or.more lev.zero lev.zero lev.zero [101] lev.zero lev.zero lev.zero lev.zero [105] lev.one lev.one lev.one lev.two.or.more [109] lev.zero lev.zero lev.zero lev.zero [113] lev.one lev.one lev.zero lev.zero [117] lev.zero lev.zero lev.zero lev.zero [121] lev.zero lev.zero lev.zero lev.zero [125] lev.one lev.one lev.one lev.one [129] lev.zero lev.zero lev.zero lev.zero [133] lev.zero lev.zero lev.zero lev.zero [137] lev.zero lev.zero lev.zero lev.zero [141] lev.zero lev.zero lev.zero lev.zero [145] lev.zero lev.zero lev.zero lev.zero [149] lev.zero lev.zero lev.zero lev.zero Levels: lev.zero lev.one lev.two.or.more names(et): survived pclass.fac parch.int parch.fac pclass.num plotmo grid: pclass.fac parch.fac 2nd lev.zero > > aflip <- earth(O3~vh + wind + humidity + temp, data=ozone1, degree=2) > col.response<- ifelse(ozone1$O3 == 38, "red", "pink") > > # test xflip arg, degree1 plots > par(mfrow=c(2,2)) > set.seed(102) > plotmo(aflip, degree1=1:2, degree2=0, do.par=F, col.response=col.response, nrug=-1, ylab="O3", smooth.col="gray") plotmo grid: vh wind humidity temp 5760 5 64 62 > plotmo(aflip, degree1=1:2, degree2=F, do.par=F, col.response=col.response, nrug=-1, ylab="O3", xflip=T, main="xflip=TRUE, degree1 plots", , smooth.col="gray") plotmo grid: vh wind humidity temp 5760 5 64 62 > > col.response<- ifelse(ozone1$O3 == 1, "green", "pink") > > # test flip args, type2=persp > par(mfrow=c(2,2)) > plotmo(aflip, degree1=0, degree2=2, do.par=F, persp.ticktype="d") > plotmo(aflip, degree1=0, degree2=2, do.par=F, persp.tickt="d", swapxy=T, main="swapxy=TRUE") > plot(0, 0, type="n", axes=FALSE, xlab="", ylab="") > plot(0, 0, type="n", axes=FALSE, xlab="", ylab="") > > # test swapxy args, type2=image > par(mfrow=c(3,3)) > > plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="im", col.response=col.response, main="test swapxy on image plots\nreference plot") > plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="im", col.response=col.response, swapxy=T, main="swapxy=T") > plot(0, 0, type="n", axes=FALSE, xlab="", ylab="") > > plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="im", col.response=col.response, xflip=T, main="xflip=T") > plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="im", col.response=col.response, yflip=T, main="yflip=T") > plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="im", col.response=col.response, xflip=T, yflip=T, main="xflip=T, yflip=T") > > plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="im", col.response=col.response, swapxy=T, xflip=T, main="swapxy=T, xflip=T") > plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="im", col.response=col.response, swapxy=T, yflip=T, main="swapxy=T, yflip=T") > plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="im", col.response=col.response, swapxy=T, xflip=T, yflip=T, main="swapxy=T, xflip=T, yflip=T") > > # test flip args, type2=contour > plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="con", col.response=col.response, main="test flip on contour plots\nreference plot") > plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="con", col.response=col.response, swapxy=T) > plot(0, 0, type="n", axes=FALSE, xlab="", ylab="") > > plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="con", col.response=col.response, xflip=T) > plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="con", col.response=col.response, yflip=T) > plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="con", col.response=col.response, xflip=T, yflip=T) > > plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="con", col.response=col.response, swapxy=T, xflip=T) > plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="con", col.response=col.response, swapxy=T, yflip=T) > plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="con", col.response=col.response, swapxy=T, xflip=T, yflip=T) > > # ordered factor > > cat("==test plotmo with ordered factor==\n") ==test plotmo with ordered factor== > par(mfcol=c(2,2)) > par(mar=c(3, 3, 3, 1)) > par(mgp=c(1.5, .5, 0)) > a <- lm(height~., data=Loblolly) > termplot(a, partial.resid=T, rug=T, terms=2, main="Seed is an ordered factor") # compare to termplot > plotmo(a, do.par=F, col.resp="gray", nrug=T, all2=T) plotmo grid: age Seed 12.5 329 > > #--------------------------------------------------------------------------- > # test ndiscrete with integer and non integer predictors, with missing values > > par(mfcol=c(2,4)) > par(mar=c(3, 3, 3, 1)) > par(mgp=c(1.5, .5, 0)) > et <- etitanic > et$var <- et$parch > et$var[et$var==1] <- 0 # want a "hole" in var's value, for testing > et$var[1:3] <- 6 > cat("table(et$var):") table(et$var):> print(table(et$var)) 0 2 3 4 5 6 927 95 8 5 6 5 > cat("\n") > a <- earth(survived~var+age, data=et, degree=2, pm="none") > > plotmo(a, trace=FALSE, ndiscrete=0, + main="integral var\n(var levels are 0 2 3 4 5 6)\nndiscrete=0", cex.lab=.8, + do.par=F, smooth.col="indianred", persp.ticktype="d", clip=F, degree1=0, persp.theta=40) > > plotmo(a, ndiscrete=0, + do.par=F, smooth.col="indianred", ylim=c(-.5,1), degree2=0, degree1=1) plotmo grid: var age 0 28 > > #------------ > plotmo(a, ndiscrete=10, main="integral var\nndiscrete=10", cex.lab=.8, + do.par=F, smooth.col="indianred", persp.ticktype="d", clip=F, degree1=0, persp.theta=40) > > plotmo(a, trace=0, ndiscrete=10, + do.par=F, smooth.col="indianred", ylim=c(-.5,1), degree2=0, degree1=1) plotmo grid: var age 0 28 > > #------------ > et$var <- et$var / 2 > cat("table(et$var):") table(et$var):> print(table(et$var)) 0 1 1.5 2 2.5 3 927 95 8 5 6 5 > cat("\n") > a <- earth(survived~var+age, data=et, degree=2, pm="none") > > plotmo(a, ndiscrete=0, + main="integral var\n(var levels are 0 1 1.5 2 2.5 3)\nndiscrete=0", cex.lab=.8, + do.par=F, smooth.col="indianred", persp.ticktype="d", clip=F, degree1=0, persp.theta=40) > > plotmo(a, ndiscrete=0, + do.par=F, smooth.col="indianred", ylim=c(-.5,1), degree2=0, degree1=1) plotmo grid: var age 0 28 > > #------------ > plotmo(a, ndiscrete=10, main="non integral var\nndiscrete=10", cex.lab=.8, + do.par=F, smooth.col="indianred", persp.ticktype="d", clip=F, degree1=0, persp.theta=40) > > plotmo(a, ndiscrete=10, + do.par=F, smooth.col="indianred", ylim=c(-.5,1), degree2=0, degree1=1) plotmo grid: var age 0 28 > > source("test.epilog.R") plotmo/inst/slowtests/test.plotmo.dots.Rout.save0000644000176200001440000000711314567071010021663 0ustar liggesusers> # test.dots.plotmo.R: test dots functions with the plotmo and earth libraries > > source("test.prolog.R") > library(plotmo) Loading required package: Formula Loading required package: plotrix > library(earth) > data(ozone1) > options(warn=1) # print warnings as they occur > > a <- earth(O3~., data=ozone1, degree=2) > expect.err(try(plotmo(a, persp.s=99)), "'s' matches both the 'sub' and 'scale' arguments of persp()") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 Error : 's' matches both the 'sub' and 'scale' arguments of persp() Got expected error from try(plotmo(a, persp.s = 99)) > > # Commented out because we now silently drop partial plot args like cex.l > # expect.err(try(plotmo(a, cex.l=.8, cex.la=.9)), "arguments 'cex.l' and 'cex.la' both match 'cex.lab' in draw.plot_degree1") > # expect.err(try(plotmo(a, persp.shad=1, persp.sh=2)), "'persp.shad' and 'persp.sh' both match the 'shade' argument of persp()") > > options(warn=2) # treat warnings as errors > > # Commented out because we now silently drop partial plot args like cex.l > # expect.err(try(plotmo(a, cex.l=.8)), "\"cex.l\" is not a graphical parameter") > # expect.err(try(plotmo(a, cex.lxx=.8)), "\"cex.lxx\" is not a graphical parameter") > # expect.err(try(plotmo(a, cex.labx=.8)), "\"cex.labx\" is not a graphical parameter") > # expect.err(try(plotmo(a, cex.l=.8, cex.lab=.9)), "\"cex.l\" is not a graphical parameter") > > expect.err(try(plotmo(a, nonesuch=.8)), "predict.earth ignored argument 'nonesuch'") stats::predict(earth.object, NULL, type="response", nonesuch=0.8) Error : (converted from warning) predict.earth ignored argument 'nonesuch' Got expected error from try(plotmo(a, nonesuch = 0.8)) > expect.err(try(plotmo(a, lw=2)), "predict.earth ignored argument 'lw'") stats::predict(earth.object, NULL, type="response", lw=2) Error : (converted from warning) predict.earth ignored argument 'lw' Got expected error from try(plotmo(a, lw = 2)) > options(warn=1) > > # test main, xlab, ylab, etc. arguments with recycling > a <- earth(O3~., data=ozone1, degree=2) > plotmo(a, caption="test main, xlab, ylab, ticktype arguments", + main=c("main1", "main2", "main3", "main4"), xlab=c("x1", "x2"), + persp.nticks=2, persp.ticktype="d", ylab=c("y1", "y2", "y3")) plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > > par(mfrow=c(2,2), mar = c(3,3,3,1), mgp = c(1.5,.5,0), oma=c(0,0,4,0)) > plotmo(a, trace=1, do.par=FALSE, degree1=1, degree2=1, caption="top: standard\nbottom: lwd=2 thresh=.9") # no errors or warnings stats::predict(earth.object, NULL, type="response") stats::fitted(object=earth.object) got model response from model.frame(O3 ~ vh + wind + humidity + temp + ib..., data=call$data, na.action="na.fail") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > plotmo(a, lwd=2, trace=1, thresh=.9, do.par=FALSE, degree1=1, degree2=1) # no errors or warnings stats::predict(earth.object, NULL, type="response", thresh=0.9) stats::fitted(object=earth.object) got model response from model.frame(O3 ~ vh + wind + humidity + temp + ib..., data=call$data, na.action="na.fail") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > > source("test.epilog.R") plotmo/inst/slowtests/test.mlr.Rout.save0000644000176200001440000011065114567065443020212 0ustar liggesusers> # test.mlr.R: test the "mlr" package with plotmo and plotres > # > # TODO mlr is in maintenance mode, add mlr3 support to plotmo? > # TODO generally, plotres residuals for WrappedModel prob models aren't right > > source("test.prolog.R") > library(mlr) Loading required package: ParamHelpers Warning message: 'mlr' is in 'maintenance-only' mode since July 2019. Future development will only happen in 'mlr3' (). Due to the focus on 'mlr3' there might be uncaught bugs meanwhile in {mlr} - please consider switching. > library(plotmo) Loading required package: Formula Loading required package: plotrix > library(rpart.plot) Loading required package: rpart > library(earth) > # TODO following function is temporary until mlr package is updated > train.with.call <- function(learner, task, subset=NULL, weights=NULL) + { + retval <- train(learner, task, subset, weights) + retval$call <- match.call() + retval + } > > cat("==simple one variable regression model with earth ===============================\n") ==simple one variable regression model with earth =============================== > > data(trees) > trees1 <- trees[,c("Volume", "Girth")] > > task <- makeRegrTask(data=trees1, target="Volume") > lrn <- makeLearner("regr.earth", degree=2) > regr.earth.with.call = train.with.call(lrn, task) > regr.earth = train(lrn, task) > earth <- earth(Volume~., data=trees1, degree=2) > > # SHOWCALL is just a testing thing, so we can see who created the plot on the plot itself > plotres(regr.earth.with.call, SHOWCALL=TRUE) > plotres(regr.earth$learner.model, SHOWCALL=TRUE) > plotres(earth, SHOWCALL=TRUE) > > plotmo(regr.earth.with.call, trace=1, SHOWCALL=TRUE) stats::fitted(object=WrappedModel.object) fitted() was unsuccessful, will use predict() instead got model response from object$y > plotmo(regr.earth$learner.model, trace=1, SHOWCALL=TRUE) stats::predict(earth.object, NULL, type="response") stats::fitted(object=earth.object) got model response from model.frame(Volume ~ Girth, data=call$data, na.action="na.fail") > plotmo(earth, trace=1, SHOWCALL=TRUE) stats::predict(earth.object, NULL, type="response") stats::fitted(object=earth.object) got model response from model.frame(Volume ~ Girth, data=call$data, na.action="na.fail") > > # compare partial dependence plots from mlr and plotmo packages > set.seed(2018) > plotmo(earth, pmethod="partdep", SHOWCALL=TRUE, col=2, pt.col="darkgray", grid.col="lightgray") calculating partdep for Girth > set.seed(2018) > pd <- generatePartialDependenceData(regr.earth, task, "Girth", n=c(50, NA)) Loading required package: mmpf > print(plotPartialDependence(pd, data = getTaskData(task))) Warning in grid.Call.graphics(C_points, x$x, x$y, x$pch, x$size) : semi-transparency is not supported on this device: reported only once per page > > cat("==test error handling if original data is messed up===========================\n") ==test error handling if original data is messed up=========================== > > par(mfrow=c(4,2), mar=c(1.5,2.5,4,1), oma=c(0,0,0,0)) > colnames(trees1) <- c("nonesuch", "Volume") > plotmo(regr.earth$learner.model, do.par=0, degree1=1, degree2=0, main='colnames(trees1) <- c("nonesuch", "Volume")') > plotmo(regr.earth.with.call, do.par=0, degree1=1, degree2=0) > par(org.par) > expect.err(try(plotmo(earth, degree1=1, degree2=0)), "cannot get the original model predictors") Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: object 'Girth' not found (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(plotmo(earth, degree1 = 1, degree2 = 0)) > > cat("==regression model with randomForest (binary response)============================\n") ==regression model with randomForest (binary response)============================ > > library(randomForest) randomForest 4.7-1.1 Type rfNews() to see new features/changes/bug fixes. > library(earth) # for etitanic data > data(etitanic) > set.seed(2018) > # use a logical subset (since we test for numeric subset elsewhere) > # use a small subset so we can see easily if subset is applied or ignored in plots > train.subset <- rnorm(nrow(etitanic)) > 1 # 166 cases ((16% of 1046 cases)) > printf("sum(train.subset) %g (%.0f%% of %g cases)\n", sum(train.subset), + 100 * sum(train.subset) / nrow(etitanic), nrow(etitanic)) sum(train.subset) 166 (16% of 1046 cases) > task.regr.rf <- makeRegrTask(data=etitanic, target="survived") > lrn.regr.rf = makeLearner("regr.randomForest") > set.seed(2018) > regr.rf.with.call = train.with.call(lrn.regr.rf, task.regr.rf, subset=train.subset) Warning in randomForest.default(x = data[["data"]], y = data[["target"]], : The response has five or fewer unique values. Are you sure you want to do regression? > set.seed(2018) > rf <- randomForest(survived~., data=etitanic, subset=train.subset) Warning in randomForest.default(m, y, ...) : The response has five or fewer unique values. Are you sure you want to do regression? > # sanity check that the models are identical > stopifnot(identical(predict(regr.rf.with.call$learner.model), predict(rf))) > > plotres(regr.rf.with.call, info=TRUE, SHOWCALL=TRUE) > # plotres(regr.rf$learner.model, info=TRUE, SHOWCALL=TRUE) # Error: no formula in getCall(object) > plotres(rf, info=TRUE, SHOWCALL=TRUE) > > set.seed(2018) # for repeatable jitter in points (specified with pt.col) > plotmo(regr.rf.with.call, pt.col=2, SHOWCALL=TRUE) plotmo grid: pclass sex age sibsp parch 3rd male 29 0 0 > # plotmo(regr.rf$learner.model, trace=1, SHOWCALL=TRUE) # Error: no formula in getCall(object) > set.seed(2018) > plotmo(rf, pt.col=2, SHOWCALL=TRUE) plotmo grid: pclass sex age sibsp parch 3rd male 29 0 0 > > # compare partial dependence plots > set.seed(2018) > plotmo(regr.rf.with.call, degree1="age", degree2=0, pmethod="partdep", + grid.col="gray", col=2, pt.col="darkgray", SHOWCALL=TRUE) calculating partdep for age > # function from randomForest package > set.seed(2018) > partialPlot(rf, pred.data=etitanic[train.subset,], x.var="age", n.pt=50, ylim=c(0, 1)) > grid() > # function from mlr package > set.seed(2018) > pd <- generatePartialDependenceData(regr.rf.with.call, task.regr.rf, "age", n=c(50, NA)) > print(plotPartialDependence(pd, data = getTaskData(task.regr.rf))) Warning in grid.Call.graphics(C_points, x$x, x$y, x$pch, x$size) : semi-transparency is not supported on this device: reported only once per page > > plotmo(regr.rf.with.call, degree1="pclass", degree2=0, pmethod="partdep", SHOWCALL=TRUE) calculating partdep for pclass > set.seed(2018) > # function from randomForest package > set.seed(2018) > partialPlot(rf, pred.data=etitanic[train.subset,], x.var="pclass", n.pt=50, ylim=c(0, 1)) > grid() > # TODO following fails > pd <- generatePartialDependenceData(regr.rf.with.call, task.regr.rf, "pclass", n=c(50, NA)) > try(print(plotPartialDependence(pd, data = getTaskData(task.regr.rf)))) # Error: Discrete value supplied to continuous scale Error in train_continuous(x, self$range) : Discrete value supplied to a continuous scale > > cat("==classification model with randomForest (binary response)======================\n") ==classification model with randomForest (binary response)====================== > > set.seed(2018) > library(earth) # for etitanic data > data(etitanic) > etit <- etitanic > etit$survived <- factor(etit$survived, labels=c("notsurvived", "survived")) > > task.classif.rf <- makeClassifTask(data=etit, target="survived") > lrn.classif.rf <- makeLearner("classif.randomForest", predict.type="prob") > set.seed(2018) > classif.rf.with.call <- train.with.call(lrn.classif.rf, task.classif.rf, , subset=train.subset) > set.seed(2018) > rf <- randomForest(survived~., data=etit, method="class", subset=train.subset) > # sanity check that the models are identical > stopifnot(identical(predict(classif.rf.with.call$learner.model), predict(rf))) > > # TODO following causes Error: classif.earth: Setting parameter glm without available description object > # lrn <- makeLearner("classif.earth", degree=2, glm=list(family=binomial)) > > # TODO residuals on WrappedModel don't match direct call to rf model > set.seed(2018) # for repeatable jitter > plotres(classif.rf.with.call, nresponse="prob.survived", SHOWCALL=TRUE, jitter=2) > set.seed(2018) > plotres(classif.rf.with.call$learner.model, type="prob", SHOWCALL=TRUE, jitter=2) > set.seed(2018) > plotres(rf, type="prob", SHOWCALL=TRUE, jitter=2) > > options(warn=2) # treat warnings as errors > expect.err(try(plotmo(classif.rf.with.call)), "Defaulting to nresponse=1, see above messages") predict.WrappedModel[3,3]: prob.notsurvived prob.survived response 5 0.466 0.534 survived 7 0.358 0.642 survived 22 0.028 0.972 survived response is a factor with levels: notsurvived survived predict.WrappedModel returned multiple columns (see above) but nresponse is not specified Use the nresponse argument to specify a column. Example: nresponse=2 Example: nresponse="prob.survived" Error : (converted from warning) Defaulting to nresponse=1, see above messages Got expected error from try(plotmo(classif.rf.with.call)) > options(warn=1) > set.seed(2018) # for repeatable jitter > plotmo(classif.rf.with.call, SHOWCALL=TRUE, nresponse="prob.survived", pt.col=2, trace=2) plotmo trace 2: plotmo(object=classif.rf.with.call, nresponse="prob.survived", pt.col=2, trace=2, SHOWCALL=TRUE) --get.model.env for object with class WrappedModel object call is train.with.call(learner=lrn.classif.rf, task=task.classif.rf, subset=train.subset) assuming the environment of the WrappedModel model is that of plotmo's caller: R_GlobalEnv --plotmo_prolog for WrappedModel object 'classif.rf.with.call' task$task.desc$id for 'classif.rf.with.call' is "etit" --plotmo_prolog for randomForest.formula object object$learner.model Done recursive call in plotmo.prolog for learner.model --plotmo_x for WrappedModel object get.object.x: object$x is usable and has column names pclass sex age sibsp parch plotmo_x returned[166,5]: pclass sex age sibsp parch 5 1st female 25 1 2 7 1st female 63 1 0 22 1st female 47 1 1 ... 1st female 29 0 0 1288 3rd male 51 0 0 factors: pclass sex ----Metadata: plotmo_predict with nresponse=NULL and newdata=NULL plotmo_predict with NULL newdata (nrows=3), using plotmo_x to get the data --plotmo_x for WrappedModel object get.object.x: object$x is usable and has column names pclass sex age sibsp parch plotmo_x returned[166,5]: pclass sex age sibsp parch 5 1st female 25 1 2 7 1st female 63 1 0 22 1st female 47 1 1 ... 1st female 29 0 0 1288 3rd male 51 0 0 factors: pclass sex will use the above data instead of newdata=NULL for predict.WrappedModel predict returned[3,3]: prob.notsurvived prob.survived response 5 0.466 0.534 survived 7 0.358 0.642 survived 22 0.028 0.972 survived response is a factor with levels: notsurvived survived predict after processing with nresponse=NULL is [3,3]: prob.notsurvived prob.survived response 5 0.466 0.534 survived 7 0.358 0.642 survived 22 0.028 0.972 survived response is a factor with levels: notsurvived survived ----Metadata: plotmo_fitted with nresponse=NULL stats::fitted(object=WrappedModel.object) fitted() was unsuccessful, will use predict() instead plotmo_predict with NULL newdata, using plotmo_x to get the data --plotmo_x for WrappedModel object get.object.x: object$x is usable and has column names pclass sex age sibsp parch plotmo_x returned[166,5]: pclass sex age sibsp parch 5 1st female 25 1 2 7 1st female 63 1 0 22 1st female 47 1 1 ... 1st female 29 0 0 1288 3rd male 51 0 0 factors: pclass sex will use the above data instead of newdata=NULL for predict.WrappedModel predict returned[166,3]: prob.notsurvived prob.survived response 5 0.466 0.534 survived 7 0.358 0.642 survived 22 0.028 0.972 survived ... 0.032 0.968 survived 1288 0.906 0.094 notsurvived response is a factor with levels: notsurvived survived predict after processing with nresponse=NULL is [166,3]: prob.notsurvived prob.survived response 5 0.466 0.534 survived 7 0.358 0.642 survived 22 0.028 0.972 survived ... 0.032 0.968 survived 1288 0.906 0.094 notsurvived response is a factor with levels: notsurvived survived got fitted values by calling predict (see above) ----Metadata: plotmo_y with nresponse=NULL --plotmo_y with nresponse=NULL for WrappedModel object get.object.y: object$y is usable and has column name survived plotmo_y returned[166,1]: survived 5 notsurvived 7 survived 22 survived ... survived 1288 notsurvived survived is a factor with levels: notsurvived survived plotmo_y after processing with nresponse=NULL is [166,1]: survived 5 notsurvived 7 survived 22 survived ... survived 1288 notsurvived survived is a factor with levels: notsurvived survived converted nresponse="prob.survived" to nresponse=2 nresponse=2 (was "prob.survived") ncol(fitted) 3 ncol(predict) 1 ncol(y) 1 ----Metadata: plotmo_y with nresponse=2 nresponse=2 but for plotmo_y using nresponse=1 because ncol(y) == 1 --plotmo_y with nresponse=1 for WrappedModel object get.object.y: object$y is usable and has column name survived got model response from object$y the response is a factor but could not get the family of the WrappedModel model plotmo_y returned[166,1]: survived 5 notsurvived 7 survived 22 survived ... survived 1288 notsurvived survived is a factor with levels: notsurvived survived converted to numeric from factor with levels "notsurvived" "survived" plotmo_y after processing with nresponse=1 is [166,1]: survived 1 1 2 2 3 2 ... 2 166 1 got response name "prob.survived" from yhat got resp.levs from yfull response levels: notsurvived survived ----Metadata: done number of x values: pclass 3 sex 2 age 60 sibsp 5 parch 5 ----plotmo_singles for WrappedModel object randomForest built with importance=FALSE, ranking variables on MeanDecreaseGini plotmo.singles(object$learner.model) succeeded singles: 1 pclass, 2 sex, 3 age, 4 sibsp, 5 parch ----plotmo_pairs for WrappedModel object plotmo.pairs(object$learner.model) succeeded pairs: [,1] [,2] [1,] "1 pclass" "2 sex" [2,] "1 pclass" "3 age" [3,] "1 pclass" "4 sibsp" [4,] "1 pclass" "5 parch" [5,] "2 sex" "3 age" [6,] "2 sex" "4 sibsp" [7,] "2 sex" "5 parch" [8,] "3 age" "4 sibsp" [9,] "3 age" "5 parch" [10,] "4 sibsp" "5 parch" graphics::par(mfrow=c(4,4), mgp=c(1.5,0.4,0), tcl=-0.3, font.main=2, mar=c(3,2,1.2,0.8), oma=c(0,0,4,0), cex.main=1.1, cex.lab=1, cex.axis=1, cex=0.66) ----Figuring out ylim ylim c(-0.1, 1.1) clip TRUE --plot.degree1(draw.plot=TRUE) plotmo grid: pclass sex age sibsp parch 3rd male 29 0 0 degree1 plot1 (pmethod "plotmo") variable pclass newdata[3,5]: pclass sex age sibsp parch 1 1st male 29 0 0 2 2nd male 29 0 0 3 3rd male 29 0 0 factors: pclass sex predict returned[3,3]: prob.notsurvived prob.survived response 1 0.872 0.128 notsurvived 2 0.904 0.096 notsurvived 3 0.928 0.072 notsurvived response is a factor with levels: notsurvived survived predict returned[3,1] after selecting nresponse=2: prob.survived 1 0.128 2 0.096 3 0.072 predict after processing with nresponse=2 is [3,1]: prob.survived 1 0.128 2 0.096 3 0.072 graphics::plot.default(x=factor.object, y=c(0.128,0.096,0...), type="n", main="1 pclass", xlab="", ylab="", xaxt="n", yaxt="s", xlim=c(0.6,3.4), ylim=c(-0.1,1.1)) Will shift and scale displayed points specified by pt.col: yshift -1 yscale 1 graphics::plot(x=factor.object, y=c(0.128,0.096,0...), xaxt="n", yaxt="s", add=TRUE, lty=1, lwd=1) Reducing trace level for subsequent degree1 plots degree1 plot2 (pmethod "plotmo") variable sex Will shift and scale displayed points specified by pt.col: yshift -1 yscale 1 degree1 plot3 (pmethod "plotmo") variable age Will shift and scale displayed points specified by pt.col: yshift -1 yscale 1 degree1 plot4 (pmethod "plotmo") variable sibsp Will shift and scale displayed points specified by pt.col: yshift -1 yscale 1 degree1 plot5 (pmethod "plotmo") variable parch Will shift and scale displayed points specified by pt.col: yshift -1 yscale 1 --plot.degree2(draw.plot=TRUE) degree2 plot1 (pmethod "plotmo") variables pclass:sex newdata[6,5]: pclass sex age sibsp parch 1 1st female 29 0 0 2 2nd female 29 0 0 3 3rd female 29 0 0 ... 1st male 29 0 0 6 3rd male 29 0 0 factors: pclass sex predict returned[6,3]: prob.notsurvived prob.survived response 1 0.032 0.968 survived 2 0.098 0.902 survived 3 0.890 0.110 notsurvived ... 0.872 0.128 notsurvived 6 0.928 0.072 notsurvived response is a factor with levels: notsurvived survived predict returned[6,1] after selecting nresponse=2: prob.survived 1 0.968 2 0.902 3 0.110 ... 0.128 6 0.072 predict after processing with nresponse=2 is [6,1]: prob.survived 1 0.968 2 0.902 3 0.110 ... 0.128 6 0.072 persp(pclass:sex) theta 145 Reducing trace level for subsequent degree2 plots degree2 plot2 (pmethod "plotmo") variables pclass:age persp(pclass:age) theta 235 degree2 plot3 (pmethod "plotmo") variables pclass:sibsp persp(pclass:sibsp) theta 55 degree2 plot4 (pmethod "plotmo") variables pclass:parch persp(pclass:parch) theta 55 degree2 plot5 (pmethod "plotmo") variables sex:age persp(sex:age) theta 145 degree2 plot6 (pmethod "plotmo") variables sex:sibsp persp(sex:sibsp) theta 55 degree2 plot7 (pmethod "plotmo") variables sex:parch persp(sex:parch) theta 55 degree2 plot8 (pmethod "plotmo") variables age:sibsp persp(age:sibsp) theta 145 degree2 plot9 (pmethod "plotmo") variables age:parch persp(age:parch) theta 145 degree2 plot10 (pmethod "plotmo") variables sibsp:parch persp(sibsp:parch) theta 55 > set.seed(2018) > plotmo(classif.rf.with.call$learner.model, SHOWCALL=TRUE, type="prob", pt.col=2) plotmo grid: pclass sex age sibsp parch 3rd male 29 0 0 > set.seed(2018) > # note that in the following, get.y.shift.scale (in plotmo code) rescales the plotted y to 0..1 > plotmo(rf, SHOWCALL=TRUE, type="prob", pt.col="gray") plotmo grid: pclass sex age sibsp parch 3rd male 29 0 0 > set.seed(2018) > # in following graph, note that get.y.shift.scale doesn't rescale the plotted y because ylim=c(0,2) > plotmo(rf, SHOWCALL=TRUE, type="prob", ylim=c(0,2), pt.col="gray") plotmo grid: pclass sex age sibsp parch 3rd male 29 0 0 > > # compare partial dependence plots > set.seed(2018) > plotmo(rf, type="prob", degree1="pclass", degree2=0, pmethod="partdep", pt.col=2, SHOWCALL=TRUE) calculating partdep for pclass > set.seed(2018) > plotmo(rf, degree1="pclass", degree2=0, pmethod="partdep", pt.col=2, SHOWCALL=TRUE) calculating partdep for pclass > set.seed(2018) > # TODO following fails > pd <- generatePartialDependenceData(classif.rf.with.call, task.classif.rf, "pclass", n=c(50, NA)) > try(print(plotPartialDependence(pd, data = getTaskData(task.classif.rf)))) # Error: Discrete value supplied to continuous scale Error in train_continuous(x, self$range) : Discrete value supplied to a continuous scale > > plotmo(rf, type="prob", nresponse="notsurvived", degree1="age", degree2=0, + pmethod="partdep", ylim=c(.3,.75), nrug=TRUE, grid.col="gray") # looks plausible calculating partdep for age > set.seed(2018) > pd <- generatePartialDependenceData(classif.rf.with.call, task.classif.rf, "age", n=c(50, NA)) > print(plotPartialDependence(pd, data = getTaskData(task.classif.rf))) Warning in grid.Call.graphics(C_segments, x$x0, x$y0, x$x1, x$y1, x$arrow) : semi-transparency is not supported on this device: reported only once per page > > cat("==examples from plotmo-notes.pdf ===============================================\n") ==examples from plotmo-notes.pdf =============================================== > > #-- Regression model with mlr ------------------------------------------- > > library(mlr) > library(plotmo) > lrn <- makeLearner("regr.svm") > fit1.with.call <- train.with.call(lrn, bh.task) > fit1 <- train(lrn, bh.task) > > # generate partial dependence plots for all variables > # we use "apartdep" and not "partdep" to save testing time > plotmo(fit1.with.call, pmethod="apartdep") calculating apartdep for crim calculating apartdep for zn calculating apartdep for indus calculating apartdep for chas calculating apartdep for nox calculating apartdep for rm calculating apartdep for age calculating apartdep for dis calculating apartdep for rad calculating apartdep for tax calculating apartdep for ptratio calculating apartdep for b calculating apartdep for lstat > plotmo(fit1$learner.model, pmethod="apartdep") calculating apartdep for crim calculating apartdep for zn calculating apartdep for indus calculating apartdep for chas calculating apartdep for nox calculating apartdep for rm calculating apartdep for age calculating apartdep for dis calculating apartdep for rad calculating apartdep for tax calculating apartdep for ptratio calculating apartdep for b calculating apartdep for lstat > > # generate partial dependence plot for just "lstat" > set.seed(2018) # so slight jitter on pt.col points in plotmo doesn't change across test runs > plotmo(fit1.with.call, + degree1="lstat", # what predictor to plot + degree2=0, # no interaction plots + pmethod="partdep", # generate partial dependence plot + pt.col=2, grid.col="gray", # optional bells and whistles + nrug=TRUE) # rug ticks along the bottom calculating partdep for lstat > set.seed(2018) # so slight jitter on pt.col points in plotmo doesn't change across test runs > plotmo(fit1$learner.model, + degree1="lstat", # what predictor to plot + degree2=0, # no interaction plots + pmethod="partdep", # generate partial dependence plot + pt.col=2, grid.col="gray", # optional bells and whistles + nrug=TRUE) # rug ticks along the bottom calculating partdep for lstat > > # compare to the function provided by the mlr package > set.seed(2018) > pd <- generatePartialDependenceData(fit1, bh.task, "lstat", n=c(50, NA)) > print(plotPartialDependence(pd, data = getTaskData(bh.task))) Warning in grid.Call.graphics(C_points, x$x, x$y, x$pch, x$size) : semi-transparency is not supported on this device: reported only once per page > # # TODO following fails: Error: Discrete value supplied to continuous scale > # pd <- generatePartialDependenceData(fit1, bh.task, "chas", n=c(50, NA)) > # plotPartialDependence(pd, data = getTaskData(bh.task)) > > #-- Classification model with mlr --------------------------------------- > > lrn.classif.rpart <- makeLearner("classif.rpart", predict.type = "prob", minsplit = 10) > fit2.with.call <- train.with.call(lrn.classif.rpart, iris.task) > fit2 <- train(lrn.classif.rpart, iris.task) > > # generate partial dependence plots for all variables > # TODO plotmo can plot the response for only one class at a time > plotmo(fit2.with.call, + nresponse="prob.virginica", # what response to plot + # type="prob", # type gets passed to predict.rpart + pmethod="apartdep") # generate partial dependence plot calculating apartdep for Petal.Length calculating apartdep for Petal.Width calculating apartdep for Petal.Length:Petal.Width 01234567890 > > plotmo(fit2$learner.model, + nresponse="virginica", # what response to plot + type="prob", # type gets passed to predict.rpart + pmethod="apartdep") # generate partial dependence plot calculating apartdep for Petal.Length calculating apartdep for Petal.Width calculating apartdep for Petal.Length:Petal.Width 01234567890 > > # generate partial dependence plot for just "Petal.Length" > plotmo(fit2.with.call, + degree1="Petal.Length", # what predictor to plot + degree2=0, # no interaction plots + nresponse="prob.virginica", # what response to plot + # type="prob", # type gets passed to predict.rpart + pmethod="apartdep") # generate partial dependence plot calculating apartdep for Petal.Length > > plotmo(fit2$learner.model, + degree1="Petal.Length", # what predictor to plot + degree2=0, # no interaction plots + nresponse="virginica", # what response to plot + type="prob", # type gets passed to predict.rpart + pmethod="apartdep") # generate partial dependence plot calculating apartdep for Petal.Length > > # compare to the function provided by the mlr package > set.seed(2018) > pd <- generatePartialDependenceData(fit2, iris.task, "Petal.Length", n=c(50, NA)) > print(plotPartialDependence(pd, data = getTaskData(iris.task))) Warning in grid.Call.graphics(C_segments, x$x0, x$y0, x$x1, x$y1, x$arrow) : semi-transparency is not supported on this device: reported only once per page > > cat("==lda example from mlr documentation, and plotmo error handling =================\n") ==lda example from mlr documentation, and plotmo error handling ================= > > set.seed(2018) > data(iris) > task.lda <- makeClassifTask(data=iris, target="Species") > lrn.lda <- makeLearner("classif.lda") > n <- nrow(iris) > train.set <- sample(n, size=2/3*n) > test.set <- setdiff(1:n, train.set) > classif.lda.with.call <- train.with.call(lrn.lda, task.lda, subset=train.set) > classif.lda <- train(lrn.lda, task.lda, subset=train.set) > iris1 <- iris[train.set, ] > library(MASS) > lda <- lda(Species~., data=iris1) > > # expect.err(try(plotres(classif.lda.with.call)), "plotres does not (yet) support type=\"class\" for \"lda\" objects") > expect.err(try(plotres(classif.lda$learner.model)), "plotres does not (yet) support type=\"class\" for \"lda\" objects") Error : plotres does not (yet) support type="class" for "lda" objects Try type="response" ? Got expected error from try(plotres(classif.lda$learner.model)) > > options(warn=2) # treat warnings as errors > # expect.err(try(plotres(classif.lda.with.call, type="response")), "predict.lda returned multiple columns (see above) but nresponse is not specified") > expect.err(try(plotres(classif.lda$learner.model, type="response")), "Defaulting to nresponse=1, see above messages") predict.lda[3,2]: LD1 LD2 15 10.723308 -1.2184763 131 -6.507414 0.9729798 140 -5.339014 -0.8727408 predict.lda returned multiple columns (see above) but nresponse is not specified Use the nresponse argument to specify a column. Example: nresponse=2 Example: nresponse="LD2" Error : (converted from warning) Defaulting to nresponse=1, see above messages Got expected error from try(plotres(classif.lda$learner.model, type = "response")) > options(warn=1) > > expect.err(try(plotres(classif.lda.with.call, type="response", nresponse="nonesuch")), "nresponse=\"nonesuch\" is not allowed") Error : nresponse="nonesuch" is not allowed Only an integer index or "response" is allowed Got expected error from try(plotres(classif.lda.with.call, type = "response", nresponse = "nonesuch")) > expect.err(try(plotres(classif.lda$learner.model, type="response", nresponse="nonesuch")), "nresponse=\"nonesuch\" is not allowed") Error : nresponse="nonesuch" is not allowed Choose an integer index or one of: "LD1" "LD2" Got expected error from try(plotres(classif.lda$learner.model, type = "response", nresponse = "nonesuch")) > > expect.err(try(plotres(classif.lda.with.call, type="response", nresponse=0)), "nresponse=0 but it should be at least 1") Error : nresponse=0 but it should be at least 1 Got expected error from try(plotres(classif.lda.with.call, type = "response", nresponse = 0)) > expect.err(try(plotres(classif.lda$learner.model, type="response", nresponse=0)), "nresponse=0 but it should be at least 1") Error : nresponse=0 but it should be at least 1 Got expected error from try(plotres(classif.lda$learner.model, type = "response", nresponse = 0)) > > expect.err(try(plotres(classif.lda.with.call, type="response", nresponse=99)), "nresponse is 99 but the number of columns is only 1") Error : nresponse is 99 but the number of columns is only 1 Got expected error from try(plotres(classif.lda.with.call, type = "response", nresponse = 99)) > expect.err(try(plotres(classif.lda$learner.model, type="response", nresponse=99)), "nresponse is 99 but the number of columns is only 2") Error : nresponse is 99 but the number of columns is only 2 Got expected error from try(plotres(classif.lda$learner.model, type = "response", nresponse = 99)) > > expect.err(try(plotmo(classif.lda)), "getCall(classif.lda) failed") Error : getCall(classif.lda) failed. Possible workaround: call plotmo like this: plotmo(classif.lda$learner.model, ...) Got expected error from try(plotmo(classif.lda)) > > expect.err(try(plotres(classif.lda)), "getCall(classif.lda) failed") Error : getCall(classif.lda) failed. Possible workaround: call plotres like this: plotres(classif.lda$learner.model, ...) Got expected error from try(plotres(classif.lda)) > > # TODO residuals don't match > plotres(classif.lda.with.call, SHOWCALL=TRUE, type="response") > plotres(classif.lda$learner.model, SHOWCALL=TRUE, type="response", nresponse="LD2") > plotres(lda, SHOWCALL=TRUE, type="response", nresponse="LD2") > > plotmo(classif.lda.with.call, SHOWCALL=TRUE) plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 6 3 4.45 1.4 > plotmo(classif.lda$learner.model, SHOWCALL=TRUE) plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 6 3 4.45 1.4 > plotmo(lda, SHOWCALL=TRUE) plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 6 3 4.45 1.4 > > # # TODO plotPartialDependence and plotmo graphs below don't match > # pd <- generatePartialDependenceData(classif.lda, task.lda, "Petal.Width", n=c(50, NA)) # TODO generates warnings > # print(plotPartialDependence(pd, data = getTaskData(task.lda))) > plotmo(classif.lda.with.call, degree1="Petal.Width", degree2=0, pmethod="partdep", do.par=FALSE) calculating partdep for Petal.Width > > plotmo(classif.lda.with.call, SHOWCALL=TRUE, all2=TRUE, type="response") plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 6 3 4.45 1.4 > plotmo(classif.lda$learner.model, SHOWCALL=TRUE, all2=TRUE, type="class") plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 6 3 4.45 1.4 > plotmo(lda, SHOWCALL=TRUE, all2=TRUE, type="class") plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 6 3 4.45 1.4 > > plotmo(classif.lda$learner.model, SHOWCALL=TRUE, all2=TRUE, type="response", nresponse="LD1") plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 6 3 4.45 1.4 > plotmo(lda, SHOWCALL=TRUE, all2=TRUE, type="response", nresponse="LD1") plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 6 3 4.45 1.4 > > cat("==test recursive call to plotmo_prolog for learner.model===============\n") ==test recursive call to plotmo_prolog for learner.model=============== > > set.seed(2018) > n <- 100 > data <- data.frame( + x1 = rnorm(n), + x2 = rnorm(n), + x3 = rnorm(n), + x4 = rnorm(n), + x5 = rnorm(n), + x6 = rnorm(n), + x7 = rnorm(n), + x8 = rnorm(n), + x9 = rnorm(n)) > > data$y <- sin(data$x3) + sin(data$x4) + 2 * cos(data$x5) > > set.seed(2018) > library(gbm) Loaded gbm 2.1.9 This version of gbm is no longer under development. Consider transitioning to gbm3, https://github.com/gbm-developers/gbm3 > # reference model > gbm = gbm(y~., data=data, n.trees=300) Distribution not specified, assuming gaussian ... > plotmo(gbm, trace=-1, SHOWCALL=TRUE) > > set.seed(2018) > task <- makeRegrTask(data=data, target="y") > lrn <- makeLearner("regr.gbm", n.trees=300, keep.data=TRUE) > regr.gbm = train.with.call(lrn, task) > plotmo(regr.gbm, trace=-1, SHOWCALL=TRUE) > > set.seed(2018) > lrn <- makeLearner("regr.gbm", n.trees=300) > regr.gbm.nokeepdata = train.with.call(lrn, task) > # expect message: use keep.data=TRUE in the call to gbm (cannot determine the variable importances) > plotmo(regr.gbm.nokeepdata, trace=1, SHOWCALL=TRUE) Error : use keep.data=TRUE in the call to gbm (cannot determine the variable importances) plotmo.prolog(object$learner.model) failed, continuing anyway stats::fitted(object=WrappedModel.object) fitted() was unsuccessful, will use predict() instead got model response from object$y plotmo grid: x1 x2 x3 x4 x5 x6 -0.07231869 0.1672582 0.1278179 -0.03757131 -0.2269232 -0.08124337 x7 x8 x9 0.06208072 0.04337176 0.02863955 > > plotres(regr.gbm, SHOWCALL=TRUE) > > cat("==example from makeClassificationViaRegressionWrapper help page ===============\n") ==example from makeClassificationViaRegressionWrapper help page =============== > # this tests that plotmo.prolog can access the learner.model at object$learner.model$next.model$learner.model > > set.seed(2018) > lrn = makeLearner("regr.rpart") > lrn = makeClassificationViaRegressionWrapper(lrn) > ClassificationViaRegression = train.with.call(lrn, sonar.task, subset = 1:140) > plotmo(ClassificationViaRegression, SHOWCALL=TRUE) plotmo grid: V1 V2 V3 V4 V5 V6 V7 V8 V9 0.0228 0.0309 0.03415 0.0436 0.06185 0.0898 0.10905 0.1079 0.12425 V10 V11 V12 V13 V14 V15 V16 V17 V18 V19 0.14675 0.17765 0.20415 0.23515 0.284 0.34475 0.4347 0.42945 0.4559 0.4763 V20 V21 V22 V23 V24 V25 V26 V27 V28 V29 0.55465 0.60735 0.6532 0.6704 0.7206 0.70165 0.68745 0.65975 0.63945 0.56105 V30 V31 V32 V33 V34 V35 V36 V37 V38 V39 0.52325 0.468 0.3803 0.3608 0.37695 0.3663 0.41885 0.3821 0.3153 0.2847 V40 V41 V42 V43 V44 V45 V46 V47 V48 V49 0.28085 0.2602 0.23295 0.2066 0.1694 0.13395 0.09905 0.08755 0.0645 0.0362 V50 V51 V52 V53 V54 V55 V56 V57 V58 V59 0.0173 0.01325 0.01005 0.01105 0.01035 0.00835 0.0074 0.0072 0.0063 0.00705 V60 0.0059 > > source("test.epilog.R") plotmo/inst/slowtests/test.partdep.R0000644000176200001440000002002313727235376017364 0ustar liggesusers# partdep.test.R: partdep tests for plotmo and plotres source("test.prolog.R") library(plotmo) library(earth) data(etitanic) mod <- earth(survived~., data=etitanic, degree=2) plotmo(mod, caption="plotmo classical") plotmo(mod, pmethod="partdep", caption="plotmo partdep age") set.seed(2016) plotmo(mod, pmethod="apartdep", caption="plotmo apartdep age", do.par=2) set.seed(2016) plotmo(mod, pmethod="apartdep", ylim=c(0,1), do.par=0, type2="image", pt.col=ifelse(etitanic$survived, "green", "red"), degree1=0, degree2=1:3) par(org.par) # compare to gbm with an artifical function of variables with a very strong interaction library(gbm) n <- 250 set.seed(2016) x1 <- runif(n) x2 <- runif(n) x3 <- runif(n) y <- ifelse(x2 > .6, x1-.2, ifelse(x2 > .4, 1 - 1.5 * x1, .3)) + .1 * sin(4 * x3) data <- data.frame(x1=x1, x2=x2, x3=x3, y=y) n.trees <- 20 set.seed(2016) mod <- gbm(y~., data=data, n.trees=n.trees, shrinkage=.1, distribution="gaussian", interact=5) plotmo(mod, degree1=0, persp.ticktype="detailed", caption="variables with a strong interaction") par(mfrow=c(4,4), mar=c(2,3,2,1), mgp=c(1.5, 0.5, 0), oma=c(0,0,6,0)) library(viridis); image.col <- viridis(100) ngrid1 <- 50 ngrid2 <- 30 plotmo(mod, pmethod="plot", do.par=0, degree2=2, type2="im", ylim=NULL, clip=FALSE, image.col=image.col, ngrid1=ngrid1, ngrid=ngrid2) title("row1: plotmo classic\nrow2: plotmo apartdep\nrow3: plotmo partdep\nrow4: plot.gbm\n\n\n\n\n\n\n", xpd=NA) ylim <- c(.21, .40) set.seed(2016) # for consistent selection of rows for partdep.x plotmo(mod, pmethod="apartdep", do.par=0, degree2=2, type2="im", ylim=ylim, clip=FALSE, image.col=image.col, ngrid1=ngrid1, ngrid=ngrid2) plotmo(mod, pmethod="partdep", do.par=0, degree2=2, type2="im", ylim=ylim, clip=FALSE, image.col=image.col, ngrid1=ngrid1, ngrid=ngrid2, trace=-1) # check that the pacifier messages are suppressed plot(mod, i.var=1, n.trees=n.trees, ylim=ylim, continuous.resolution=ngrid1) plot(mod, i.var=2, n.trees=n.trees, ylim=ylim, continuous.resolution=ngrid1) plot(mod, i.var=3, n.trees=n.trees, ylim=ylim, continuous.resolution=ngrid1) # following ignores par(mfrow=c(2,2)) plot(mod, i.var=c(1,3), n.trees=n.trees, continuous.resolution=ngrid2, col.regions=image.col, colorkey=FALSE, main="gbm plot x1:x3\ncompare to plotmo partdep on previous page") par(org.par) #--- compare to gbm and randomForest with a simple regression function data(scor, package="bootstrap") # some correlated data n <- 50 x1 <- scale(scor$mec[1:n]) x2 <- scale(scor$vec[1:n]) data <- data.frame(x1=x1, x2=x2) ngrid1 <- 100 # randomForest, simple regression function library(randomForest) data$y <- x1 > -.1 # y depends only on x1 (-.1 hand-tuned to create interesting model surface) set.seed(2016) # Expect Warning: The response has five or fewer unique values. Are you sure you want to do regression? mod <- randomForest(y~., data=data, ntree=3) par(mfrow=c(4,2), mar=c(2.5,3,2,1), mgp=c(1.3,0.4,0), oma=c(0,0,7,0)) set.seed(2016) # for consistent jitter of response sites plotmo(mod, degree1=0, ngrid2=100, do.par=0, clip=FALSE, type2="image", main="regression surface", pt.col=ifelse(data$y, "green", "red")) title("RANDOM FOREST SIMPLE REGRESSION MODEL row1: regression surface row2: plotmo classic type=response row3: plotmo partdep type=response row4: randomForest plot\n\n\n\n\n\n\n", xpd=NA, adj=0) plotmo(mod, degree1=0, ngrid2=100, do.par=0, clip=FALSE, persp.border=NA, main="regression surface") plotmo(mod, pmethod="plotmo", do.par=0, degree2=0, ngrid1=ngrid1, type="response") plotmo(mod, pmethod="partdep", do.par=0, degree2=0, ngrid1=ngrid1, type="response") partialPlot(mod, pred.data=data, x.var="x1", n.pt=ngrid1, which.class="True") partialPlot(mod, pred.data=data, x.var="x2", n.pt=ngrid1, which.class="True") par(org.par) # gbm, simple regression function library(gbm) n.trees <- 20 data$y <- x1 > -.6 # y depends only on x1 (-.1 hand-tuned to create interesting model surface) set.seed(2016) mod <- gbm(y~., data=data, n.trees=n.trees, shrinkage=.1, interaction.depth=4, distribution="gaussian") par(mfrow=c(4,2), mar=c(2.5,3,2,1), mgp=c(1.3,0.4,0), oma=c(0,0,7,0)) set.seed(2016) # for consistent jitter of response sites plotmo(mod, degree1=0, ngrid2=100, do.par=0, clip=FALSE, type2="image", main="regression surface", pt.col=ifelse(data$y, "green", "red")) title("GBM SIMPLE REGRESSION MODEL row1: regression surface row2: plotmo classic type=response row3: plotmo partdep type=response row4: gbm plot\n\n\n\n\n\n\n", xpd=NA, adj=0) plotmo(mod, degree1=0, ngrid2=100, do.par=0, clip=FALSE, persp.border=NA, main="regression surface") plotmo(mod, pmethod="plotmo", do.par=0, all1=TRUE, degree2=0, ngrid1=ngrid1, type="response") plotmo(mod, pmethod="partdep", do.par=0, all1=TRUE, degree2=0, ngrid1=ngrid1, type="response") plot(mod, i.var=1, n.trees=n.trees, continuous.resolution=ngrid1) plot(mod, i.var=2, n.trees=n.trees, continuous.resolution=ngrid1) par(org.par) #--- compare to gbm and randomForest with simple binomial (two class) data data(scor, package="bootstrap") # some correlated data n <- 50 x1 <- scale(scor$mec[1:n]) x2 <- scale(scor$vec[1:n]) data <- data.frame(x1=x1, x2=x2) ngrid1 <- 100 # randomForest, simple binomial (two-class) data library(randomForest) # y depends only on x1 # random forest requires a factor for classification (not a logical) data$y <- factor(as.character(x1 > .4), levels=c("FALSE", "TRUE"), labels=c("False", "True")) set.seed(2016) mod <- randomForest(y~., data=data, ntree=3) par(mfrow=c(4,2), mar=c(2.5,3,2,1), mgp=c(1.3,0.4,0), oma=c(0,0,7,0)) set.seed(2016) # for consistent jitter of response sites plotmo(mod, degree1=0, ngrid2=100, do.par=0, clip=FALSE, type2="image", main="regression surface", pt.col=ifelse(data$y=="True", "green", "red")) title("RANDOM FOREST SIMPLE TWO-CLASS MODEL row1: regression surface row2: plotmo partdep type=response (FALSE or TRUE) row3: plotmo partdep type=prob row4: randomForest partialPlot (clipped log odds)\n\n\n\n\n\n\n", xpd=NA, adj=0) plotmo(mod, degree1=0, ngrid2=100, do.par=0, clip=FALSE, persp.border=NA, main="regression surface") plotmo(mod, pmethod="partdep", do.par=0, degree2=0, ngrid1=ngrid1, type="response") plotmo(mod, pmethod="partdep", do.par=0, degree2=0, ngrid1=ngrid1, type="prob", nresponse="True", ylim=c(0,1)) partialPlot(mod, pred.data=data, x.var="x1", n.pt=ngrid1, which.class="True", ylim=c(-16,16)) partialPlot(mod, pred.data=data, x.var="x2", n.pt=ngrid1, which.class="True", ylim=c(-16,16)) par(org.par) # gbm, simple binomial (two-class) data library(gbm) n.trees <- 10 data$y <- x1 > .6 # y depends only on x1 set.seed(2016) mod <- gbm(y~., data=data, n.trees=n.trees, shrinkage=.1, interact=4, distribution="bernoulli") par(mfrow=c(4,2), mar=c(2.5,3,2,1), mgp=c(1.3,0.4,0), oma=c(0,0,7,0)) set.seed(2016) # for consistent jitter of response sites plotmo(mod, degree1=0, ngrid2=100, do.par=0, clip=FALSE, type2="image", main="regression surface", pt.col=ifelse(data$y, "green", "red")) title("GBM SIMPLE TWO-CLASS MODEL row1: regression surface row2: plotmo partdep type=response (probability) row4: plotmo partdep type=link (log odds) row3: gbm plot (log odds)\n\n\n\n\n\n\n", xpd=NA, adj=0) plotmo(mod, degree1=0, ngrid2=100, do.par=0, clip=FALSE, persp.border=NA, main="regression surface") plotmo(mod, pmethod="partdep", do.par=0, all1=TRUE, degree2=0, ngrid1=ngrid1, type="response") plotmo(mod, pmethod="partdep", do.par=0, all1=TRUE, degree2=0, ngrid1=ngrid1, type="link") plot(mod, i.var=1, n.trees=n.trees, continuous.resolution=ngrid1) plot(mod, i.var=2, n.trees=n.trees, continuous.resolution=ngrid1) par(org.par) source("test.epilog.R") plotmo/inst/slowtests/test.plotmo.Rout.save0000644000176200001440000034530014567065443020733 0ustar liggesusers> # test.plotmo.R: regression tests for plotmo > # Stephen Milborrow, Petaluma Jan 2007 > > print(R.version.string) [1] "R version 4.3.2 (2023-10-31 ucrt)" > > source("test.prolog.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix > options(warn=1) # print warnings as they occur > data(etitanic) > make.space.for.caption <- function(caption="CAPTION") + { + oma <- par("oma") + needed <- 3 + # adjust for newlines in caption + newlines <- grep("\n", caption) + if(length(newlines) > 0) + needed <- needed + .5 * newlines # .5 seems enough although 1 in theory + if(!is.null(caption) && any(nchar(caption)) && oma[3] <= needed) { + oma[3] <- needed + par(oma=oma) + } + } > dopar <- function(nrows, ncols, caption = "") + { + cat(" ", caption, "\n") + make.space.for.caption(caption) + par(mfrow=c(nrows, ncols)) + par(mar = c(3, 3, 1.7, 0.5)) + par(mgp = c(1.6, 0.6, 0)) + par(cex = 0.7) + } > example(plotmo) plotmo> if (require(rpart)) { plotmo+ data(kyphosis) plotmo+ rpart.model <- rpart(Kyphosis~., data=kyphosis) plotmo+ # pass type="prob" to plotmo's internal calls to predict.rpart, and plotmo+ # select the column named "present" from the matrix returned by predict.rpart plotmo+ plotmo(rpart.model, type="prob", nresponse="present") plotmo+ } Loading required package: rpart plotmo grid: Age Number Start 87 4 13 plotmo> if (require(earth)) { plotmo+ data(ozone1) plotmo+ earth.model <- earth(O3 ~ ., data=ozone1, degree=2) plotmo+ plotmo(earth.model) plotmo+ # plotmo(earth.model, pmethod="partdep") # partial dependence plots plotmo+ } plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > caption <- "basic earth test of plotmo" > a <- earth(O3 ~ ., data=ozone1, degree=2) > plotmo(a, degree1=2, degree2=4, caption=caption, trace=-1) > > caption <- "test 5 x 5 layout" > dopar(1,1,caption) test 5 x 5 layout > a <- earth(O3 ~ ., data=ozone1, nk=51, pmethod="n", degree=2) > plotmo(a, caption=caption, trace=1) stats::predict(earth.object, NULL, type="response") stats::fitted(object=earth.object) got model response from model.frame(O3 ~ vh + wind + humidity + temp + ib..., data=call$data, na.action="na.fail") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > > caption <- "test 4 x 4 layout with ylab" > dopar(1,1,caption) test 4 x 4 layout with ylab > a <- earth(O3 ~ ., data=ozone1, nk=30, pmethod="n", degree=2) > plotmo(a, caption=caption, trace=2) plotmo trace 2: plotmo(object=a, caption=caption, trace=2) --get.model.env for object with class earth object call is earth(formula=O3~., data=ozone1, pmethod="n", degree=2, nk=30) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'a' --plotmo_x for earth object get.object.x: object$x is NULL (and it has no colnames) object call is earth(formula=O3~., data=ozone1, pmethod="n", degree=2, nk=30) get.x.from.model.frame: formula(object) is O3 ~ vh + wind + humidity + temp + ibh + dpg + ibt + vis ... naked formula is the same formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) object$data is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names O3 vh wind humidity temp ibh dpg ibt vis doy na.action(object) is "na.fail" stats::model.frame(O3 ~ vh + wind + humidity + temp + ib..., data=call$data, na.action="na.fail") x=model.frame[,-1] is usable and has column names vh wind humidity temp ibh dpg ibt vis doy plotmo_x returned[330,9]: vh wind humidity temp ibh dpg ibt vis doy 1 5710 4 28 40 2693 -25 87 250 33 2 5700 3 37 45 590 -24 128 100 34 3 5760 3 51 54 1450 25 139 60 35 ... 5720 4 69 35 1568 15 121 60 36 330 5550 4 85 39 5000 8 44 100 390 ----Metadata: plotmo_predict with nresponse=NULL and newdata=NULL calling predict.earth with NULL newdata stats::predict(earth.object, NULL, type="response") predict returned[330,1]: O3 1 1.240608 2 3.596894 3 7.464276 ... 5.282731 330 3.228830 predict after processing with nresponse=NULL is [330,1]: O3 1 1.240608 2 3.596894 3 7.464276 ... 5.282731 330 3.228830 ----Metadata: plotmo_fitted with nresponse=NULL stats::fitted(object=earth.object) fitted(object) returned[330,1]: O3 1 1.240608 2 3.596894 3 7.464276 ... 5.282731 330 3.228830 fitted(object) after processing with nresponse=NULL is [330,1]: O3 1 1.240608 2 3.596894 3 7.464276 ... 5.282731 330 3.228830 ----Metadata: plotmo_y with nresponse=NULL --plotmo_y with nresponse=NULL for earth object get.object.y: object$y is NULL (and it has no colnames) object call is earth(formula=O3~., data=ozone1, pmethod="n", degree=2, nk=30) get.y.from.model.frame: formula(object) is O3 ~ vh + wind + humidity + temp + ibh + dpg + ibt + vis ... formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) object$data is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names O3 vh wind humidity temp ibh dpg ibt vis doy na.action(object) is "na.fail" stats::model.frame(O3 ~ vh + wind + humidity + temp + ib..., data=call$data, na.action="na.fail") y=model.frame[,1] is usable and has column name O3 plotmo_y returned[330,1]: O3 1 3 2 5 3 5 ... 6 330 1 plotmo_y after processing with nresponse=NULL is [330,1]: O3 1 3 2 5 3 5 ... 6 330 1 converted nresponse=NA to nresponse=1 nresponse=1 (was NA) ncol(fitted) 1 ncol(predict) 1 ncol(y) 1 ----Metadata: plotmo_y with nresponse=1 --plotmo_y with nresponse=1 for earth object get.object.y: object$y is NULL (and it has no colnames) object call is earth(formula=O3~., data=ozone1, pmethod="n", degree=2, nk=30) get.y.from.model.frame: formula(object) is O3 ~ vh + wind + humidity + temp + ibh + dpg + ibt + vis ... formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) object$data is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names O3 vh wind humidity temp ibh dpg ibt vis doy na.action(object) is "na.fail" stats::model.frame(O3 ~ vh + wind + humidity + temp + ib..., data=call$data, na.action="na.fail") y=model.frame[,1] is usable and has column name O3 got model response from model.frame(O3 ~ vh + wind + humidity + temp + ib..., data=call$data, na.action="na.fail") plotmo_y returned[330,1]: O3 1 3 2 5 3 5 ... 6 330 1 plotmo_y after processing with nresponse=1 is [330,1]: O3 1 3 2 5 3 5 ... 6 330 1 got response name "O3" from yhat resp.levs is NULL ----Metadata: done number of x values: vh 53 wind 11 humidity 65 temp 63 ibh 196 dpg 128 ibt 193... ----plotmo_singles for earth object singles: 4 temp, 5 ibh, 7 ibt, 8 vis, 9 doy ----plotmo_pairs for earth object pairs: [,1] [,2] [1,] "1 vh" "4 temp" [2,] "1 vh" "9 doy" [3,] "2 wind" "8 vis" [4,] "3 humidity" "4 temp" [5,] "4 temp" "5 ibh" [6,] "4 temp" "6 dpg" [7,] "4 temp" "9 doy" [8,] "5 ibh" "6 dpg" [9,] "7 ibt" "8 vis" graphics::par(mfrow=c(4,4), mgp=c(1.5,0.4,0), tcl=-0.3, font.main=2, mar=c(3,2,1.2,0.8), oma=c(0,0,3,0), cex.main=1.1, cex.lab=1, cex.axis=1, cex=0.66) ----Figuring out ylim --get.ylim.by.dummy.plots --plot.degree1(draw.plot=FALSE) degree1 plot1 (pmethod "plotmo") variable temp newdata[50,9]: vh wind humidity temp ibh dpg ibt vis doy 1 5760 5 64 25.00000 2112.5 24 167.5 120 205.5 2 5760 5 64 26.38776 2112.5 24 167.5 120 205.5 3 5760 5 64 27.77551 2112.5 24 167.5 120 205.5 ... 5760 5 64 29.16327 2112.5 24 167.5 120 205.5 50 5760 5 64 93.00000 2112.5 24 167.5 120 205.5 stats::predict(earth.object, data.frame[50,9], type="response") predict returned[50,1]: O3 1 8.724965 2 8.813294 3 8.901624 ... 8.989953 50 18.716007 predict after processing with nresponse=1 is [50,1]: O3 1 8.724965 2 8.813294 3 8.901624 ... 8.989953 50 18.716007 Reducing trace level for subsequent degree1 plots degree1 plot2 (pmethod "plotmo") variable ibh degree1 plot3 (pmethod "plotmo") variable ibt degree1 plot4 (pmethod "plotmo") variable vis degree1 plot5 (pmethod "plotmo") variable doy --plot.degree2(draw.plot=FALSE) degree2 plot1 (pmethod "plotmo") variables vh:temp newdata[400,9]: vh wind humidity temp ibh dpg ibt vis doy 1 5320.000 5 64 25 2112.5 24 167.5 120 205.5 2 5353.158 5 64 25 2112.5 24 167.5 120 205.5 3 5386.316 5 64 25 2112.5 24 167.5 120 205.5 ... 5419.474 5 64 25 2112.5 24 167.5 120 205.5 400 5950.000 5 64 93 2112.5 24 167.5 120 205.5 stats::predict(earth.object, data.frame[400,9], type="response") predict returned[400,1]: O3 1 10.41649 2 10.28902 3 10.16155 ... 10.03408 400 27.17075 predict after processing with nresponse=1 is [400,1]: O3 1 10.41649 2 10.28902 3 10.16155 ... 10.03408 400 27.17075 Reducing trace level for subsequent degree2 plots degree2 plot2 (pmethod "plotmo") variables vh:doy degree2 plot3 (pmethod "plotmo") variables wind:vis degree2 plot4 (pmethod "plotmo") variables humidity:temp degree2 plot5 (pmethod "plotmo") variables temp:ibh degree2 plot6 (pmethod "plotmo") variables temp:dpg degree2 plot7 (pmethod "plotmo") variables temp:doy degree2 plot8 (pmethod "plotmo") variables ibh:dpg degree2 plot9 (pmethod "plotmo") variables ibt:vis --done get.ylim.by.dummy.plots ylim c(-33.06, 31.48) clip TRUE --plot.degree1(draw.plot=TRUE) plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 graphics::plot.default(x=c(25,26.39,27.7...), y=c(8.725,8.813,8...), type="n", main="1 temp", xlab="", ylab="", xaxt="s", yaxt="s", xlim=c(25,93), ylim=c(-33.06,31.48)) --plot.degree2(draw.plot=TRUE) persp(vh:temp) theta -35 persp(vh:doy) theta -35 persp(wind:vis) theta 145 persp(humidity:temp) theta -35 persp(temp:ibh) theta 235 persp(temp:dpg) theta 235 persp(temp:doy) theta 235 persp(ibh:dpg) theta 235 persp(ibt:vis) theta 235 > > caption <- "test 3 x 3 layout" > dopar(1,1,caption) test 3 x 3 layout > a <- earth(O3 ~ ., data=ozone1, nk=16, pmethod="n", degree=2) > plotmo(a, caption=caption, trace=3) plotmo trace 3: plotmo(object=a, caption=caption, trace=3) --get.model.env for object with class earth object call is earth(formula=O3~., data=ozone1, pmethod="n", degree=2, nk=16) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'a' --plotmo_x for earth object get.object.x: object$x is NULL (and it has no colnames) object call is earth(formula=O3~., data=ozone1, pmethod="n", degree=2, nk=16) get.x.from.model.frame: formula(object) is O3 ~ vh + wind + humidity + temp + ibh + dpg + ibt + vis ... naked formula is the same formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) object$data is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names O3 vh wind humidity temp ibh dpg ibt vis doy na.action(object) is "na.fail" model.env is R_GlobalEnv data[330,10]: O3 vh wind humidity temp ibh dpg ibt vis doy 1 3 5710 4 28 40 2693 -25 87 250 33 2 5 5700 3 37 45 590 -24 128 100 34 3 5 5760 3 51 54 1450 25 139 60 35 ... 6 5720 4 69 35 1568 15 121 60 36 330 1 5550 4 85 39 5000 8 44 100 390 stats::model.frame(O3 ~ vh + wind + humidity + temp + ib..., data=call$data, na.action="na.fail") model.frame returned[330,10]: O3 vh wind humidity temp ibh dpg ibt vis doy 1 3 5710 4 28 40 2693 -25 87 250 33 2 5 5700 3 37 45 590 -24 128 100 34 3 5 5760 3 51 54 1450 25 139 60 35 ... 6 5720 4 69 35 1568 15 121 60 36 330 1 5550 4 85 39 5000 8 44 100 390 x=model.frame[,-1] is usable and has column names vh wind humidity temp ibh dpg ibt vis doy plotmo_x returned[330,9]: vh wind humidity temp ibh dpg ibt vis doy 1 5710 4 28 40 2693 -25 87 250 33 2 5700 3 37 45 590 -24 128 100 34 3 5760 3 51 54 1450 25 139 60 35 ... 5720 4 69 35 1568 15 121 60 36 330 5550 4 85 39 5000 8 44 100 390 ----Metadata: plotmo_predict with nresponse=NULL and newdata=NULL calling predict.earth with NULL newdata stats::predict(earth.object, NULL, type="response") predict returned[330,1]: O3 1 1.255037 2 4.164931 3 7.585888 ... 4.443360 330 1.685101 predict after processing with nresponse=NULL is [330,1]: O3 1 1.255037 2 4.164931 3 7.585888 ... 4.443360 330 1.685101 ----Metadata: plotmo_fitted with nresponse=NULL stats::fitted(object=earth.object) fitted(object) returned[330,1]: O3 1 1.255037 2 4.164931 3 7.585888 ... 4.443360 330 1.685101 fitted(object) after processing with nresponse=NULL is [330,1]: O3 1 1.255037 2 4.164931 3 7.585888 ... 4.443360 330 1.685101 ----Metadata: plotmo_y with nresponse=NULL --plotmo_y with nresponse=NULL for earth object get.object.y: object$y is NULL (and it has no colnames) object call is earth(formula=O3~., data=ozone1, pmethod="n", degree=2, nk=16) get.y.from.model.frame: formula(object) is O3 ~ vh + wind + humidity + temp + ibh + dpg + ibt + vis ... formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) object$data is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names O3 vh wind humidity temp ibh dpg ibt vis doy na.action(object) is "na.fail" model.env is R_GlobalEnv data[330,10]: O3 vh wind humidity temp ibh dpg ibt vis doy 1 3 5710 4 28 40 2693 -25 87 250 33 2 5 5700 3 37 45 590 -24 128 100 34 3 5 5760 3 51 54 1450 25 139 60 35 ... 6 5720 4 69 35 1568 15 121 60 36 330 1 5550 4 85 39 5000 8 44 100 390 stats::model.frame(O3 ~ vh + wind + humidity + temp + ib..., data=call$data, na.action="na.fail") model.frame returned[330,10]: O3 vh wind humidity temp ibh dpg ibt vis doy 1 3 5710 4 28 40 2693 -25 87 250 33 2 5 5700 3 37 45 590 -24 128 100 34 3 5 5760 3 51 54 1450 25 139 60 35 ... 6 5720 4 69 35 1568 15 121 60 36 330 1 5550 4 85 39 5000 8 44 100 390 y=model.frame[,1] is usable and has column name O3 plotmo_y returned[330,1]: O3 1 3 2 5 3 5 ... 6 330 1 plotmo_y after processing with nresponse=NULL is [330,1]: O3 1 3 2 5 3 5 ... 6 330 1 converted nresponse=NA to nresponse=1 nresponse=1 (was NA) ncol(fitted) 1 ncol(predict) 1 ncol(y) 1 ----Metadata: plotmo_y with nresponse=1 --plotmo_y with nresponse=1 for earth object get.object.y: object$y is NULL (and it has no colnames) object call is earth(formula=O3~., data=ozone1, pmethod="n", degree=2, nk=16) get.y.from.model.frame: formula(object) is O3 ~ vh + wind + humidity + temp + ibh + dpg + ibt + vis ... formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) object$data is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names O3 vh wind humidity temp ibh dpg ibt vis doy na.action(object) is "na.fail" model.env is R_GlobalEnv data[330,10]: O3 vh wind humidity temp ibh dpg ibt vis doy 1 3 5710 4 28 40 2693 -25 87 250 33 2 5 5700 3 37 45 590 -24 128 100 34 3 5 5760 3 51 54 1450 25 139 60 35 ... 6 5720 4 69 35 1568 15 121 60 36 330 1 5550 4 85 39 5000 8 44 100 390 stats::model.frame(O3 ~ vh + wind + humidity + temp + ib..., data=call$data, na.action="na.fail") model.frame returned[330,10]: O3 vh wind humidity temp ibh dpg ibt vis doy 1 3 5710 4 28 40 2693 -25 87 250 33 2 5 5700 3 37 45 590 -24 128 100 34 3 5 5760 3 51 54 1450 25 139 60 35 ... 6 5720 4 69 35 1568 15 121 60 36 330 1 5550 4 85 39 5000 8 44 100 390 y=model.frame[,1] is usable and has column name O3 got model response from model.frame(O3 ~ vh + wind + humidity + temp + ib..., data=call$data, na.action="na.fail") plotmo_y returned[330,1]: O3 1 3 2 5 3 5 ... 6 330 1 plotmo_y after processing with nresponse=1 is [330,1]: O3 1 3 2 5 3 5 ... 6 330 1 got response name "O3" from yhat resp.levs is NULL ----Metadata: done number of x values: vh 53 wind 11 humidity 65 temp 63 ibh 196 dpg 128 ibt 193... ----plotmo_singles for earth object singles: 4 temp, 5 ibh, 8 vis, 9 doy ----plotmo_pairs for earth object pairs: [,1] [,2] [1,] "2 wind" "8 vis" [2,] "3 humidity" "4 temp" [3,] "4 temp" "6 dpg" do.par invoked call.dots TRACE do.par called call.dots(par, DROP="*", KEEP="PREFIX,PAR.ARGS", TRACE=if(trace>=2)trace-1e...), SCALAR=TRUE, def.mfrow=c(nrows,nrows), def.mgp=mgp, def.tcl=-0.3, def.font.main=def.font.main, def.mar=mar, def.oma=def.oma, def.cex.main=def.cex.main, def.cex.lab=cex.lab, def.cex.axis=cex.lab, force.cex=cex) PREFIX par. DROP .* KEEP >STANDARDPREFIXES|^force\.|^def\.|^drop\. >PREFIX|^par\. >CALLARGS|^def\.mfrow$|^def\.mgp$|^def\.tcl$|^def\.font\.main$|^def\.mar$|^def\.oma$|^def\.cex\.main$|^def\.cex\.lab$|^def\.cex\.axis$|^force\.cex$ >EXPLICIT >PAR_ARGS|^adj$|^ann$|^ask$|^bg$|^bty$|^cex$|^cex\.axis$|^cex\.lab$|^cex\.main$|^cex\.sub$|^col\.axis$|^col\.lab$|^col\.main$|^col\.sub$|^crt$|^err$|^family$|^fg$|^fig$|^fin$|^font$|^font\.axis$|^font\.lab$|^font\.main$|^font\.sub$|^lab$|^las$|^lend$|^lheight$|^ljoin$|^lmitre$|^lty$|^mai$|^mar$|^mex$|^mfcol$|^mfg$|^mfrow$|^mgp$|^mkh$|^new$|^oma$|^omd$|^omi$|^pch$|^pin$|^plt$|^ps$|^pty$|^srt$|^tck$|^tcl$|^usr$|^xaxp$|^xaxs$|^xaxt$|^xlog$|^xpd$|^yaxp$|^yaxs$|^yaxt$|^ylbias$|^ylog$ input dotnames def.mfrow def.mgp def.tcl def.font.main def.mar def.oma def.cex.main def.cex.lab def.cex.axis force.cex after DROP and KEEP def.mfrow def.mgp def.tcl def.font.main def.mar def.oma def.cex.main def.cex.lab def.cex.axis force.cex return dotnames mfrow mgp tcl font.main mar oma cex.main cex.lab cex.axis cex graphics::par(mfrow=c(3,3), mgp=c(1.5,0.4,0), tcl=-0.3, font.main=2, mar=c(3,2,1.2,0.8), oma=c(0,0,3,0), cex.main=1.2, cex.lab=1, cex.axis=1, cex=0.66) ----Figuring out ylim --get.ylim.by.dummy.plots --plot.degree1(draw.plot=FALSE) degree1 plot1 (pmethod "plotmo") variable temp newdata[50,9]: vh wind humidity temp ibh dpg ibt vis doy 1 5760 5 64 25.00000 2112.5 24 167.5 120 205.5 2 5760 5 64 26.38776 2112.5 24 167.5 120 205.5 3 5760 5 64 27.77551 2112.5 24 167.5 120 205.5 ... 5760 5 64 29.16327 2112.5 24 167.5 120 205.5 50 5760 5 64 93.00000 2112.5 24 167.5 120 205.5 stats::predict(earth.object, data.frame[50,9], type="response") predict returned[50,1]: O3 1 5.311674 2 5.527233 3 5.742791 ... 5.958350 50 29.012915 predict after processing with nresponse=1 is [50,1]: O3 1 5.311674 2 5.527233 3 5.742791 ... 5.958350 50 29.012915 degree1 plot2 (pmethod "plotmo") variable ibh newdata[50,9]: vh wind humidity temp ibh dpg ibt vis doy 1 5760 5 64 62 111.0000 24 167.5 120 205.5 2 5760 5 64 62 210.7755 24 167.5 120 205.5 3 5760 5 64 62 310.5510 24 167.5 120 205.5 ... 5760 5 64 62 410.3265 24 167.5 120 205.5 50 5760 5 64 62 5000.0000 24 167.5 120 205.5 stats::predict(earth.object, data.frame[50,9], type="response") predict returned[50,1]: O3 1 10.870828 2 11.135522 3 11.400215 ... 11.664908 50 9.845279 predict after processing with nresponse=1 is [50,1]: O3 1 10.870828 2 11.135522 3 11.400215 ... 11.664908 50 9.845279 degree1 plot3 (pmethod "plotmo") variable vis newdata[50,9]: vh wind humidity temp ibh dpg ibt vis doy 1 5760 5 64 62 2112.5 24 167.5 0.000000 205.5 2 5760 5 64 62 2112.5 24 167.5 7.142857 205.5 3 5760 5 64 62 2112.5 24 167.5 14.285714 205.5 ... 5760 5 64 62 2112.5 24 167.5 21.428571 205.5 50 5760 5 64 62 2112.5 24 167.5 350.000000 205.5 stats::predict(earth.object, data.frame[50,9], type="response") predict returned[50,1]: O3 1 14.86257 2 14.72553 3 14.58850 ... 14.45147 50 11.88484 predict after processing with nresponse=1 is [50,1]: O3 1 14.86257 2 14.72553 3 14.58850 ... 14.45147 50 11.88484 degree1 plot4 (pmethod "plotmo") variable doy newdata[50,9]: vh wind humidity temp ibh dpg ibt vis doy 1 5760 5 64 62 2112.5 24 167.5 120 33.00000 2 5760 5 64 62 2112.5 24 167.5 120 40.28571 3 5760 5 64 62 2112.5 24 167.5 120 47.57143 ... 5760 5 64 62 2112.5 24 167.5 120 54.85714 50 5760 5 64 62 2112.5 24 167.5 120 390.00000 stats::predict(earth.object, data.frame[50,9], type="response") predict returned[50,1]: O3 1 7.968080 2 8.746490 3 9.524900 ... 10.303310 50 8.957033 predict after processing with nresponse=1 is [50,1]: O3 1 7.968080 2 8.746490 3 9.524900 ... 10.303310 50 8.957033 --plot.degree2(draw.plot=FALSE) degree2 plot1 (pmethod "plotmo") variables wind:vis newdata[400,9]: vh wind humidity temp ibh dpg ibt vis doy 1 5760 0.0000000 64 62 2112.5 24 167.5 0 205.5 2 5760 0.5789474 64 62 2112.5 24 167.5 0 205.5 3 5760 1.1578947 64 62 2112.5 24 167.5 0 205.5 ... 5760 1.7368421 64 62 2112.5 24 167.5 0 205.5 400 5760 11.0000000 64 62 2112.5 24 167.5 350 205.5 stats::predict(earth.object, data.frame[400,9], type="response") predict returned[400,1]: O3 1 16.19942 2 16.04463 3 15.88983 ... 15.73504 400 11.88484 predict after processing with nresponse=1 is [400,1]: O3 1 16.19942 2 16.04463 3 15.88983 ... 15.73504 400 11.88484 degree2 plot2 (pmethod "plotmo") variables humidity:temp newdata[400,9]: vh wind humidity temp ibh dpg ibt vis doy 1 5760 5 19.00000 25 2112.5 24 167.5 120 205.5 2 5760 5 22.89474 25 2112.5 24 167.5 120 205.5 3 5760 5 26.78947 25 2112.5 24 167.5 120 205.5 ... 5760 5 30.68421 25 2112.5 24 167.5 120 205.5 400 5760 5 93.00000 93 2112.5 24 167.5 120 205.5 stats::predict(earth.object, data.frame[400,9], type="response") predict returned[400,1]: O3 1 5.311674 2 5.311674 3 5.311674 ... 5.311674 400 32.296021 predict after processing with nresponse=1 is [400,1]: O3 1 5.311674 2 5.311674 3 5.311674 ... 5.311674 400 32.296021 degree2 plot3 (pmethod "plotmo") variables temp:dpg newdata[400,9]: vh wind humidity temp ibh dpg ibt vis doy 1 5760 5 64 25.00000 2112.5 -69 167.5 120 205.5 2 5760 5 64 28.57895 2112.5 -69 167.5 120 205.5 3 5760 5 64 32.15789 2112.5 -69 167.5 120 205.5 ... 5760 5 64 35.73684 2112.5 -69 167.5 120 205.5 400 5760 5 64 93.00000 2112.5 107 167.5 120 205.5 stats::predict(earth.object, data.frame[400,9], type="response") predict returned[400,1]: O3 1 5.311674 2 5.867588 3 6.423503 ... 6.979417 400 -6.671880 predict after processing with nresponse=1 is [400,1]: O3 1 5.311674 2 5.867588 3 6.423503 ... 6.979417 400 -6.671880 --done get.ylim.by.dummy.plots ylim c(-6.672, 40.23) clip TRUE --plot.degree1(draw.plot=TRUE) plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 draw.degree1 invoked call.dots TRACE draw.degree1 called call.plot(plot.default, PREFIX="degree1.", TRACE=if(isingle==1&&trace...), force.x=xframe[,ipred], force.y=yhat, force.type="n", force.main=main, force.xlab=xlab, force.ylab=ylab, force.xlim=xlim, force.ylim=ylim, def.xaxt=if(xaxis.is.levs)"n"...), def.yaxt=if(yaxis.is.levs)"n"...)) PREFIX degree1. DROP .* KEEP >STANDARDPREFIXES|^force\.|^def\.|^drop\. >PREFIX|^degree1\. >CALLARGS|^force\.x$|^force\.y$|^force\.type$|^force\.main$|^force\.xlab$|^force\.ylab$|^force\.xlim$|^force\.ylim$|^def\.xaxt$|^def\.yaxt$ >EXPLICIT >PLOT_ARGS|^add$|^adj$|^bty$|^cex$|^cex\.axis$|^cex\.lab$|^cex\.main$|^cex\.sub$|^col$|^col\.axis$|^col\.lab$|^col\.main$|^col\.sub$|^crt$|^family$|^font$|^font$|^font\.axis$|^font\.lab$|^font\.main$|^font\.sub$|^lend$|^ljoin$|^lmitre$|^lty$|^lwd$|^main$|^pch$|^srt$|^xaxp$|^xaxs$|^xaxt$|^xlab$|^xlim$|^xlog$|^xpd$|^yaxp$|^yaxs$|^yaxt$|^ylab$|^ylim$|^ylog$ input dotnames force.x force.y force.type force.main force.xlab force.ylab force.xlim force.ylim def.xaxt def.yaxt after DROP and KEEP force.x force.y force.type force.main force.xlab force.ylab force.xlim force.ylim def.xaxt def.yaxt return dotnames x y type main xlab ylab xaxt yaxt xlim ylim graphics::plot.default(x=c(25,26.39,27.7...), y=c(5.312,5.527,5...), type="n", main="1 temp", xlab="", ylab="", xaxt="s", yaxt="s", xlim=c(25,93), ylim=c(-6.67,40.23)) --plot.degree2(draw.plot=TRUE) persp(wind:vis) theta 145 TRACE plot.persp called deprefix(persp, FNAME="persp", KEEP="PREFIX,PLOT.ARGS", FORMALS=persp.def.formals, TRACE=if(ipair==1&&trace>=...), force.x=x1grid, force.y=x2grid, force.z=yhat, force.xlim=range(x1grid), force.ylim=range(x2grid), force.zlim=if(is.null(ylim))yli...), force.xlab=xlab, force.ylab=ylab, force.theta=theta, force.phi=30, force.d=1, force.main=main2, def.cex.lab=cex.lab, def.cex.axis=cex.lab, def.zlab=zlab, def.ticktype="simple", def.nticks=def.nticks, def.cex=cex1, force.col="lightblue", def.border=NULL, def.shade=0.5) PREFIX persp. DROP NULL KEEP >STANDARDPREFIXES|^force\.|^def\.|^drop\. >PREFIX|^persp\. >CALLARGS|^force\.x$|^force\.y$|^force\.z$|^force\.xlim$|^force\.ylim$|^force\.zlim$|^force\.xlab$|^force\.ylab$|^force\.theta$|^force\.phi$|^force\.d$|^force\.main$|^def\.cex\.lab$|^def\.cex\.axis$|^def\.zlab$|^def\.ticktype$|^def\.nticks$|^def\.cex$|^force\.col$|^def\.border$|^def\.shade$ >EXPLICIT >PLOT_ARGS|^add$|^adj$|^bty$|^cex$|^cex\.axis$|^cex\.lab$|^cex\.main$|^cex\.sub$|^col$|^col\.axis$|^col\.lab$|^col\.main$|^col\.sub$|^crt$|^family$|^font$|^font$|^font\.axis$|^font\.lab$|^font\.main$|^font\.sub$|^lend$|^ljoin$|^lmitre$|^lty$|^lwd$|^main$|^pch$|^srt$|^xaxp$|^xaxs$|^xaxt$|^xlab$|^xlim$|^xlog$|^xpd$|^yaxp$|^yaxs$|^yaxt$|^ylab$|^ylim$|^ylog$ input dotnames force.x force.y force.z force.xlim force.ylim force.zlim force.xlab force.ylab force.theta force.phi force.d force.main def.cex.lab def.cex.axis def.zlab def.ticktype def.nticks def.cex force.col def.border def.shade after DROP and KEEP force.x force.y force.z force.xlim force.ylim force.zlim force.xlab force.ylab force.theta force.phi force.d force.main def.cex.lab def.cex.axis def.zlab def.ticktype def.nticks def.cex force.col def.shade return dotnames x y main xlab ylab cex.lab cex.axis zlab ticktype nticks cex shade z xlim ylim zlim theta phi d col persp(humidity:temp) theta -35 persp(temp:dpg) theta 235 > > caption <- "test 2 x 2 layout" > dopar(1,1,caption) test 2 x 2 layout > a <- earth(O3 ~ ., data=ozone1, nk=9, pmethod="n", degree=2) > plotmo(a, caption=caption) plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > > caption <- "test 1 x 1 layout" > dopar(1,1,caption) test 1 x 1 layout > a <- earth(O3 ~ ., data=ozone1, nk=4, pmethod="n", degree=2) > plotmo(a, caption=caption) plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > > caption <- "test plotmo basic params" > a <- earth(O3 ~ ., data=ozone1, degree=2) > dopar(3,2,caption) test plotmo basic params > plotmo(a, do.par=FALSE, degree1=1, nrug=-1, degree2=F, caption=caption, + main="test main", xlab="test xlab", ylab="test ylab") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > plotmo(a, do.par=FALSE, degree1=F, degree2=4, grid.func=mean, persp.col="white", ngrid2=10, persp.phi=40) > set.seed(2016) > plotmo(a, do.par=FALSE, degree1=1, degree1.lty=2, degree1.lwd=4, degree1.col=2, nrug=TRUE, degree2=F, main="nrug=300") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > plotmo(a, do.par=FALSE, degree1=1, nrug=-1, degree2=F, main="nrug=TRUE") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > set.seed(2016) > plotmo(a, do.par=FALSE, degree1=1, nrug=10, ngrid1=50, degree2=F, main="ngrid1=50 nrug=10") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > plotmo(a, do.par=FALSE, degree1=NA, degree2=1, persp.phi=60) # graph args > > caption <- "test plotmo xlim and ylim" > a <- earth(O3 ~ ., data=ozone1, degree=2) > dopar(5,3,caption) test plotmo xlim and ylim > plotmo(a, do.par=FALSE, degree1=2:3, degree2=4, caption=caption, xlab="ylim=default") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > plotmo(a, do.par=FALSE, degree1=2:3, degree2=4, ylim=NA, xlab="ylim=NA") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > plotmo(a, do.par=FALSE, degree1=2:3, degree2=4, ylim=c(0,20), xlab="ylim=c(0,20)") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > plotmo(a, do.par=FALSE, degree1=2:3, degree2=4, xlim=c(190,250), xlab="xlim=c(190,250)") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > plotmo(a, do.par=FALSE, degree1=2:3, degree2=4, xlim=c(190,250), ylim=c(11,18), xlab="xlim=c(190,250), ylim=c(11,18)") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > > # check various types of predictors with grid.func and ndiscrete > > varied.type.data <- data.frame( + y = 1:13, + num = c(1, 3, 2, 3, 4, 5, 6, 4, 5, 6.5, 3, 6, 5), # 7 unique values (but one is non integral) + int = c(1L, 1L, 3L, 3L, 4L, 4L, 3L, 5L, 3L, 6L, 7L, 8L, 10L), # 8 unique values + bool = c(F, F, F, F, F, T, T, T, T, T, T, T, T), + date = as.Date( + c("2018-08-01", "2018-08-02", "2018-08-03", + "2018-08-04", "2018-08-05", "2018-08-06", + "2018-08-07", "2018-08-08", "2018-08-08", + "2018-08-08", "2018-08-10", "2018-08-11", "2018-08-11")), + ord = ordered(c("ord3", "ord3", "ord3", + "ord1", "ord2", "ord3", + "ord1", "ord2", "ord3", + "ord1", "ord1", "ord1", "ord1"), + levels=c("ord1", "ord3", "ord2")), + fac = as.factor(c("fac1", "fac1", "fac1", + "fac2", "fac2", "fac2", + "fac3", "fac3", "fac3", + "fac1", "fac2", "fac3", "fac3")), + str = c("str1", "str1", "str1", # will be treated like a factor + "str2", "str2", "str2", + "str3", "str3", "str3", + "str3", "str3", "str3", "str3")) > > varied.type.lm <- lm(y ~ ., data = varied.type.data) > print(summary(varied.type.lm)) Call: lm(formula = y ~ ., data = varied.type.data) Residuals: 1 2 3 4 5 6 7 9.619e-02 1.673e-01 -2.635e-01 1.297e-02 -1.297e-02 -6.592e-17 -1.029e-01 8 9 10 11 12 13 1.297e-02 5.898e-17 -8.674e-17 5.204e-17 5.772e-02 3.220e-02 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) -7192.3724 6018.6749 -1.195 0.3546 num 0.2618 0.1919 1.364 0.3057 int 0.6437 0.2279 2.824 0.1058 boolTRUE -1.7185 0.5305 -3.240 0.0835 . date 0.4053 0.3392 1.195 0.3547 ord.L -0.2014 0.1726 -1.167 0.3637 ord.Q -1.5481 0.4045 -3.827 0.0620 . facfac2 0.4621 1.1289 0.409 0.7219 facfac3 -0.4299 0.5784 -0.743 0.5348 strstr2 1.3480 0.8570 1.573 0.2564 strstr3 5.0732 1.2534 4.048 0.0560 . --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 0.2471 on 2 degrees of freedom Multiple R-squared: 0.9993, Adjusted R-squared: 0.996 F-statistic: 297.9 on 10 and 2 DF, p-value: 0.003351 > set.seed(2018) > plotres(varied.type.lm, info=TRUE) > plotmo(varied.type.lm, pmethod="apartdep", all2=TRUE, ticktype="d", col.response="red", caption="varied.type.lm\npmethod=\"apartdep\" default grid func") calculating apartdep for num calculating apartdep for int calculating apartdep for bool calculating apartdep for date calculating apartdep for ord calculating apartdep for fac calculating apartdep for str calculating apartdep for num:int 01234567890 calculating apartdep for num:bool 01234567890 calculating apartdep for num:date 01234567890 calculating apartdep for num:ord 01234567890 calculating apartdep for num:fac 01234567890 calculating apartdep for num:str 01234567890 calculating apartdep for int:bool 01234567890 calculating apartdep for int:date 01234567890 calculating apartdep for int:ord 01234567890 calculating apartdep for int:fac 01234567890 calculating apartdep for int:str 01234567890 calculating apartdep for bool:date 0123456790 calculating apartdep for bool:ord 0123456790 calculating apartdep for bool:fac 0123456790 calculating apartdep for bool:str 0123456790 calculating apartdep for date:ord 01234567890 calculating apartdep for date:fac 01234567890 calculating apartdep for date:str 01234567890 calculating apartdep for ord:fac 01234567890 calculating apartdep for ord:str 01234567890 calculating apartdep for fac:str 01234567890 > plotmo(varied.type.lm, all2=TRUE, ticktype="d", col.response="red", caption="varied.type.lm\ndefault grid func") plotmo grid: num int bool date ord fac str 4 4 TRUE 2018-08-07 ord1 fac3 str3 > plotmo(varied.type.lm, all2=TRUE, ndiscre=1, caption="varied.type.lm\nndiscrete=1") plotmo grid: num int bool date ord fac str 4 4 TRUE 2018-08-07 ord1 fac3 str3 > plotmo(varied.type.lm, all2=TRUE, ndiscr=2, caption="varied.type.lm\nndiscrete=2") plotmo grid: num int bool date ord fac str 4 4 TRUE 2018-08-07 ord1 fac3 str3 > plotmo(varied.type.lm, all2=TRUE, ndis=100, caption="varied.type.lm\nndiscrete=100") plotmo grid: num int bool date ord fac str 4 4 TRUE 2018-08-07 ord1 fac3 str3 > cat("grid.func=median:\n") grid.func=median: > plotmo(varied.type.lm, all2=TRUE, grid.func=median, caption="varied.type.lm\ngrid.func=median") Warning: grid.func failed for ord, so will use the most common value of ord Warning: grid.func failed for fac, so will use the most common value of fac Warning: grid.func failed for str, so will use the most common value of str Warning: grid.func failed for ord, so will use the most common value of ord Warning: grid.func failed for fac, so will use the most common value of fac Warning: grid.func failed for str, so will use the most common value of str plotmo grid: num int bool date ord fac str 4 4 TRUE 2018-08-07 ord1 fac3 str3 > cat("grid.func=quantile:\n") grid.func=quantile: > plotmo(varied.type.lm, all2=TRUE, grid.func=function(x, ...) quantile(x, 0.5), caption="varied.type.lm\ngrid.func=function(x, ...) quantile(x, 0.5)") Warning: grid.func failed for date, so will use the default grid.func for date Warning: grid.func failed for ord, so will use the most common value of ord Warning: grid.func failed for fac, so will use the most common value of fac Warning: grid.func failed for str, so will use the most common value of str Warning: grid.func failed for date, so will use the default grid.func for date Warning: grid.func failed for ord, so will use the most common value of ord Warning: grid.func failed for fac, so will use the most common value of fac Warning: grid.func failed for str, so will use the most common value of str plotmo grid: num int bool date ord fac str 4 4 TRUE 2018-08-07 ord1 fac3 str3 > cat("grid.func=mean:\n") grid.func=mean: > plotmo(varied.type.lm, all2=TRUE, grid.func=mean, caption="varied.type.lm\ngrid.func=mean") Warning in mean.default(x, na.rm = TRUE) : argument is not numeric or logical: returning NA Warning: grid.func returned NA for ord, so will use the default grid.func for ord Warning in mean.default(x, na.rm = TRUE) : argument is not numeric or logical: returning NA Warning: grid.func returned NA for fac, so will use the default grid.func for fac Warning in mean.default(x, na.rm = TRUE) : argument is not numeric or logical: returning NA Warning: grid.func returned NA for str, so will use the default grid.func for str Warning in mean.default(x, na.rm = TRUE) : argument is not numeric or logical: returning NA Warning: grid.func returned NA for ord, so will use the default grid.func for ord Warning in mean.default(x, na.rm = TRUE) : argument is not numeric or logical: returning NA Warning: grid.func returned NA for fac, so will use the default grid.func for fac Warning in mean.default(x, na.rm = TRUE) : argument is not numeric or logical: returning NA Warning: grid.func returned NA for str, so will use the default grid.func for str plotmo grid: num int bool date ord fac str 4.115385 4 TRUE 2018-08-06 ord1 fac3 str3 > > varied.type.earth <- earth(y ~ ., data = varied.type.data, thresh=0, penalty=-1, trace=1) x[13,10] with colnames num int boolTRUE date ord.L ord.Q facfac2 facfac3 strstr2... y[13,1] with colname y, and values 1, 2, 3, 4, 5, 6, 7, 8, 9, 10... Forward pass term 1, 2, 4, 6, 8, 10, 12, 14, 16, 18 Reached maximum RSq 1.0000 at 19 terms, 13 terms used (RSq 1.0000) After forward pass GRSq 1.000 RSq 1.000 Prune backward penalty -1 nprune null: selected 13 of 13 terms, and 9 of 10 preds After pruning pass GRSq 1 RSq 1 > print(summary(varied.type.earth)) Call: earth(formula=y~., data=varied.type.data, trace=1, thresh=0, penalty=-1) coefficients (Intercept) 9.5964912 boolTRUE -2.0473684 ord.L 0.4986964 ord.Q 0.0859470 facfac2 -4.4157895 facfac3 -3.1526316 strstr2 3.2526316 h(4-num) 1.4105263 h(num-4) -0.3157895 h(4-int) 2.1157895 h(int-4) 0.3421053 h(17749-date) -3.8210526 h(date-17749) 1.4368421 Selected 13 of 13 terms, and 9 of 10 predictors Termination condition: Reached maximum RSq 1.0000 at 13 terms Importance: date, facfac2, facfac3, int, strstr2, boolTRUE, num, ord.L, ... Number of terms at each degree of interaction: 1 12 (additive model) GCV 0 RSS 0 GRSq 1 RSq 1 > set.seed(2018) > plotres(varied.type.earth, info=TRUE) Warning in cor(rank(x), rank(y)) : the standard deviation is zero Warning: draw.density.along.the.bottom: cannot determine density > plotmo(varied.type.earth, all1=TRUE, all2=TRUE, persp.ticktype="d", col.response="red") plotmo grid: num int bool date ord fac str 4 4 TRUE 2018-08-07 ord1 fac3 str3 > > # term.plot calls predict.earth with an se parameter, even with termplot(se=FALSE) > > caption <- "basic earth test against termplot" > dopar(4,4,caption) basic earth test against termplot > make.space.for.caption("test caption1") > a <- earth(O3 ~ ., data=ozone1, degree=2) > plotmo(a, do.par=FALSE, ylim=NA, caption=caption, degree2=FALSE) plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > cat("Ignore warning: predict.earth ignored argument \"se.fit\"\n") Ignore warning: predict.earth ignored argument "se.fit" > termplot(a) Warning: predict.earth ignored argument 'se.fit' > > caption <- "test change order of earth predictors and cex" > dopar(4,4,caption) test change order of earth predictors and cex > # minspan=1 to force two degree2 graphs for the test (wasn't necessary in old versions of earth) > a <- earth(doy ~ humidity + temp + wind, data=ozone1, degree=2, minspan=1) > plotmo(a, do.par=FALSE, ylim=NA, caption=caption, degree2=c(1,2), cex=1.2) plotmo grid: humidity temp wind 64 62 5 > termplot(a) Warning: predict.earth ignored argument 'se.fit' > > caption <- "test all1=TRUE" > a <- earth(doy ~ humidity + temp + wind, data=ozone1, degree=2) > plotmo(a, caption=caption, all1=TRUE, persp.ticktype="d", persp.nticks=2) plotmo grid: humidity temp wind 64 62 5 > caption <- "test all2=TRUE" > print(summary(a)) Call: earth(formula=doy~humidity+temp+wind, data=ozone1, degree=2) coefficients (Intercept) 150.868918 h(humidity-28) 1.614397 h(49-temp) -6.984397 h(3-wind) 50.527668 h(28-humidity) * h(temp-53) 8.123127 h(28-humidity) * h(53-temp) 1.520105 h(28-humidity) * h(temp-45) 5.390040 h(28-humidity) * h(temp-50) -12.953206 h(41-humidity) * h(wind-3) -0.996454 Selected 9 of 18 terms, and 3 of 3 predictors Termination condition: Reached nk 21 Importance: wind, temp, humidity Number of terms at each degree of interaction: 1 3 5 GCV 8954.829 RSS 2590958 GRSq 0.1805267 RSq 0.2771303 > plotmo(a, caption=caption, all2=TRUE) plotmo grid: humidity temp wind 64 62 5 > > oz <- ozone1[150:200,c("O3","temp","humidity","ibh")] > a.glob <- earth(O3~temp+humidity, data=oz, degree=2) > ad.glob <- earth(oz[,2:3], oz[,1], degree=2) > func1 <- function() + { + caption <- "test environments and finding the correct data" + dopar(4,4,caption) + set.seed(2016) + + plotmo(a.glob, do.par=FALSE, main="a.glob oz", + degree1=1, all2=1, degree2=1, type2="im", + col.response=3, pt.pch=20, trace=2) + mtext(caption, outer=TRUE, font=2, line=1.5, cex=1) + plotmo(ad.glob, do.par=FALSE, main="ad.glob oz", + degree1=1, all2=1, degree2=1, type2="im", + col.response=3, pch.response=20, trace=2) # pch.response test backcompat + + a <- earth(O3~temp+humidity, data=oz, degree=2) + plotmo(a, do.par=FALSE, main="a oz", + degree1=1, all2=1, degree2=1, type2="im", + col.response=3, pt.pch=20) + + ad <- earth(oz[,2:3], oz[,1], degree=2) + plotmo(ad, do.par=FALSE, main="ad oz", + degree1=1, all2=1, degree2=1, type2="im", + col.response=3, pt.pch=20) + + oz.org <- oz + oz10 <- 10 * oz # multiply by 10 so we can see by the axis labels if right data is being used + oz <- oz10 # oz is now local to this function, but multiplied by 10 + a.oz10 <- earth(O3~temp+humidity, data=oz, degree=2) + a.oz10.keep <- earth(O3~temp+humidity, data=oz, degree=2, keepxy=TRUE) + plotmo(a.oz10, do.par=FALSE, main="a oz10", + degree1=1, all2=1, degree2=1, type2="im", + col.response=3, pt.pch=20) + + ad.oz10 <- earth(oz[,2:3], oz[,1], degree=2) + ad.oz10.keep <- earth(oz[,2:3], oz[,1], degree=2, keepxy=TRUE) + plotmo(ad.oz10, do.par=FALSE, main="ad oz10", + degree1=1, all2=1, degree2=1, type2="im", + col.response=3, pt.pch=20) + + func2 <- function() { + a.func <- earth(O3 ~ temp + humidity, data=oz10, degree=2) + plotmo(a.func, do.par=FALSE, main="a.func oz10", + degree1=1, all2=1, degree2=1, type2="im", + col.response=3, pt.pch=20) + + ad.func <- earth(oz10[,2:3], oz10[,1], degree=2) + plotmo(ad.func, do.par=FALSE, main="ad.func oz10", + degree1=1, all2=1, degree2=1, type2="im", + col.response=3, pt.pch=20) + + caption <- "test environments and finding the correct data, continued" + dopar(4,4,caption) + + oz <- .1 * oz.org + a.func <- earth(O3~temp+ humidity , data=oz, degree=2) + plotmo(a.func, do.par=FALSE, main="a.func oz.1", + degree1=1, all2=1, degree2=1, type2="im", + col.response=3, pt.pch=20) + + ad.func <- earth(oz[,2:3], oz[,1], degree=2) + plotmo(ad.func, do.par=FALSE, main="ad.func oz.1", + degree1=1, all2=1, degree2=1, type2="im", + col.response=3, pt.pch=20) + + plotmo(a.oz10.keep, do.par=FALSE, main="func1:a.oz10.keep", + degree1=1, all2=1, degree2=1, type2="im", + col.response=3, pt.pch=20) + + plotmo(ad.oz10.keep, do.par=FALSE, main="func1:ad.oz10.keep", + degree1=1, all2=1, degree2=1, type2="im", + col.response=3, pt.pch=20) + + cat("Expect error msg: formal argument \"do.par\" matched by multiple actual arguments\n") + expect.err(try(plotmo(a.oz10, do.par=FALSE, main="func1:a.oz10", + degree1=1, all2=1, degree2=1, type2="im", + col.response=3, pt.pch=20, do.par=FALSE))) + } + func2() + + y <- 3:11 + x1 <- c(1,3,2,4,5,6,6,6,6) + x2 <- c(2,3,4,5,6,7,8,9,10) + frame <- data.frame(y=y, x1=x1, x2=x2) + foo <- function() + { + lm.18.out <- lm(y~x1+x2, model=FALSE) + x1[2] <- 18 + y[3] <- 19 + frame <- data.frame(y=y, x1=x1, x2=x2) + list(lm.18.out = lm.18.out, + lm.18 = lm(y~x1+x2), + lm.18.keep = lm(y~x1+x2, x=TRUE, y=TRUE), + lm.18.frame = lm(y~x1+x2, data=frame)) + } + temp <- foo() + lm.18.out <- temp$lm.18.out + lm.18 <- temp$lm.18 + lm.18.keep <- temp$lm.18.keep + lm.18.frame <- temp$lm.18.frame + + # following should all use the x1 and y inside foo + + cat("==lm.18.out\n") + plotmo(lm.18.out, main="lm.18.out", + do.par=FALSE, degree1=1, clip=FALSE, ylim=c(0,20), + col.response=2, pt.pch=20) + + cat("==lm.18\n") + plotmo(lm.18, main="lm.18", + do.par=FALSE, degree1=1, clip=FALSE, ylim=c(0,20), + col.response=2, pt.pch=20) + + cat("==lm.18.keep\n") + plotmo(lm.18.keep, main="lm.18.keep", trace=2, + do.par=FALSE, degree1=1, clip=FALSE, ylim=c(0,20), + col.response=2, pt.pch=20) + + cat("==lm.18.frame\n") + plotmo(lm.18.frame, main="lm.18.frame", + do.par=FALSE, degree1=1, clip=FALSE, ylim=c(0,20), + col.response=2, pt.pch=20) + } > func1() test environments and finding the correct data plotmo trace 2: plotmo(object=a.glob, type2="im", degree1=1, degree2=1, all2=1, do.par=FALSE, trace=2, main="a.glob oz", col.response=3, pt.pch=20) --get.model.env for object with class earth object call is earth(formula=O3~temp+humidity, data=oz, degree=2) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'a.glob' --plotmo_x for earth object get.object.x: object$x is NULL (and it has no colnames) object call is earth(formula=O3~temp+humidity, data=oz, degree=2) get.x.from.model.frame: formula(object) is O3 ~ temp + humidity naked formula is the same formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) object$data is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names O3 temp humidity ibh na.action(object) is "na.fail" stats::model.frame(O3 ~ temp + humidity, data=call$data, na.action="na.fail") x=model.frame[,-1] is usable and has column names temp humidity plotmo_x returned[51,2]: temp humidity 150 48 81 151 59 63 152 67 58 ... 66 68 200 79 65 ----Metadata: plotmo_predict with nresponse=NULL and newdata=NULL calling predict.earth with NULL newdata stats::predict(earth.object, NULL, type="response") predict returned[51,1]: O3 1 7.990058 2 11.446254 3 13.959851 ... 13.645652 51 18.207402 predict after processing with nresponse=NULL is [51,1]: O3 1 7.990058 2 11.446254 3 13.959851 ... 13.645652 51 18.207402 ----Metadata: plotmo_fitted with nresponse=NULL stats::fitted(object=earth.object) fitted(object) returned[51,1]: O3 1 7.990058 2 11.446254 3 13.959851 ... 13.645652 51 18.207402 fitted(object) after processing with nresponse=NULL is [51,1]: O3 1 7.990058 2 11.446254 3 13.959851 ... 13.645652 51 18.207402 ----Metadata: plotmo_y with nresponse=NULL --plotmo_y with nresponse=NULL for earth object get.object.y: object$y is NULL (and it has no colnames) object call is earth(formula=O3~temp+humidity, data=oz, degree=2) get.y.from.model.frame: formula(object) is O3 ~ temp + humidity formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) object$data is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names O3 temp humidity ibh na.action(object) is "na.fail" stats::model.frame(O3 ~ temp + humidity, data=call$data, na.action="na.fail") y=model.frame[,1] is usable and has column name O3 plotmo_y returned[51,1]: O3 150 2 151 12 152 22 ... 17 200 14 plotmo_y after processing with nresponse=NULL is [51,1]: O3 150 2 151 12 152 22 ... 17 200 14 converted nresponse=NA to nresponse=1 nresponse=1 (was NA) ncol(fitted) 1 ncol(predict) 1 ncol(y) 1 ----Metadata: plotmo_y with nresponse=1 --plotmo_y with nresponse=1 for earth object get.object.y: object$y is NULL (and it has no colnames) object call is earth(formula=O3~temp+humidity, data=oz, degree=2) get.y.from.model.frame: formula(object) is O3 ~ temp + humidity formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) object$data is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names O3 temp humidity ibh na.action(object) is "na.fail" stats::model.frame(O3 ~ temp + humidity, data=call$data, na.action="na.fail") y=model.frame[,1] is usable and has column name O3 got model response from model.frame(O3 ~ temp + humidity, data=call$data, na.action="na.fail") plotmo_y returned[51,1]: O3 150 2 151 12 152 22 ... 17 200 14 plotmo_y after processing with nresponse=1 is [51,1]: O3 150 2 151 12 152 22 ... 17 200 14 got response name "O3" from yhat resp.levs is NULL ----Metadata: done number of x values: temp 27 humidity 27 ----plotmo_singles for earth object singles: 1 temp ----plotmo_pairs for earth object pairs: [,1] [,2] [1,] "1 temp" "2 humidity" ----Figuring out ylim --get.ylim.by.dummy.plots --plot.degree1(draw.plot=FALSE) degree1 plot1 (pmethod "plotmo") variable temp newdata[50,2]: temp humidity 1 48.00000 68 2 48.91837 68 3 49.83673 68 ... 50.75510 68 50 93.00000 68 stats::predict(earth.object, data.frame[50,2], type="response") predict returned[50,1]: O3 1 7.990058 2 8.278609 3 8.567159 ... 8.855710 50 29.834221 predict after processing with nresponse=1 is [50,1]: O3 1 7.990058 2 8.278609 3 8.567159 ... 8.855710 50 29.834221 --plot.degree2(draw.plot=FALSE) degree2 plot1 (pmethod "plotmo") variables temp:humidity newdata[400,2]: temp humidity 1 48.00000 33 2 50.36842 33 3 52.73684 33 ... 55.10526 33 400 93.00000 90 stats::predict(earth.object, data.frame[400,2], type="response") predict returned[400,1]: O3 1 7.990058 2 8.734215 3 9.478372 ... 10.222529 400 33.851866 predict after processing with nresponse=1 is [400,1]: O3 1 7.990058 2 8.734215 3 9.478372 ... 10.222529 400 33.851866 --done get.ylim.by.dummy.plots ylim c(1.936, 33.94) clip TRUE --plot.degree1(draw.plot=TRUE) plotmo grid: temp humidity 80 68 graphics::plot.default(x=c(48,48.92,49.8...), y=c(7.99,8.279,8...), type="n", main="a.glob oz", xlab="", ylab="", xaxt="s", yaxt="s", xlim=c(47.98,93.08), ylim=c(1.94,33.94)) --plot.degree2(draw.plot=TRUE) plotmo trace 2: plotmo(object=ad.glob, type2="im", degree1=1, degree2=1, all2=1, do.par=FALSE, trace=2, main="ad.glob oz", col.response=3, pch.response=20) --get.model.env for object with class earth object call is earth(x=oz[, 2:3], y=oz[, 1], degree=2) assuming the environment of the earth model is that of plotmo's caller: env(caption) --plotmo_prolog for earth object 'ad.glob' --plotmo_x for earth object get.object.x: object$x is NULL (and it has no colnames) object call is earth(x=oz[, 2:3], y=oz[, 1], degree=2) get.x.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$x, env(caption)) getCall(object)$x is usable and has column names temp humidity plotmo_x returned[51,2]: temp humidity 150 48 81 151 59 63 152 67 58 ... 66 68 200 79 65 ----Metadata: plotmo_predict with nresponse=NULL and newdata=NULL calling predict.earth with NULL newdata stats::predict(earth.object, NULL, type="response") predict returned[51,1]: oz[, 1] 1 7.990058 2 11.446254 3 13.959851 ... 13.645652 51 18.207402 predict after processing with nresponse=NULL is [51,1]: oz[, 1] 1 7.990058 2 11.446254 3 13.959851 ... 13.645652 51 18.207402 ----Metadata: plotmo_fitted with nresponse=NULL stats::fitted(object=earth.object) fitted(object) returned[51,1]: oz[, 1] 1 7.990058 2 11.446254 3 13.959851 ... 13.645652 51 18.207402 fitted(object) after processing with nresponse=NULL is [51,1]: oz[, 1] 1 7.990058 2 11.446254 3 13.959851 ... 13.645652 51 18.207402 ----Metadata: plotmo_y with nresponse=NULL --plotmo_y with nresponse=NULL for earth object get.object.y: object$y is NULL (and it has no colnames) object call is earth(x=oz[, 2:3], y=oz[, 1], degree=2) get.y.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$y, env(caption)) getCall(object)$y is usable but without colnames so we will keep on searching names(call) is "" "x" "y" "degree" the name of argument 2 is "y" so we will not process it with argn object$y is NULL call$y is usable but without colnames but we will use it anyway colname was NULL now "y" plotmo_y returned[51,1]: y 1 2 2 12 3 22 ... 17 51 14 plotmo_y after processing with nresponse=NULL is [51,1]: y 1 2 2 12 3 22 ... 17 51 14 converted nresponse=NA to nresponse=1 nresponse=1 (was NA) ncol(fitted) 1 ncol(predict) 1 ncol(y) 1 ----Metadata: plotmo_y with nresponse=1 --plotmo_y with nresponse=1 for earth object get.object.y: object$y is NULL (and it has no colnames) object call is earth(x=oz[, 2:3], y=oz[, 1], degree=2) get.y.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$y, env(caption)) getCall(object)$y is usable but without colnames so we will keep on searching names(call) is "" "x" "y" "degree" the name of argument 2 is "y" so we will not process it with argn object$y is NULL call$y is usable but without colnames but we will use it anyway got model response from getCall(object)$y colname was NULL now "y" plotmo_y returned[51,1]: y 1 2 2 12 3 22 ... 17 51 14 plotmo_y after processing with nresponse=1 is [51,1]: y 1 2 2 12 3 22 ... 17 51 14 got response name "oz[, 1]" from yhat resp.levs is NULL ----Metadata: done number of x values: temp 27 humidity 27 ----plotmo_singles for earth object singles: 1 temp ----plotmo_pairs for earth object pairs: [,1] [,2] [1,] "1 temp" "2 humidity" ----Figuring out ylim --get.ylim.by.dummy.plots --plot.degree1(draw.plot=FALSE) degree1 plot1 (pmethod "plotmo") variable temp newdata[50,2]: temp humidity 1 48.00000 68 2 48.91837 68 3 49.83673 68 ... 50.75510 68 50 93.00000 68 stats::predict(earth.object, data.frame[50,2], type="response") predict returned[50,1]: oz[, 1] 1 7.990058 2 8.278609 3 8.567159 ... 8.855710 50 29.834221 predict after processing with nresponse=1 is [50,1]: oz[, 1] 1 7.990058 2 8.278609 3 8.567159 ... 8.855710 50 29.834221 --plot.degree2(draw.plot=FALSE) degree2 plot1 (pmethod "plotmo") variables temp:humidity newdata[400,2]: temp humidity 1 48.00000 33 2 50.36842 33 3 52.73684 33 ... 55.10526 33 400 93.00000 90 stats::predict(earth.object, data.frame[400,2], type="response") predict returned[400,1]: oz[, 1] 1 7.990058 2 8.734215 3 9.478372 ... 10.222529 400 33.851866 predict after processing with nresponse=1 is [400,1]: oz[, 1] 1 7.990058 2 8.734215 3 9.478372 ... 10.222529 400 33.851866 --done get.ylim.by.dummy.plots ylim c(1.931, 34) clip TRUE --plot.degree1(draw.plot=TRUE) plotmo grid: temp humidity 80 68 graphics::plot.default(x=c(48,48.92,49.8...), y=c(7.99,8.279,8...), type="n", main="ad.glob oz", xlab="", ylab="", xaxt="s", yaxt="s", xlim=c(48,93), ylim=c(1.93,34)) --plot.degree2(draw.plot=TRUE) plotmo grid: temp humidity 80 68 plotmo grid: temp humidity 80 68 plotmo grid: temp humidity 800 680 plotmo grid: temp humidity 800 680 plotmo grid: temp humidity 800 680 plotmo grid: temp humidity 800 680 test environments and finding the correct data, continued plotmo grid: temp humidity 8 6.8 plotmo grid: temp humidity 8 6.8 plotmo grid: temp humidity 800 680 plotmo grid: temp humidity 800 680 Expect error msg: formal argument "do.par" matched by multiple actual arguments Error in plotmo(a.oz10, do.par = FALSE, main = "func1:a.oz10", degree1 = 1, : formal argument "do.par" matched by multiple actual arguments Got expected error from try(plotmo(a.oz10, do.par = FALSE, main = "func1:a.oz10", degree1 = 1, all2 = 1, degree2 = 1, type2 = "im", col.response = 3, pt.pch = 20, do.par = FALSE)) ==lm.18.out plotmo grid: x1 x2 6 6 ==lm.18 plotmo grid: x1 x2 6 6 ==lm.18.keep plotmo trace 2: plotmo(object=lm.18.keep, degree1=1, do.par=FALSE, clip=FALSE, ylim=c(0,20), trace=2, main="lm.18.keep", col.response=2, pt.pch=20) --get.model.env for object with class lm object call is lm(formula=y~x1+x2, x=TRUE, y=TRUE) using the environment saved in $terms of the lm model: env(frame, lm.18.out, x1, y) --plotmo_prolog for lm object 'lm.18.keep' --plotmo_x for lm object get.object.x: object$x is usable and has column names (Intercept) x1 x2 dropped "(Intercept)" column from x plotmo_x returned[9,2]: x1 x2 1 1 2 2 18 3 3 2 4 ... 4 5 9 6 10 ----Metadata: plotmo_predict with nresponse=NULL and newdata=NULL calling predict.lm with NULL newdata stats::predict(lm.object, NULL, type="response") predict returned[9,1] with no column names: 1 8.098674 2 3.323243 3 8.792796 ... 8.674176 9 10.564707 predict after processing with nresponse=NULL is [9,1] with no column names: 1 8.098674 2 3.323243 3 8.792796 ... 8.674176 9 10.564707 ----Metadata: plotmo_fitted with nresponse=NULL stats::fitted(object=lm.object) fitted(object) returned[9,1] with no column names: 1 8.098674 2 3.323243 3 8.792796 ... 8.674176 9 10.564707 fitted(object) after processing with nresponse=NULL is [9,1] with no column names: 1 8.098674 2 3.323243 3 8.792796 ... 8.674176 9 10.564707 ----Metadata: plotmo_y with nresponse=NULL --plotmo_y with nresponse=NULL for lm object get.object.y: object$y is usable but without colnames so we will keep on searching object call is lm(formula=y~x1+x2, x=TRUE, y=TRUE) get.y.from.model.frame: formula(object) is y ~ x1 + x2 formula is valid, now looking for data for the model.frame object$model is usable and has column names y x1 x2 y=model.frame[,1] is usable and has column name y plotmo_y returned[9,1]: y 1 3 2 4 3 19 ... 6 9 11 plotmo_y after processing with nresponse=NULL is [9,1]: y 1 3 2 4 3 19 ... 6 9 11 converted nresponse=NA to nresponse=1 nresponse=1 (was NA) ncol(fitted) 1 ncol(predict) 1 ncol(y) 1 ----Metadata: plotmo_y with nresponse=1 --plotmo_y with nresponse=1 for lm object get.object.y: object$y is usable but without colnames so we will keep on searching object call is lm(formula=y~x1+x2, x=TRUE, y=TRUE) get.y.from.model.frame: formula(object) is y ~ x1 + x2 formula is valid, now looking for data for the model.frame object$model is usable and has column names y x1 x2 y=model.frame[,1] is usable and has column name y got model response from object$model plotmo_y returned[9,1]: y 1 3 2 4 3 19 ... 6 9 11 plotmo_y after processing with nresponse=1 is [9,1]: y 1 3 2 4 3 19 ... 6 9 11 got response name "y" from yfull resp.levs is NULL ----Metadata: done number of x values: x1 6 x2 9 ----plotmo_singles for lm object singles: 1 x1 ----plotmo_pairs for lm object formula(object) returned y ~ x1 + x2 formula.vars "x1" "x2" term.labels "x1" "x2" plotmo_pairs_from_term_labels term.labels: "x1" "x2" "x1" "x2" pred.names: "x1" "x2" considering x1 considering x2 considering x1 considering x2 no pairs ----Figuring out ylim ylim c(0, 20) clip FALSE --plot.degree1(draw.plot=TRUE) plotmo grid: x1 x2 6 6 degree1 plot1 (pmethod "plotmo") variable x1 newdata[50,2]: x1 x2 1 1.000000 6 2 1.346939 6 3 1.693878 6 ... 2.040816 6 50 18.000000 6 stats::predict(lm.object, data.frame[50,2], type="response") predict returned[50,1] with no column names: 1 10.107826 2 10.000117 3 9.892409 ... 9.784700 50 4.830107 predict after processing with nresponse=1 is [50,1]: predict 1 10.107826 2 10.000117 3 9.892409 ... 9.784700 50 4.830107 graphics::plot.default(x=c(1,1.347,1.694...), y=c(10.11,10,9.89...), type="n", main="lm.18.keep", xlab="", ylab="", xaxt="s", yaxt="s", xlim=c(1,18.04), ylim=c(0,20)) ==lm.18.frame plotmo grid: x1 x2 6 6 > > caption <- "test earth formula versus x,y model" > # dopar(4,4,caption) > # mtext(caption, outer=TRUE, font=2, line=1.5, cex=1) > a <- earth(O3 ~ ., data=ozone1, degree=2) > plotmo(a, caption="test earth formula versus xy model (formula)") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > a <- earth(ozone1[, -1], ozone1[,1], degree=2) > plotmo(a, caption="test earth formula versus xy model (xy)") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > > # single predictor > caption <- "test earth(O3~wind, data=ozone1, degree=2), single predictor" > dopar(2,2,caption) test earth(O3~wind, data=ozone1, degree=2), single predictor > a <- earth(O3~wind, data=ozone1, degree=2) > plotmo(a) > > caption = "se=2, earth(doy~humidity+temp+wind, data=ozone1) versus termplot (expect no se lines)" > dopar(3,3,caption) se=2, earth(doy~humidity+temp+wind, data=ozone1) versus termplot (expect no se lines) > mtext(caption, outer=TRUE, font=2, line=1.5, cex=1) > # minspan=1 to force two degree2 graphs for the test (wasn't necessary in old versions of earth) > a <- earth(doy~humidity + temp + wind, data=ozone1, degree=2, minspan=1) > cat("Ignore warning: predict.earth ignored argument \"se\"\n") Ignore warning: predict.earth ignored argument "se" > termplot(a) Warning: predict.earth ignored argument 'se.fit' > plotmo(a, do.par=FALSE, ylim=NA, degree2=c(1:2), clip=FALSE, caption=caption) plotmo grid: humidity temp wind 64 62 5 > > # test fix to bug reported by Joe Retzer, FIXED Dec 7, 2007 > N <- 650 > set.seed(2007) > q_4 <- runif(N, -1, 1) > q_2102 <- runif(N, -1, 1) > q_2104 <- runif(N, -1, 1) > q_3105 <- runif(N, -1, 1) > q_3106 <- runif(N, -1, 1) > q_4104 <- runif(N, -1, 1) > q_6101 <- runif(N, -1, 1) > q_6103 <- runif(N, -1, 1) > q_7104 <- runif(N, -1, 1) > q_3109 <- runif(N, -1, 1) > q_4103 <- runif(N, -1, 1) > q_2111 <- runif(N, -1, 1) > q_3107 <- runif(N, -1, 1) > q_3101 <- runif(N, -1, 1) > q_3104 <- runif(N, -1, 1) > q_7107 <- runif(N, -1, 1) > depIndex <- sin(1.0 * q_4 + rnorm(650, sd=.8)) + sin(1.8 * q_2102 + rnorm(650, sd=.8)) + sin(1.3 * q_2104 + rnorm(650, sd=.8)) + sin(1.4 * q_3105 + rnorm(650, sd=.8)) + + sin(1.5 * q_3106 + rnorm(650, sd=.8)) + sin(1.6 * q_4104 + rnorm(650, sd=.8)) + sin(1.8 * q_6101 + rnorm(650, sd=.8)) + sin(1.8 * q_6103 + rnorm(650, sd=.8)) + + sin(1.9 * q_7104 + rnorm(650, sd=.8)) + sin(2.0 * q_3109 + rnorm(650, sd=.8)) > > regDatCWD <- as.data.frame(cbind(depIndex, q_4, q_2102, q_2104, q_3105, q_3106, q_4104, q_6101, q_6103, q_7104, q_3109, q_4103, q_2111, q_3107, q_3101, q_3104, q_7107)) > cat("--plotmo(earthobj5)--\n") --plotmo(earthobj5)-- > earthobj5 <- earth(depIndex ~ q_4+q_2102+q_2104+q_3105+q_3106+q_4104+q_6101+q_6103+q_7104+q_3109+q_4103+q_2111+q_3107+q_3101+q_3104+q_7107, data=regDatCWD) > print(summary(earthobj5, digits = 2)) Call: earth(formula=depIndex~q_4+q_2102+q_2104+q_3105+q_3106+q_4104+q_...), data=regDatCWD) coefficients (Intercept) 1.79 h(0.782075-q_4) -0.97 h(q_4-0.782075) -5.36 h(q_2102- -0.664223) 1.19 h(q_2104- -0.954733) 0.85 h(0.83147-q_3105) -0.77 h(0.492009-q_3106) -0.93 h(q_4104- -0.671276) 1.02 h(0.483685-q_6101) -1.10 h(0.914724-q_6103) -1.12 h(0.545206-q_7104) -1.19 h(-0.157173-q_3109) -0.96 h(q_3109- -0.157173) 1.03 Selected 13 of 21 terms, and 10 of 16 predictors Termination condition: RSq changed by less than 0.001 at 21 terms Importance: q_6103, q_4104, q_2102, q_7104, q_3109, q_6101, q_2104, q_4, ... Number of terms at each degree of interaction: 1 12 (additive model) GCV 2.5 RSS 1509 GRSq 0.53 RSq 0.57 > plotmo(earthobj5) plotmo grid: q_4 q_2102 q_2104 q_3105 q_3106 q_4104 0.05726625 0.01725001 0.004659335 -0.01826179 -0.00913319 0.01401429 q_6101 q_6103 q_7104 q_3109 q_4103 q_2111 -0.04790454 0.03681165 0.01827148 -0.09899272 -0.0623349 0.01007481 q_3107 q_3101 q_3104 q_7107 -0.02481171 -0.07733527 -0.003053319 0.02821214 > > # long predictor names > > a.rather.long.in.fact.very.long.name.q_4 <- q_4 > a.rather.long.in.fact.very.long.name.q_2102 <- q_2102 > a.rather.long.in.fact.very.long.name.q_2104 <- q_2104 > a.rather.long.in.fact.very.long.name.q_3105 <- q_3105 > a.rather.long.in.fact.very.long.name.q_3106 <- q_3106 > a.rather.long.in.fact.very.long.name.q_4104 <- q_4104 > a.rather.long.in.fact.very.long.name.q_6101 <- q_6101 > a.rather.long.in.fact.very.long.name.q_6103 <- q_6103 > a.rather.long.in.fact.very.long.name.q_7104 <- q_7104 > a.rather.long.in.fact.very.long.name.q_3109 <- q_3109 > a.rather.long.in.fact.very.long.name.q_4103 <- q_4103 > a.rather.long.in.fact.very.long.name.q_2111 <- q_2111 > a.rather.long.in.fact.very.long.name.q_3107 <- q_3107 > a.rather.long.in.fact.very.long.name.q_3101 <- q_3101 > a.rather.long.in.fact.very.long.name.q_3104 <- q_3104 > a.rather.long.in.fact.very.long.name.q_7107 <- q_7107 > a.rather.long.in.fact.very.long.name.for.the.response <- depIndex > a.rather.long.in.fact.very.long.name.for.the.dataframe <- + as.data.frame(cbind( + a.rather.long.in.fact.very.long.name.for.the.response, + a.rather.long.in.fact.very.long.name.q_4, + a.rather.long.in.fact.very.long.name.q_2102, + a.rather.long.in.fact.very.long.name.q_2104, + a.rather.long.in.fact.very.long.name.q_3105, + a.rather.long.in.fact.very.long.name.q_3106, + a.rather.long.in.fact.very.long.name.q_4104, + a.rather.long.in.fact.very.long.name.q_6101, + a.rather.long.in.fact.very.long.name.q_6103, + a.rather.long.in.fact.very.long.name.q_7104, + a.rather.long.in.fact.very.long.name.q_3109, + a.rather.long.in.fact.very.long.name.q_4103, + a.rather.long.in.fact.very.long.name.q_2111, + a.rather.long.in.fact.very.long.name.q_3107, + a.rather.long.in.fact.very.long.name.q_3101, + a.rather.long.in.fact.very.long.name.q_3104, + a.rather.long.in.fact.very.long.name.q_7107)) > > cat("--a.rather.long.in.fact.very.long.name.for.the...A--\n") --a.rather.long.in.fact.very.long.name.for.the...A-- > a.rather.long.in.fact.very.long.name.for.the.modelA <- + earth(a.rather.long.in.fact.very.long.name.for.the.response ~ + a.rather.long.in.fact.very.long.name.q_4 + + a.rather.long.in.fact.very.long.name.q_2102 + + a.rather.long.in.fact.very.long.name.q_2104 + + a.rather.long.in.fact.very.long.name.q_3105 + + a.rather.long.in.fact.very.long.name.q_3106 + + a.rather.long.in.fact.very.long.name.q_4104 + + a.rather.long.in.fact.very.long.name.q_6101 + + a.rather.long.in.fact.very.long.name.q_6103 + + a.rather.long.in.fact.very.long.name.q_7104 + + a.rather.long.in.fact.very.long.name.q_3109 + + a.rather.long.in.fact.very.long.name.q_4103 + + a.rather.long.in.fact.very.long.name.q_2111 + + a.rather.long.in.fact.very.long.name.q_3107 + + a.rather.long.in.fact.very.long.name.q_3101 + + a.rather.long.in.fact.very.long.name.q_3104 + + a.rather.long.in.fact.very.long.name.q_7107, + data = a.rather.long.in.fact.very.long.name.for.the.dataframe) > print(summary(a.rather.long.in.fact.very.long.name.for.the.modelA, digits = 2)) Call: earth(formula=a.rather.long.in.fact.very.long.name.for.the.respo...), data=a.rather.long.in.fact.very.long.name.for.the.da...) coefficients (Intercept) 1.79 h(0.782075-a.rather.long.in.fact.very.long.name.q_4) -0.97 h(a.rather.long.in.fact.very.long.name.q_4-0.782075) -5.36 h(a.rather.long.in.fact.very.long.name.q_2102- -0.664223) 1.19 h(a.rather.long.in.fact.very.long.name.q_2104- -0.954733) 0.85 h(0.83147-a.rather.long.in.fact.very.long.name.q_3105) -0.77 h(0.492009-a.rather.long.in.fact.very.long.name.q_3106) -0.93 h(a.rather.long.in.fact.very.long.name.q_4104- -0.671276) 1.02 h(0.483685-a.rather.long.in.fact.very.long.name.q_6101) -1.10 h(0.914724-a.rather.long.in.fact.very.long.name.q_6103) -1.12 h(0.545206-a.rather.long.in.fact.very.long.name.q_7104) -1.19 h(-0.157173-a.rather.long.in.fact.very.long.name.q_3109) -0.96 h(a.rather.long.in.fact.very.long.name.q_3109- -0.157173) 1.03 Selected 13 of 21 terms, and 10 of 16 predictors Termination condition: RSq changed by less than 0.001 at 21 terms Importance: a.rather.long.in.fact.very.long.name.q_6103, ... Number of terms at each degree of interaction: 1 12 (additive model) GCV 2.5 RSS 1509 GRSq 0.53 RSq 0.57 > plot(a.rather.long.in.fact.very.long.name.for.the.modelA) > plotmo(a.rather.long.in.fact.very.long.name.for.the.modelA) plotmo grid: a.rather.long.in.fact.very.long.name.q_4 0.05726625 a.rather.long.in.fact.very.long.name.q_2102 0.01725001 a.rather.long.in.fact.very.long.name.q_2104 0.004659335 a.rather.long.in.fact.very.long.name.q_3105 -0.01826179 a.rather.long.in.fact.very.long.name.q_3106 -0.00913319 a.rather.long.in.fact.very.long.name.q_4104 0.01401429 a.rather.long.in.fact.very.long.name.q_6101 -0.04790454 a.rather.long.in.fact.very.long.name.q_6103 0.03681165 a.rather.long.in.fact.very.long.name.q_7104 0.01827148 a.rather.long.in.fact.very.long.name.q_3109 -0.09899272 a.rather.long.in.fact.very.long.name.q_4103 -0.0623349 a.rather.long.in.fact.very.long.name.q_2111 0.01007481 a.rather.long.in.fact.very.long.name.q_3107 -0.02481171 a.rather.long.in.fact.very.long.name.q_3101 -0.07733527 a.rather.long.in.fact.very.long.name.q_3104 -0.003053319 a.rather.long.in.fact.very.long.name.q_7107 0.02821214 > > cat("--a.rather.long.in.fact.very.long.name.for.the...C--\n") --a.rather.long.in.fact.very.long.name.for.the...C-- > a.rather.long.in.fact.very.long.name.for.the.modelC <- + earth(x = a.rather.long.in.fact.very.long.name.for.the.dataframe[,-1], + y = a.rather.long.in.fact.very.long.name.for.the.response, + degree = 3) > print(summary(a.rather.long.in.fact.very.long.name.for.the.modelC, digits = 2)) Call: earth(x=a.rather.long.in.fact.very.long.name.for.the.dataf...), y=a.rather.long.in.fact.very.long.name.for.the.re..., degree=3) coefficients (Intercept) 1.72 h(0.782075-a.rather.long.in.fact.very.long.name.q_4) -1.02 h(a.rather.long.in.fact.very.long.name.q_4-0.782075) -10.33 h(a.rather.long.in.fact.very.long.name.q_2102- -0.664223) 1.27 h(a.rather.long.in.fact.very.long.name.q_2104- -0.954733) 0.82 h(0.83147-a.rather.long.in.fact.very.long.name.q_3105) -1.00 h(0.492009-a.rather.long.in.fact.very.long.name.q_3106) -0.90 h(a.rather.long.in.fact.very.long.name.q_4104- -0.671276) 1.01 h(0.483685-a.rather.long.in.fact.very.long.name.q_6101) -1.09 h(0.914724-a.rather.long.in.fact.very.long.name.q_6103) -1.18 h(0.545206-a.rather.long.in.fact.very.long.name.q_7104) -1.62 h(-0.157173-a.rather.long.in.fact.very.long.name.q_3109) -1.81 h(a.rather.long.in.fact.very.long.name.q_3109- -0.157173) 1.15 h(-0.664223-a.rather.long.in.fact.very.long.name.q_2102) * h(a.rather.long.in.fact.very.long.name.q_3106- -0.148502) 3.71 h(0.83147-a.rather.long.in.fact.very.long.name.q_3105) * h(a.rather.long.in.fact.very.long.name.q_7107- -0.748278) 0.31 h(0.914724-a.rather.long.in.fact.very.long.name.q_6103) * h(-0.713314-a.rather.long.in.fact.very.long.name.q_3107) 2.90 h(0.545206-a.rather.long.in.fact.very.long.name.q_7104) * h(a.rather.long.in.fact.very.long.name.q_2111- -0.544753) 0.61 h(-0.157173-a.rather.long.in.fact.very.long.name.q_3109) * h(0.700096-a.rather.long.in.fact.very.long.name.q_2111) 1.33 h(a.rather.long.in.fact.very.long.name.q_4-0.82106) * h(0.545206-a.rather.long.in.fact.very.long.name.q_7104) * h(a.rather.long.in.fact.very.long.name.q_2111- -0.544753) 15.97 Selected 19 of 33 terms, and 13 of 16 predictors Termination condition: Reached nk 33 Importance: a.rather.long.in.fact.very.long.name.q_6103, ... Number of terms at each degree of interaction: 1 12 5 1 GCV 2.4 RSS 1374 GRSq 0.54 RSq 0.6 > plot(a.rather.long.in.fact.very.long.name.for.the.modelC) > plotmo(a.rather.long.in.fact.very.long.name.for.the.modelC) plotmo grid: a.rather.long.in.fact.very.long.name.q_4 0.05726625 a.rather.long.in.fact.very.long.name.q_2102 0.01725001 a.rather.long.in.fact.very.long.name.q_2104 0.004659335 a.rather.long.in.fact.very.long.name.q_3105 -0.01826179 a.rather.long.in.fact.very.long.name.q_3106 -0.00913319 a.rather.long.in.fact.very.long.name.q_4104 0.01401429 a.rather.long.in.fact.very.long.name.q_6101 -0.04790454 a.rather.long.in.fact.very.long.name.q_6103 0.03681165 a.rather.long.in.fact.very.long.name.q_7104 0.01827148 a.rather.long.in.fact.very.long.name.q_3109 -0.09899272 a.rather.long.in.fact.very.long.name.q_4103 -0.0623349 a.rather.long.in.fact.very.long.name.q_2111 0.01007481 a.rather.long.in.fact.very.long.name.q_3107 -0.02481171 a.rather.long.in.fact.very.long.name.q_3101 -0.07733527 a.rather.long.in.fact.very.long.name.q_3104 -0.003053319 a.rather.long.in.fact.very.long.name.q_7107 0.02821214 > > a <- earth(survived ~ pclass+sex+age, data=etitanic, degree=2) > print(summary(a)) Call: earth(formula=survived~pclass+sex+age, data=etitanic, degree=2) coefficients (Intercept) 0.92939850 pclass3rd -0.45571429 pclass2nd * sexmale -0.27354805 pclass3rd * sexmale 0.18991361 sexmale * h(age-16) 0.05497748 sexmale * h(age-25) -0.01885057 sexmale * h(age-2) -0.04217428 Selected 7 of 14 terms, and 4 of 4 predictors Termination condition: Reached nk 21 Importance: sexmale, pclass3rd, pclass2nd, age Number of terms at each degree of interaction: 1 1 5 GCV 0.1442766 RSS 146.3318 GRSq 0.4039126 RSq 0.4209023 > plotmo(a, caption="plotmo with facs: pclass+sex+age") plotmo grid: pclass sex age 3rd male 28 > plotmo(a, caption="plotmo with facs: pclass+sex+age, all1=T, grid.col=\"gray\"", all1=T, grid.col="gray") plotmo grid: pclass sex age 3rd male 28 > plotmo(a, caption="plotmo with facs: pclass+sex+age, all2=T, col.grid=\"green\"", all2=T, col.grid="green") plotmo grid: pclass sex age 3rd male 28 > plotmo(a, caption="plotmo with facs: pclass+sex+age, all1=T, all2=T, grid=2", all1=T, all2=T, grid.col=2) plotmo grid: pclass sex age 3rd male 28 > plotmo(a, clip=FALSE, degree2=FALSE, caption="plotmo (no degree2) with facs: pclass+sex+age") plotmo grid: pclass sex age 3rd male 28 > plotmo(a, clip=FALSE, grid.levels=list(pclass="2n", sex="ma"), + caption="plotmo with grid.levels: pclass+sex+age") plotmo grid: pclass sex age 2nd male 28 > # in above tests, all degree2 terms use facs > # now build a model with some degree2 term that use facs, some that don't > a <- earth(survived ~ pclass+age+sibsp, data=etitanic, degree=2) > print(summary(a)) Call: earth(formula=survived~pclass+age+sibsp, data=etitanic, degree=2) coefficients (Intercept) 1.20590993 pclass2nd -0.27484540 pclass3rd -0.45765086 h(age-5) -0.03561187 h(age-18) 0.03022469 h(18-age) * h(sibsp-2) -0.04797511 h(18-age) * h(sibsp-3) 0.04721023 Selected 7 of 17 terms, and 4 of 4 predictors Termination condition: Reached nk 21 Importance: pclass3rd, age, pclass2nd, sibsp Number of terms at each degree of interaction: 1 4 2 GCV 0.2040487 RSS 206.9554 GRSq 0.1569604 RSq 0.1809888 > plotmo(a, caption="plotmo with mixed fac and non-fac degree2 terms", persp.border=NA) plotmo grid: pclass age sibsp 3rd 28 0 > plotmo(a, caption="plotmo with mixed fac and non-fac degree2 terms and grid.levels", + grid.levels=list(pclass="2n", age=20), # test partial matching of grid levels, and numeric preds + persp.ticktype="d", persp.nticks=2) plotmo grid: pclass age sibsp 2nd 20 0 > > # check detection of illegal grid.levels argument > expect.err(try(plotmo(a, grid.levels=list(pcla="1", pclass="2"))), 'illegal grid.levels argument ("pcla" and "pclass" both match "pclass")') Error : illegal grid.levels argument ("pcla" and "pclass" both match "pclass") Got expected error from try(plotmo(a, grid.levels = list(pcla = "1", pclass = "2"))) > expect.err(try(plotmo(a, grid.levels=list(pclass="1", pcla="2"))), 'illegal grid.levels argument ("pclass" and "pcla" both match "pclass")') Error : illegal grid.levels argument ("pclass" and "pcla" both match "pclass") Got expected error from try(plotmo(a, grid.levels = list(pclass = "1", pcla = "2"))) > expect.err(try(plotmo(a, grid.levels=list(pcla="nonesuch"))), 'illegal level "nonesuch" for "pclass" in grid.levels (allowed levels are "1st" "2nd" "3rd")') Error : illegal level "nonesuch" for "pclass" in grid.levels (allowed levels are "1st" "2nd" "3rd") Got expected error from try(plotmo(a, grid.levels = list(pcla = "nonesuch"))) > expect.err(try(plotmo(a, grid.levels=list(pcla="1sx"))), 'illegal level "1sx" for "pclass" in grid.levels (allowed levels are "1st" "2nd" "3rd")') Error : illegal level "1sx" for "pclass" in grid.levels (allowed levels are "1st" "2nd" "3rd") Got expected error from try(plotmo(a, grid.levels = list(pcla = "1sx"))) > expect.err(try(plotmo(a, grid.levels=list(pcla=1))), 'illegal level for "pclass" in grid.levels (specify factor levels with a string)') Error : illegal level for "pclass" in grid.levels (specify factor levels with a string) Got expected error from try(plotmo(a, grid.levels = list(pcla = 1))) > expect.err(try(plotmo(a, grid.levels=list(pcla=c("ab", "cd")))), "length(pclass) in grid.levels is not 1") Error : length(pclass) in grid.levels is not 1 Got expected error from try(plotmo(a, grid.levels = list(pcla = c("ab", "cd")))) > expect.err(try(plotmo(a, grid.levels=list(pcla=NA))), 'pclass in grid.levels is NA') Error : pclass in grid.levels is NA Got expected error from try(plotmo(a, grid.levels = list(pcla = NA))) > expect.err(try(plotmo(a, grid.levels=list(pcla=Inf))), 'pclass in grid.levels is infinite') Error : pclass in grid.levels is infinite Got expected error from try(plotmo(a, grid.levels = list(pcla = Inf))) > expect.err(try(plotmo(a, grid.levels=list(pcla=9))), 'illegal level for "pclass" in grid.levels (specify factor levels with a string)') Error : illegal level for "pclass" in grid.levels (specify factor levels with a string) Got expected error from try(plotmo(a, grid.levels = list(pcla = 9))) > options(warn=2) > expect.err(try(plotmo(a, grid.levels=list(age="ab"))), 'grid.levels returned class \"character\" for age, so will use the default grid.func for age') Error : (converted from warning) grid.levels returned class "character" for age, so will use the default grid.func for age Got expected error from try(plotmo(a, grid.levels = list(age = "ab"))) > options(warn=1) > expect.err(try(plotmo(a, grid.levels=list(age=NA))), 'age in grid.levels is NA') Error : age in grid.levels is NA Got expected error from try(plotmo(a, grid.levels = list(age = NA))) > expect.err(try(plotmo(a, grid.levels=list(age=Inf))), 'age in grid.levels is infinite') Error : age in grid.levels is infinite Got expected error from try(plotmo(a, grid.levels = list(age = Inf))) > expect.err(try(plotmo(a, grid.lev=list(age=list(1,2)))), 'length(age) in grid.levels is not 1') Error : length(age) in grid.levels is not 1 Got expected error from try(plotmo(a, grid.lev = list(age = list(1, 2)))) > > # more-or-less repeat above, but with glm models > a <- earth(survived ~ pclass+age+sibsp, data=etitanic, degree=2, glm=list(family=binomial)) > print(summary(a)) Call: earth(formula=survived~pclass+age+sibsp, data=etitanic, glm=list(family=binomial), degree=2) GLM coefficients survived (Intercept) 3.4306891 pclass2nd -1.2012524 pclass3rd -2.0973424 h(age-5) -0.1769427 h(age-18) 0.1502007 h(18-age) * h(sibsp-2) -0.2887477 h(18-age) * h(sibsp-3) 0.2820357 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 1414.62 1045 1212.21 1039 0.143 1226 5 1 Earth selected 7 of 17 terms, and 4 of 4 predictors Termination condition: Reached nk 21 Importance: pclass3rd, age, pclass2nd, sibsp Number of terms at each degree of interaction: 1 4 2 Earth GCV 0.2040487 RSS 206.9554 GRSq 0.1569604 RSq 0.1809888 > plotmo(a, ylim=c(0, 1), caption="plotmo glm with mixed fac and non-fac degree2 terms") plotmo grid: pclass age sibsp 3rd 28 0 > plotmo(a, ylim=c(0, 1), caption="plotmo glm with mixed fac and non-fac degree2 terms and grid.levels", + grid.levels=list(pcl="2nd")) # test partial matching of variable name in grid levels plotmo grid: pclass age sibsp 2nd 28 0 > plotmo(a, type="earth", ylim=c(0, 1), caption="type=\"earth\" plotmo glm with mixed fac and non-fac degree2 terms") plotmo grid: pclass age sibsp 3rd 28 0 > plotmo(a, type="link", ylim=c(0, 1), clip=FALSE, caption="type=\"link\" plotmo glm with mixed fac and non-fac degree2 terms") plotmo grid: pclass age sibsp 3rd 28 0 > plotmo(a, type="class", ylim=c(0, 1), caption="type=\"class\" plotmo glm with mixed fac and non-fac degree2 terms") plotmo grid: pclass age sibsp 3rd 28 0 > plotmo(a, ylim=c(0, 1), caption="default type (\"response\")\nplotmo glm with mixed fac and non-fac degree2 terms") plotmo grid: pclass age sibsp 3rd 28 0 > # now with different type2s > set.seed(2016) > plotmo(a, do.par=FALSE, type2="persp", persp.theta=-20, degree1=FALSE, grid.levels=list(pclass="2nd")) > mtext("different type2s", outer=TRUE, font=2, line=1.5, cex=1) > plotmo(a, do.par=FALSE, type2="contour", degree1=FALSE, grid.levels=list(pclass="2nd")) > plotmo(a, do.par=FALSE, type2="image", degree1=FALSE, grid.levels=list(pclass="2nd"), + col.response=as.numeric(etitanic$survived)+2, pt.pch=20) > plotmo(a, do.par=FALSE, type="earth", type2="image", degree1=FALSE, + grid.levels=list(pclass="2")) > > # grid.levels with partdep > > set.seed(2018) > x1 <- (1:11) + runif(11) > x2 <- (1:11) + runif(11) > x3 <- as.integer((1:11) + runif(11)) > x4 <- runif(11) > .5 # logical > y <- x1 - x2 + x3 + x4 > data <- data.frame(y=y, x1=x1, x2=x2, x3=x3, x4=x4) > lm.x1.x2.x3 <- lm(y ~ x1 + x2 + x3 + x4 + x1*x2 + x1*x3, data=data) > cat("summary(lm.x1.x2.x3):\n") summary(lm.x1.x2.x3): > print(summary(lm.x1.x2.x3)) Warning in summary.lm(lm.x1.x2.x3) : essentially perfect fit: summary may be unreliable Call: lm(formula = y ~ x1 + x2 + x3 + x4 + x1 * x2 + x1 * x3, data = data) Residuals: 1 2 3 4 5 6 7 4.445e-17 -2.215e-16 9.227e-18 2.871e-16 2.251e-16 -9.376e-17 -5.566e-16 8 9 10 11 1.746e-17 2.252e-16 3.073e-16 -2.440e-16 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 2.142e-15 1.549e-15 1.383e+00 0.239 x1 1.000e+00 6.608e-16 1.513e+15 <2e-16 *** x2 -1.000e+00 1.816e-15 -5.507e+14 <2e-16 *** x3 1.000e+00 1.818e-15 5.502e+14 <2e-16 *** x4TRUE 1.000e+00 3.109e-16 3.216e+15 <2e-16 *** x1:x2 3.625e-16 2.328e-16 1.557e+00 0.195 x1:x3 -3.314e-16 2.274e-16 -1.458e+00 0.219 --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 4.207e-16 on 4 degrees of freedom Multiple R-squared: 1, Adjusted R-squared: 1 F-statistic: 1.326e+32 on 6 and 4 DF, p-value: < 2.2e-16 > par(mfrow = c(5, 6), mar = c(2, 3, 2, 1), mgp = c(1.5, 0.5, 0), cex = 0.6, oma=c(0,0,8,0)) > plotmo(lm.x1.x2.x3, do.par=0, ylim=c(0,16), pt.col=2, + caption="row1 default\nrow2 grid.levels=list(x3=15)\nrow3 partdep\nrow4 partdetp grid.levels=list(x3=15)") plotmo grid: x1 x2 x3 x4 6.301049 6.270736 6 TRUE > plotmo(lm.x1.x2.x3, do.par=0, ylim=c(0,16), pt.col=2, grid.levels=list(x3=15)) plotmo grid: x1 x2 x3 x4 6.301049 6.270736 15 TRUE > plotmo(lm.x1.x2.x3, do.par=0, ylim=c(0,16), pt.col=2, pmethod="partdep") calculating partdep for x1 calculating partdep for x2 calculating partdep for x3 calculating partdep for x4 calculating partdep for x1:x2 01234567890 calculating partdep for x1:x3 01234567890 > plotmo(lm.x1.x2.x3, do.par=0, ylim=c(0,16), pt.col=2, pmethod="partdep", grid.levels=list(x3=15)) calculating partdep for x1 calculating partdep for x2 calculating partdep for x3 calculating partdep for x4 calculating partdep for x1:x2 01234567890 calculating partdep for x1:x3 01234567890 > > # check auto type convert in grid.levels > plotmo(lm.x1.x2.x3, degree1="x1", degree2=0, main="x1 (x2=5L))", ylim=c(0,16), do.par=0, pmethod="partdep", grid.levels=list(x2=15L)) # integer to numeric calculating partdep for x1 > plotmo(lm.x1.x2.x3, degree1="x1", degree2=0, main="x1 (x3=5))", ylim=c(0,16), do.par=0, pmethod="partdep", grid.levels=list(x3=15)) # numeric to integer calculating partdep for x1 > plotmo(lm.x1.x2.x3, degree1="x1", degree2=0, main="x1 (x4=1))", ylim=c(0,16), do.par=0, pmethod="partdep", grid.levels=list(x4=1)) # numeric to logical calculating partdep for x1 > expect.err(try(plotmo(lm.x1.x2.x3, degree1="x1", degree2=0, main="x1 (x4=1))", ylim=c(0,16), do.par=0, pmethod="partdep", grid.levels=list(x4="x"))), "expected a logical value in grid.levels for x4") # char to logical Error : expected a logical value in grid.levels for x4 Got expected error from try(plotmo(lm.x1.x2.x3, degree1 = "x1", degree2 = 0, main = "x1 (x4=1))", ylim = c(0, 16), do.par = 0, pmethod = "partdep", grid.levels = list(x4 = "x"))) > expect.err(try(plotmo(lm.x1.x2.x3, degree1="x2", do.par=0, pmethod="partdep", grid.levels=list(x1="1"))), "the class \"character\" of \"x1\" in grid.levels does not match its class \"numeric\" in the input data") Warning: grid.levels returned class "character" for x1, so will use the default grid.func for x1 Error : the class "character" of "x1" in grid.levels does not match its class "numeric" in the input data Got expected error from try(plotmo(lm.x1.x2.x3, degree1 = "x2", do.par = 0, pmethod = "partdep", grid.levels = list(x1 = "1"))) > par(org.par) > > # test vector main > > a20 <- earth(O3 ~ humidity + temp + doy, data=ozone1, degree=2, glm=list(family=Gamma)) > > dopar(2, 2) > plotmo(a20, nrug=-1) plotmo grid: humidity temp doy 64 62 205.5 > > set.seed(2016) > plotmo(a20, nrug=10, caption="Test plotmo with a vector main (and npoints=200)", + main=c("Humidity", "Temperature", "Day of year", "Humidity: Temperature", "Temperature: Day of Year"), + col.response="darkgray", pt.pch=".", cex.response=3, npoints=200) # cex.response tests back compat plotmo grid: humidity temp doy 64 62 205.5 > > cat("Expect warning below (missing double titles)\n") Expect warning below (missing double titles) > plotmo(a20, nrug=-1, caption="Test plotmo with a vector main (and plain smooth)", + main=c("Humidity", "Temperature", "Day of year", "Humidity: Temperature", "Temp: Doy"), + smooth.col="indianred") plotmo grid: humidity temp doy 64 62 205.5 > > cat("Expect warning below (missing single titles)\n") Expect warning below (missing single titles) > plotmo(a20, nrug=-1, caption="Test plotmo with a vector main (and smooth args)", + main=c("Humidity", "Temperature"), + smooth.col="indianred", smooth.lwd=2, smooth.lty=2, smooth.f=.1, + col.response="gray", npoints=500) plotmo grid: humidity temp doy 64 62 205.5 > > plotmo(a20, nrug=-1, caption="Test plotmo with pt.pch=paste(1:nrow(ozone1))", + type2="im", + col.response=2, pt.cex=.8, pt.pch=paste(1:nrow(ozone1)), npoints=100) plotmo grid: humidity temp doy 64 62 205.5 > > aflip <- earth(O3~vh + wind + humidity + temp, data=ozone1, degree=2) > > # test all1 and all2, with and without degree1 and degree2 > plotmo(aflip, all2=T, caption="all2=T", npoints=TRUE) plotmo grid: vh wind humidity temp 5760 5 64 62 > plotmo(aflip, all2=T, degree2=c(4, 2), caption="all2=T, degree2=c(4, 2)") plotmo grid: vh wind humidity temp 5760 5 64 62 > plotmo(aflip, all1=T, caption="all1=T") plotmo grid: vh wind humidity temp 5760 5 64 62 > plotmo(aflip, all1=T, degree1=c(3,1), degree2=NA, caption="all1=T, degree1=c(3,1), degree2=NA") plotmo grid: vh wind humidity temp 5760 5 64 62 > > options(warn=2) > expect.err(try(plotmo(aflip, no.such.arg=9)), "(converted from warning) predict.earth ignored argument 'no.such.arg'") stats::predict(earth.object, NULL, type="response", no.such.arg=9) Error : (converted from warning) predict.earth ignored argument 'no.such.arg' Got expected error from try(plotmo(aflip, no.such.arg = 9)) > expect.err(try(plotmo(aflip, ycolumn=1)), "(converted from warning) predict.earth ignored argument 'ycolumn'") stats::predict(earth.object, NULL, type="response", ycolumn=1) Error : (converted from warning) predict.earth ignored argument 'ycolumn' Got expected error from try(plotmo(aflip, ycolumn = 1)) > expect.err(try(plotmo(aflip, title="abc")), "(converted from warning) predict.earth ignored argument 'title'") stats::predict(earth.object, NULL, type="response", title="abc") Error : (converted from warning) predict.earth ignored argument 'title' Got expected error from try(plotmo(aflip, title = "abc")) > expect.err(try(plotmo(aflip, persp.ticktype="d", persp.ntick=3, tic=3, tick=9)), "(converted from warning) predict.earth ignored argument 'tic'") stats::predict(earth.object, NULL, type="response", tic=3, tick=9) Error : (converted from warning) predict.earth ignored argument 'tic' Got expected error from try(plotmo(aflip, persp.ticktype = "d", persp.ntick = 3, tic = 3, tick = 9)) > expect.err(try(plotmo(aflip, persp.ticktype="d", ntick=3, tic=3)), "(converted from warning) predict.earth ignored argument 'ntick'") stats::predict(earth.object, NULL, type="response", ntick=3, tic=3) Error : (converted from warning) predict.earth ignored argument 'ntick' Got expected error from try(plotmo(aflip, persp.ticktype = "d", ntick = 3, tic = 3)) > options(warn=1) > # expect.err(try(plotmo(aflip, adj1=8, adj2=9))) # Error : plotmo: illegal argument "adj1" > # expect.err(try(plotmo(aflip, yc=8, x2=9))) # "ycolumn" is no longer legal, use "nresponse" instead > # expect.err(try(plotmo(aflip, persp.ticktype="d", ntick=3, ti=3))) # Error : "title" is illegal, use "caption" instead ("ti" taken to mean "title") > # expect.err(try(plotmo(aflip, persp.ticktype="d", ntick=3, title=3))) # Error : "title" is illegal, use "caption" instead > # expect.err(try(plotmo(aflip, persp.ticktype="d", ntick=3, tit=3, titl=7))) # Error : "title" is illegal, use "caption" instead ("tit" taken to mean "title") > # expect.err(try(plotmo(aflip, zlab="abc"))) # "zlab" is illegal, use "ylab" instead > # expect.err(try(plotmo(aflip, z="abc"))) # "zlab" is illegal, use "ylab" instead ("z" taken to mean "zlab") > expect.err(try(plotmo(aflip, degree1=c(4,1))), "'degree1' is out of range, allowed values are 1 to 2") Error : 'degree1' is out of range, allowed values are 1 to 2 Got expected error from try(plotmo(aflip, degree1 = c(4, 1))) > # expect.err(try(plotmo(aflip, none.such=TRUE))) # illegal argument "all1" > # expect.err(try(plotmo(aflip, ntick=3, type2="im"))) # the ntick argument is illegal for type2="image" > # expect.err(try(plotmo(aflip, breaks=3, type2="persp"))) # the breaks argument is illegal for type2="persp" > # expect.err(try(plotmo(aflip, breaks=99, type2="cont"))) # the breaks argument is illegal for type2="contour" > > # Test error handling when accessing the original data > > lm.bad <- lm.fit(as.matrix(ozone1[,-1]), as.matrix(ozone1[,1])) > expect.err(try(plotmo(lm.bad)), "'lm.bad' is a plain list, not an S3 model") Error : 'lm.bad' is a plain list, not an S3 model Got expected error from try(plotmo(lm.bad)) > expect.err(try(plotmo(99)), "'99' is not an S3 model") Error : '99' is not an S3 model Got expected error from try(plotmo(99)) > > x <- matrix(c(1,3,2,4,5,6,7,8,9,10, + 2,3,4,5,6,7,8,9,8,9), ncol=2) > > colnames(x) <- c("c1", "c2") > x1 <- x[,1] > x2 <- x[,2] > y <- 3:12 > df <- data.frame(y=y, x1=x1, x2=x2) > foo1 <- function() + { + a.foo1 <- lm(y~x1+x2, model=FALSE) + x1 <- NULL + expect.err(try(plotmo(a.foo1)), "cannot get the original model predictors") + } > foo1() Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: invalid type (NULL) for variable 'x1' (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(plotmo(a.foo1)) > foo2 <- function() + { + a.foo2 <- lm(y~x1+x2, data=df, model=FALSE) + df <- 99 # note that df <- NULL here will not cause an error msg + y <- 99 # also needed else model.frame in plotmo will find the global y + expect.err(try(plotmo(a.foo2)), "cannot get the original model predictors") + } > foo2() Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: variable lengths differ (found for 'x1') (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(plotmo(a.foo2)) > foo3 <- function() + { + a.foo3 <- lm(y~x) # lm() builds an lm model for which predict doesn't work + expect.err(try(plotmo(a.foo3)), "predict returned the wrong length (got 10 but expected 50)") + } > foo3() Warning: the variable on the right side of the formula is a matrix or data.frame plotmo often cannot process such variables Warning: 'newdata' had 50 rows but variables found have 10 rows Error : predict returned the wrong length (got 10 but expected 50) Got expected error from try(plotmo(a.foo3)) > foo3a <- function() + { + a.foo3a <- lm(y~x) # lm() builds an lm model for which predict doesn't work + # this tests "ngrid1 <- ngrid1 + 1" in plotmo.R + expect.err(try(plotmo(a.foo3a, ngrid1=nrow(x))), "predict returned the wrong length (got 10 but expected 11)") + } > foo3a() Warning: the variable on the right side of the formula is a matrix or data.frame plotmo often cannot process such variables Warning: 'newdata' had 11 rows but variables found have 10 rows Error : predict returned the wrong length (got 10 but expected 11) Got expected error from try(plotmo(a.foo3a, ngrid1 = nrow(x))) > foo4 <- function() + { + a.foo4 <- lm(y~x[,1]+x[,2]) # builds an lm model for which predict doesn't work + # causes 'newdata' had 8 rows but variables found have 10 rows + expect.err(try(plotmo(a.foo4)), "predict returned the wrong length (got 10 but expected 50)") + } > foo4() Warning: Cannot determine which variables to plot in degree2 plots (use all2=TRUE?) Confused by variable name "x[, 1]" Warning: 'newdata' had 50 rows but variables found have 10 rows Error : predict returned the wrong length (got 10 but expected 50) Got expected error from try(plotmo(a.foo4)) > foo5 <- function() + { + a.foo5 <- lm(y~x1+x2, model=FALSE) + x1 <- c(1,2,3) + # causes Error in model.frame.default: variable lengths differ (found for 'x1') + expect.err(try(plotmo(a.foo5)), "cannot get the original model predictors") + } > foo5() Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: variable lengths differ (found for 'x1') (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(plotmo(a.foo5)) > foo6 <- function() + { + a.foo6 <- lm(y~x1+x2, model=FALSE) + y[1] <- NA + # Error in na.fail.default: missing values in object + expect.err(try(plotmo(a.foo6, col.response=3)), "cannot get the original model predictors") + } > foo6() Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: missing values in object (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(plotmo(a.foo6, col.response = 3)) > foo7 <- function() + { + a.foo7 <- lm(y~x1+x2, model=FALSE) + y[1] <- Inf + options <- options("warn") + on.exit(options(warn=options$warn)) + options(warn=2) + expect.err(try(plotmo(a.foo7, col.response=3)), "non-finite values returned by plotmo_y") + } > foo7() Error : (converted from warning) non-finite values returned by plotmo_y Got expected error from try(plotmo(a.foo7, col.response = 3)) > options(warn=1) > foo8 <- function() + { + i <- 1 + a.foo8 <- lm(y~x[,i]+x[,2]) + options <- options("warn") + on.exit(options(warn=options$warn)) + options(warn=2) + expect.err(try(plotmo(a.foo8)), "Cannot determine which variables to plot in degree2 plots (use all2=TRUE?)") + options(warn=options$warn) + expect.err(try(plotmo(a.foo8)), "predict returned the wrong length (got 10 but expected 50)") + } > foo8() Error : (converted from warning) Cannot determine which variables to plot in degree2 plots (use all2=TRUE?) Confused by variable name "x[, i]" Got expected error from try(plotmo(a.foo8)) Warning: Cannot determine which variables to plot in degree2 plots (use all2=TRUE?) Confused by variable name "x[, i]" Warning: 'newdata' had 50 rows but variables found have 10 rows Error : predict returned the wrong length (got 10 but expected 50) Got expected error from try(plotmo(a.foo8)) > options(warn=1) > foo9 <- function() + { + my.list <- list(j=2) + a.foo9 <- lm(y~x[,1]+x[,my.list$j]) + expect.err(try(plotmo(a.foo9)), "cannot get the original model predictors") + } > foo9() Warning: "$" in the formula is not supported by plotmo, will try to get the data elsewhere formula: x[, 1] + x[, my.list$j] Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: formula(object): "$" in formula is not allowed (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(plotmo(a.foo9)) > foo9a <- function() + { + df <- data.frame(y=y, x1=x[,1], x2=x[,2]) + a.foo9a <- lm(y~x1+x2, data=df) + par(mfrow = c(2, 2), oma=c(0,0,4,0)) + set.seed(2018) + plotmo(a.foo9a, col.resp=2, do.par=FALSE, + caption="top two plots should be identical to bottom two plots") + x2 <- rep(99, length(x2)) + a.foo9b <- lm(y~x1+x2, data=df) + x2 <- rep(199, length(x2)) + plotmo(a.foo9b, col.resp=2, do.par=FALSE) + } > foo9a() plotmo grid: x1 x2 5.5 6.5 plotmo grid: x1 x2 5.5 6.5 > par(org.par) > > foo20.func <- function() + { + par(mfrow = c(2, 2), oma=c(0,0,4,0)) + foo20 <- lm(y~x1+x2) + set.seed(2018) + plotmo(foo20, degree1=1:2, col.resp=2, do.par=FALSE, + caption="top two plots should be identical to bottom two plots\nbecause we use saved lm$model") + x1 <- 99 + plotmo(foo20, degree1=1:2, col.resp=2, do.par=FALSE) + } > foo20.func() plotmo grid: x1 x2 5.5 6.5 plotmo grid: x1 x2 5.5 6.5 > par(org.par) > > set.seed(1235) > tit <- etitanic > tit <- tit[c(30:80,330:380,630:680), ] > a <- earth(survived~., data=tit, glm=list(family=binomial), degree=2) > plotmo(a, grid.levels=list(sex="ma"), + caption="smooth: survived, sex=\"m\" jitter=1", + smooth.col="indianred", smooth.lwd=2, + col.response=as.numeric(tit$survived)+2, pt.pch=".", type2="im", + pt.cex=3, jitter=1) # big jitter plotmo grid: pclass sex age sibsp parch 1st male 29 0 0 > set.seed(1238) > a <- earth(pclass~., data=tit) > plotmo(a, type="class", nresponse=1, + grid.levels=list(sex="ma"), + caption="smooth: pclass, sex=\"m\"", SHOWCALL=TRUE, + smooth.col="indianred", smooth.lwd=2, + col.response=as.numeric(tit$pclass)+1, type2="im", + pt.pch=".", pt.cex=3) plotmo grid: survived sex age sibsp parch 0 male 29 0 0 > plotmo(a, type="class", nresponse=1, + grid.levels=list(sex="ma"), + caption="smooth: pclass, sex=\"m\" jitter=.3", SHOWCALL=TRUE, + smooth.col="indianred", smooth.lwd=2, + col.response=as.numeric(tit$pclass)+1, type2="im", + pt.pch="x", jit=.3) # small jitter plotmo grid: survived sex age sibsp parch 0 male 29 0 0 > plotmo(a, nresponse=1, + type="class", grid.levels=list(sex="ma"), + caption="smooth: pclass, sex=\"m\"", SHOWCALL=TRUE, + smooth.col="indianred", smooth.lwd=2, + col.response=as.numeric(tit$pclass)+1, type2="im", + pt.pch=paste(1:nrow(tit))) plotmo grid: survived sex age sibsp parch 0 male 29 0 0 > > # test the extend argument > > plotmo(a, nresponse=1, pt.col=2, degree2=0, SHOWCALL=TRUE, + caption="test extend: extend=0 (reference plot)") plotmo grid: survived sex age sibsp parch 0 male 29 0 0 > plotmo(a, nresponse=1, extend=.5, pt.col=2, SHOWCALL=TRUE, + caption="test extend: extend=.5") plotmo grid: survived sex age sibsp parch 0 male 29 0 0 > plotmo(a, nresponse=1, degree1=0, extend=.2, pt.col=2, SHOWCALL=TRUE) # nothing to plot Warning: plotmo: nothing to plot > > a <- earth(survived~pclass+age, data=etitanic, degree=2) > # expect warning: extend=.5 not degree2 plots > plotmo(a, extend=.5, pt.col=2, SHOWCALL=TRUE, + caption="test extend: extend=.5") Warning: extend=0.5: will not plot degree2 plots (extend is not yet implemented for degree2 plots) plotmo grid: pclass age 3rd 28 > > # intercept only models > > dopar(2, 2, caption = "intercept-only models") intercept-only models > set.seed(1) > x <- 1:10 > y <- runif(length(x)) > earth.intercept.only <- earth(x, y) > plotmo(earth.intercept.only, do.par=FALSE, main="earth intercept-only model") > plotmo(earth.intercept.only, do.par=FALSE, col.response=1, pt.pch=20) > # TODO following draws a plot but it shouldn't (very minor bug because int-only model with a bad degree1 spec) > plotmo(earth.intercept.only, do.par=FALSE, degree1=3) # expect warning: 'degree1' specified but no degree1 plots Warning: 'degree1' specified but no degree1 plots (maybe use all1=TRUE?) > plotmo(earth.intercept.only, do.par=FALSE, degree1=0) # expect warning: plotmo: nothing to plot Warning: plotmo: nothing to plot > library(rpart) > rpart.intercept.only <- rpart(y~x) > plotmo(rpart.intercept.only, do.par=FALSE, main="rpart.plot intercept-only model") > plotmo(rpart.intercept.only, do.par=FALSE, degree1=0) Warning: plotmo: nothing to plot > par(org.par) > > # nrug argument > > par(mfrow=c(3,3), mar=c(3,3,3,1), mgp=c(1.5, 0.5, 0)) > mod.nrug <- earth(survived~age, data=etitanic) > set.seed(2016) > plotmo(mod.nrug, do.par=0, nrug=-1, main="nrug=-1") > plotmo(mod.nrug, do.par=0, nrug=TRUE, main="nrug=TRUE") > plotmo(mod.nrug, do.par=0, nrug=10, rug.col=2, main="nrug=10, rug.col=2") > plotmo(mod.nrug, do.par=0, nrug=5, rug.col=2, rug.lwd=2, main="nrug=5, rug.col=2, rug.lwd=2") > plotmo(mod.nrug, do.par=0, nrug="density", main="nrug=\"density\"") > plotmo(mod.nrug, do.par=0, nrug="density", density.col=2, density.lwd=2, main="nrug=\"density\"\ndensity.col=2, density.lwd=2") > plotmo(mod.nrug, do.par=0, nrug="density", density.adj=.2, density.col=1, main="nrug=\"density\"\ndensity.adj=.2, density.col=1") > par(org.par) > > # a <- earth(ozone1[,3]~ozone1[,1]+ozone1[,2]+ozone1[,4]+ozone1[,5]+ozone1[,6], data=ozone1) > # # TODO fails: actual.nrows=330 expected.nrows=50 fitted.nrows=330 > # plotmo(a) > > # # TODO following fails in plotmo with > # # Error : get.earth.x from model.matrix.earth from predict.earth: x has 2 columns, expected 4 to match: 1 2 3 Girth > # a <- earth(Volume~poly(Height, degree=3)+Girth, data=trees, subset=4:23, linpreds=TRUE) > # plotmo(a, trace=-1, do.par=FALSE, caption="all three rows should be the same") > > source("test.epilog.R") plotmo/inst/slowtests/test.degree.Rout.save0000644000176200001440000001776314563614021020651 0ustar liggesusers> # test.pre.R: test the degree1 and degree2 and related args > > source("test.prolog.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix > library(plotmo) > > # test character degree1 and degree2 (added in plotmo version 1.3-0) > > data(ozone1) > a80 <- earth(O3~., data=ozone1, degree=2) > plotmo(a80, degree1="i", degree2="t", + caption='degree1="i", degree2="t"') plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > plotmo(a80, degree1="^temp$", degree2="^dpg$", + caption='degree1="^temp$", degree2="^dpg$"') plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > # Expect Warning: "nonesuch1" in degree1 does not regex-match any variables, ditto for degree2 > plotmo(a80, degree1=c("temp", "nonesuch1"), degree2="vis", + caption='degree1=c("temp", "nonesuch1"), degree2="vis")') Warning: "nonesuch1" in degree1 does not regex-match any names Available names are "vh" "wind" "humidity" "temp" "ibh" "dpg" "ibt" "vis" "doy" plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > # Expect above warnings and also Warning: nothing to plot > plotmo(a80, degree1="nonesuch1", degree2="nonesuch2") Warning: "nonesuch1" in degree1 does not regex-match any names Available names are "vh" "wind" "humidity" "temp" "ibh" "dpg" "ibt" "vis" "doy" Warning: "nonesuch2" in degree2 does not regex-match any names Available names are "vh" "wind" "humidity" "temp" "ibh" "dpg" "ibt" "vis" "doy" Warning: plotmo: nothing to plot > > # tests for plotmo version 3.3.7 (degree1 and degree2 handling changed) > > data(etitanic) > a81 <- earth(survived~., data=etitanic, degree=2) > options(warn=1) # print warnings as they occur > plotmo(a81) plotmo grid: pclass sex age sibsp parch 3rd male 28 0 0 > > # degree1 tests > par(mfrow=c(3,3), mar=c(1,2.5,2,1), oma=c(0,0,4,0)) > plotmo(a81, do.par=FALSE, degree1="pclass", degree2=0, main='degree1="pclass"', + caption="test degree1 with strings") plotmo grid: pclass sex age sibsp parch 3rd male 28 0 0 > options(warn=2) # treat warnings as errors > expect.err(try(plotmo(a81, do.par=FALSE, degree1="survived", degree2=0)), '"survived" in degree1 does not regex-match any names') Error : (converted from warning) "survived" in degree1 does not regex-match any names Available names are "pclass" "sex" "age" "sibsp" "parch" Got expected error from try(plotmo(a81, do.par = FALSE, degree1 = "survived", degree2 = 0)) > options(warn=1) # print warnings as they occur > plotmo(a81, do.par=FALSE, degree1="sibsp", degree2=0, main='degree1="sibsp"') plotmo grid: pclass sex age sibsp parch 3rd male 28 0 0 > # parch does not appear in the standard degree1 plotmo plots, but we can still specify it explictly > plotmo(a81, do.par=FALSE, degree1="parch", degree2=0, trace=0, main='degree1="parch"') plotmo grid: pclass sex age sibsp parch 3rd male 28 0 0 > plotmo(a81, do.par=FALSE, degree1=c("sibsp", "pclass"), degree2=0, main='degree1=c("sibsp", "pclass")') plotmo grid: pclass sex age sibsp parch 3rd male 28 0 0 > par(org.par) > > # degree2 tests > par(mfrow=c(3,3), mar=c(1,2.5,2,1), oma=c(0,0,4,0)) > plotmo(a81, do.par=FALSE, degree1=0, degree2="pclass", main='degree2="pclass"', + caption="test degree2 with two strings") > plotmo(a81, do.par=FALSE, degree1=0, degree2=c("age", "se"), persp.theta=-35, + main='degree2=c("age", "se")\npersp.theta=-35') > plotmo(a81, do.par=FALSE, degree1=0, degree2="ag", main='degree2="ag"') > plotmo(a81, do.par=FALSE, degree1=0, degree2=c("sex", "sibsp"), main='degree2=c("sex", "sibsp"') > plotmo(a81, do.par=FALSE, degree1=0, degree2=c("sibsp", "sex"), main='degree2=c("sibsp", "sex")') > options(warn=2) # treat warnings as errors > expect.err(try(plotmo(a81, do.par=FALSE, degree1=0, degree2=c("pclass", "nonesuch"))), "\"nonesuch\" in degree2 does not regex-match any names") Error : (converted from warning) "nonesuch" in degree2 does not regex-match any names Available names are "pclass" "sex" "age" "sibsp" "parch" Got expected error from try(plotmo(a81, do.par = FALSE, degree1 = 0, degree2 = c("pclass", "nonesuch"))) > expect.err(try(plotmo(a81, do.par=FALSE, degree1=0, degree2=c("nonesuch1", "nonesuch2"))), "\"nonesuch1\" in degree2 does not regex-match any names") Error : (converted from warning) "nonesuch1" in degree2 does not regex-match any names Available names are "pclass" "sex" "age" "sibsp" "parch" Got expected error from try(plotmo(a81, do.par = FALSE, degree1 = 0, degree2 = c("nonesuch1", "nonesuch2"))) > expect.err(try(plotmo(a81, do.par=FALSE, degree1=0, degree2=c("nonesuch", "pclass"))), "\"nonesuch\" in degree2 does not regex-match any names") Error : (converted from warning) "nonesuch" in degree2 does not regex-match any names Available names are "pclass" "sex" "age" "sibsp" "parch" Got expected error from try(plotmo(a81, do.par = FALSE, degree1 = 0, degree2 = c("nonesuch", "pclass"))) > options(warn=1) # print warnings as they occur > par(org.par) > > par(mfrow=c(2,2), mar=c(1,2.5,2,1), oma=c(0,0,4,0)) > > # check that order of strings in two string degree2 is observed > cat('\n\ndegree2=c("age", "se"):\n') degree2=c("age", "se"): > plotmo(a81, do.par=FALSE, degree1=0, + degree2=c("age", "se"), main='degree2=c("age", "se")') > cat('\n\ndegree2=c("se", "age"):\n') degree2=c("se", "age"): > plotmo(a81, do.par=FALSE, degree1=0, + degree2=c("se", "age"), main='degree2=c("se", "age")') > > # check handling of bad strings in two string degree2 > cat('\n\ndegree2=c("nonesuch", "age"):\n') degree2=c("nonesuch", "age"): > try(plotmo(a81, do.par=FALSE, degree1=0, + degree2=c("nonesuch", "age"), main='degree2=c("nonesuch", "age")')) Warning: "nonesuch" in degree2 does not regex-match any names Available names are "pclass" "sex" "age" "sibsp" "parch" Warning: plotmo: nothing to plot > cat('\n\ndegree2=c("age", "nonesuch"):\n') degree2=c("age", "nonesuch"): > try(plotmo(a81, do.par=FALSE, degree1=0, + degree2=c("age", "nonesuch"), + main='degree2=c("age", "nonesuch")')) Warning: "nonesuch" in degree2 does not regex-match any names Available names are "pclass" "sex" "age" "sibsp" "parch" Warning: plotmo: nothing to plot > cat('\n\ndegree2=c("nevermore", "nonesuch"):\n') degree2=c("nevermore", "nonesuch"): > try(plotmo(a81, do.par=FALSE, degree1=0, + degree2=c("nevermore", "nonesuch"), + main='degree2=c("nevermore", "nonesuch")')) Warning: "nevermore" in degree2 does not regex-match any names Available names are "pclass" "sex" "age" "sibsp" "parch" Warning: plotmo: nothing to plot > # follow should still plot the degree1 plot even though degree2 spec is wrong > cat('\n\ndegree1=1, degree2=c("nevermore", "nonesuch"):\n') degree1=1, degree2=c("nevermore", "nonesuch"): > try(plotmo(a81, do.par=FALSE, degree1=1, + degree2=c("nevermore", "nonesuch"), + main='degree1=1\ndegree2=c("nevermore", "nonesuch")')) Warning: "nevermore" in degree2 does not regex-match any names Available names are "pclass" "sex" "age" "sibsp" "parch" plotmo grid: pclass sex age sibsp parch 3rd male 28 0 0 > > # expect warning: both elements of degree2 are the same > cat('\n\ndegree2=c("sex", "sex"):\n') degree2=c("sex", "sex"): > try(plotmo(a81, do.par=FALSE, degree1=0, + degree2=c("sex", "sex"), + main='degree1=1\ndegree2=c("sex", "sex")')) Warning: both elements of degree2 are the same > > par(org.par) > > source("test.epilog.R") plotmo/inst/slowtests/test.plotmo.dots.R0000644000176200001440000000365614566064534020222 0ustar liggesusers# test.dots.plotmo.R: test dots functions with the plotmo and earth libraries source("test.prolog.R") library(plotmo) library(earth) data(ozone1) options(warn=1) # print warnings as they occur a <- earth(O3~., data=ozone1, degree=2) expect.err(try(plotmo(a, persp.s=99)), "'s' matches both the 'sub' and 'scale' arguments of persp()") # Commented out because we now silently drop partial plot args like cex.l # expect.err(try(plotmo(a, cex.l=.8, cex.la=.9)), "arguments 'cex.l' and 'cex.la' both match 'cex.lab' in draw.plot_degree1") # expect.err(try(plotmo(a, persp.shad=1, persp.sh=2)), "'persp.shad' and 'persp.sh' both match the 'shade' argument of persp()") options(warn=2) # treat warnings as errors # Commented out because we now silently drop partial plot args like cex.l # expect.err(try(plotmo(a, cex.l=.8)), "\"cex.l\" is not a graphical parameter") # expect.err(try(plotmo(a, cex.lxx=.8)), "\"cex.lxx\" is not a graphical parameter") # expect.err(try(plotmo(a, cex.labx=.8)), "\"cex.labx\" is not a graphical parameter") # expect.err(try(plotmo(a, cex.l=.8, cex.lab=.9)), "\"cex.l\" is not a graphical parameter") expect.err(try(plotmo(a, nonesuch=.8)), "predict.earth ignored argument 'nonesuch'") expect.err(try(plotmo(a, lw=2)), "predict.earth ignored argument 'lw'") options(warn=1) # test main, xlab, ylab, etc. arguments with recycling a <- earth(O3~., data=ozone1, degree=2) plotmo(a, caption="test main, xlab, ylab, ticktype arguments", main=c("main1", "main2", "main3", "main4"), xlab=c("x1", "x2"), persp.nticks=2, persp.ticktype="d", ylab=c("y1", "y2", "y3")) par(mfrow=c(2,2), mar = c(3,3,3,1), mgp = c(1.5,.5,0), oma=c(0,0,4,0)) plotmo(a, trace=1, do.par=FALSE, degree1=1, degree2=1, caption="top: standard\nbottom: lwd=2 thresh=.9") # no errors or warnings plotmo(a, lwd=2, trace=1, thresh=.9, do.par=FALSE, degree1=1, degree2=1) # no errors or warnings source("test.epilog.R") plotmo/inst/slowtests/test.c50.Rout.save0000644000176200001440000000601214563614021017766 0ustar liggesusers> # test.c50.R: c50 tests for plotmo and plotres > > source("test.prolog.R") > library(C50) > library(rpart.plot) # for ptitanic, want data with NAs for testing Loading required package: rpart > library(plotmo) Loading required package: Formula Loading required package: plotrix > library(earth) # for etitanic > data(etitanic) > get.tit <- function() # abbreviated titanic data + { + tit <- etitanic + pclass <- as.character(tit$pclass) + # change the order of the factors so not alphabetical + pclass[pclass == "1st"] <- "first" + pclass[pclass == "2nd"] <- "class2" + pclass[pclass == "3rd"] <- "classthird" + tit$pclass <- factor(pclass, levels=c("class2", "classthird", "first")) + # log age is so we have a continuous predictor even when model is age~. + set.seed(2015) + tit$logage <- log(tit$age) + rnorm(nrow(tit)) + tit$parch <- NULL + # by=12 gives us a small fast model with an additive and a interaction term + tit <- tit[seq(1, nrow(etitanic), by=12), ] + } > tit <- get.tit() > > c50.tree.xy <- C5.0(x=tit[,-1], y=tit[,1]) # predict pclass > plotmo(c50.tree.xy, type="prob", nresponse="first", pmethod="apartdep") calculating apartdep for survived calculating apartdep for age calculating apartdep for logage calculating apartdep for survived:age 0123456790 calculating apartdep for survived:logage 0123456790 calculating apartdep for age:logage 01234567890 > plotmo(c50.tree.xy, type="class") plotmo grid: survived sex age sibsp logage 0 male 30 0 3.06991 > # TODO following gives error: type should be either 'class', 'confidence' or 'prob' > # try(plotmo(c50.tree.xy, type="confidence")) > plotres(c50.tree.xy, type="prob", nresponse="first") > > c50.tree.form <- C5.0(pclass~., data=tit) # predict pclass > plotmo(c50.tree.form, type="prob", nresponse="first") plotmo grid: survived sex age sibsp logage 0 male 30 0 3.06991 > plotmo(c50.tree.form, type="class") plotmo grid: survived sex age sibsp logage 0 male 30 0 3.06991 > # TODO following gives error: type should be either 'class', 'confidence' or 'prob' > # try(plotmo(c50.tree.form, type="confidence")) > plotres(c50.tree.form, type="prob", nresponse="first") > > tit$survived <- factor(ifelse(tit$survived == 1, "yes", "no"), + levels = c("yes", "no")) > c50.tree.survived <- C5.0(survived~., data=tit, trials=5) # predict survived > plotmo(c50.tree.survived, type="prob", nresponse="yes") plotmo grid: pclass sex age sibsp logage classthird male 30 0 3.06991 > plotmo(c50.tree.survived, type="class") plotmo grid: pclass sex age sibsp logage classthird male 30 0 3.06991 > # TODO following gives error: type should be either 'class', 'confidence' or 'prob' > # try(plotmo(c50.tree.survived, type="confidence")) > plotres(c50.tree.survived, type="prob", nresponse="yes") > > source("test.epilog.R") plotmo/inst/slowtests/makeclean.bat0000755000176200001440000000075514273324334017237 0ustar liggesusers@rem makeclean.bat: clean up R package slowtests directory @rem make sure we are in the right directory @cd ..\..\.. @if %errorlevel% NEQ 0 goto err @cd plotmo\inst\slowtests @if %errorlevel% NEQ 0 goto err rm -rf Debug Release .vs rm -f ../../src/earth_res.rc ../Makedeps rm -f *.dll *.lib *.pdb *.map *.ilk rm -f *.ps *.pdf *.Rout *.exe *.out @goto done :err @echo ==== ERROR ==== @exit /B %errorlevel% :done @exit /B 0 plotmo/inst/slowtests/test.gbm.bat0000755000176200001440000000142314563571565017047 0ustar liggesusers@rem test.gbm.bat: gbm tests for plotmo and plotres @echo test.gbm.bat @"C:\PROGRA~1\R\R-4.3.2\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.gbm.R @if %errorlevel% equ 0 goto good1: @echo R returned errorlevel %errorlevel%, see test.gbm.Rout: @echo. @tail test.gbm.Rout @echo test.gbm.R @exit /B 1 :good1 mks.diff test.gbm.Rout test.gbm.Rout.save @if %errorlevel% equ 0 goto good2: @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.gbm.save.ps @exit /B 1 :good2 @rem test.gbm.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.gbm.save.ps @if %errorlevel% equ 0 goto good3: @echo === Files are different === @exit /B 1 :good3 @rm -f test.gbm.Rout @rm -f Rplots.ps @exit /B 0 plotmo/inst/slowtests/test.non.earth.Rout.save0000644000176200001440000021222614567065443021315 0ustar liggesusers> # test.non.earth.R: test plotmo on non-earth models > # Stephen Milborrow, Basley KwaZulu-Natal Mar 2011 > > source("test.prolog.R") > library(plotmo) Loading required package: Formula Loading required package: plotrix > library(earth) > data(ozone1) > data(etitanic) > dopar <- function(nrows, ncols, caption = "") + { + cat(" ", caption, "\n") + par(mfrow=c(nrows, ncols)) + par(oma = c(0, 0, 3, 0)) + par(mar = c(3, 3, 1.7, 0.5)) + par(mgp = c(1.6, 0.6, 0)) + par(cex = 0.7) + } > caption <- "test lm(log(doy) ~ vh+wind+humidity+temp+log(ibh), data=ozone1)" > dopar(4,5,caption) test lm(log(doy) ~ vh+wind+humidity+temp+log(ibh), data=ozone1) > a <- lm(log(doy) ~ vh + wind + humidity + temp + log(ibh), data=ozone1) > set.seed(2020) > plotmo(a, do.par=FALSE, caption=caption, ylim=NA, col.response=3, pt.pch=20, smooth.col="indianred", + trace=2) plotmo trace 2: plotmo(object=a, smooth.col="indianred", do.par=FALSE, ylim=NA, caption=caption, trace=2, col.response=3, pt.pch=20) --get.model.env for object with class lm object call is lm(formula=log(doy)~vh+wind+humidity+temp+log(ibh), data=ozone1) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'a' --plotmo_x for lm object get.object.x: object$x is NULL (and it has no colnames) object call is lm(formula=log(doy)~vh+wind+humidity+temp+log(ibh), data=ozone1) get.x.from.model.frame: formula(object) is log(doy) ~ vh + wind + humidity + temp + log(ibh) naked formula is log(doy) ~ vh + wind + humidity + temp + ibh formula is valid, now looking for data for the model.frame object$model is usable and has column names log(doy) vh wind humidity temp log(ibh) object$model cannot be used because it has non-naked column names "log(doy)" "log(ibh)" object$data is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names O3 vh wind humidity temp ibh dpg ibt vis doy na.action(object) is "na.fail" stats::model.frame(log(doy) ~ vh + wind + humidity + tem..., data=call$data, na.action="na.fail") x=model.frame[,-1] is usable and has column names vh wind humidity temp ibh plotmo_x returned[330,5]: vh wind humidity temp ibh 1 5710 4 28 40 2693 2 5700 3 37 45 590 3 5760 3 51 54 1450 ... 5720 4 69 35 1568 330 5550 4 85 39 5000 ----Metadata: plotmo_predict with nresponse=NULL and newdata=NULL calling predict.lm with NULL newdata stats::predict(lm.object, NULL, type="response") predict returned[330,1] with no column names: 1 4.869230 2 4.711557 3 5.135810 ... 4.906652 330 5.044131 predict after processing with nresponse=NULL is [330,1] with no column names: 1 4.869230 2 4.711557 3 5.135810 ... 4.906652 330 5.044131 ----Metadata: plotmo_fitted with nresponse=NULL stats::fitted(object=lm.object) fitted(object) returned[330,1] with no column names: 1 4.869230 2 4.711557 3 5.135810 ... 4.906652 330 5.044131 fitted(object) after processing with nresponse=NULL is [330,1] with no column names: 1 4.869230 2 4.711557 3 5.135810 ... 4.906652 330 5.044131 ----Metadata: plotmo_y with nresponse=NULL --plotmo_y with nresponse=NULL for lm object get.object.y: object$y is NULL (and it has no colnames) object call is lm(formula=log(doy)~vh+wind+humidity+temp+log(ibh), data=ozone1) get.y.from.model.frame: formula(object) is log(doy) ~ vh + wind + humidity + temp + log(ibh) formula is valid, now looking for data for the model.frame object$model is usable and has column names log(doy) vh wind humidity temp log(ibh) object$model cannot be used because it has non-naked column names "log(doy)" "log(ibh)" object$data is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names O3 vh wind humidity temp ibh dpg ibt vis doy na.action(object) is "na.fail" stats::model.frame(log(doy) ~ vh + wind + humidity + tem..., data=call$data, na.action="na.fail") y=model.frame[,1] is usable and has column name log(doy) plotmo_y returned[330,1]: log(doy) 1 3.496508 2 3.526361 3 3.555348 ... 3.583519 330 5.966147 plotmo_y after processing with nresponse=NULL is [330,1]: log(doy) 1 3.496508 2 3.526361 3 3.555348 ... 3.583519 330 5.966147 converted nresponse=NA to nresponse=1 nresponse=1 (was NA) ncol(fitted) 1 ncol(predict) 1 ncol(y) 1 ----Metadata: plotmo_y with nresponse=1 --plotmo_y with nresponse=1 for lm object get.object.y: object$y is NULL (and it has no colnames) object call is lm(formula=log(doy)~vh+wind+humidity+temp+log(ibh), data=ozone1) get.y.from.model.frame: formula(object) is log(doy) ~ vh + wind + humidity + temp + log(ibh) formula is valid, now looking for data for the model.frame object$model is usable and has column names log(doy) vh wind humidity temp log(ibh) object$model cannot be used because it has non-naked column names "log(doy)" "log(ibh)" object$data is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names O3 vh wind humidity temp ibh dpg ibt vis doy na.action(object) is "na.fail" stats::model.frame(log(doy) ~ vh + wind + humidity + tem..., data=call$data, na.action="na.fail") y=model.frame[,1] is usable and has column name log(doy) got model response from model.frame(log(doy) ~ vh + wind + humidity + tem..., data=call$data, na.action="na.fail") plotmo_y returned[330,1]: log(doy) 1 3.496508 2 3.526361 3 3.555348 ... 3.583519 330 5.966147 plotmo_y after processing with nresponse=1 is [330,1]: log(doy) 1 3.496508 2 3.526361 3 3.555348 ... 3.583519 330 5.966147 got response name "log(doy)" from yfull resp.levs is NULL ----Metadata: done number of x values: vh 53 wind 11 humidity 65 temp 63 ibh 196 ----plotmo_singles for lm object singles: 1 vh, 2 wind, 3 humidity, 4 temp, 5 ibh ----plotmo_pairs for lm object formula(object) returned log(doy) ~ vh + wind + humidity + temp + log(ibh) formula.vars "vh" "wind" "humidity" "temp" "log(ibh)" term.labels "vh" "wind" "humidity" "temp" "log(ibh)" plotmo_pairs_from_term_labels term.labels: "vh" "wind" "humidity" "temp" "log(ibh)" "vh" "wind" "humidity" "temp" "log(ibh)" pred.names: "vh" "wind" "humidity" "temp" "ibh" considering vh considering wind considering humidity considering temp considering log(ibh) considering vh considering wind considering humidity considering temp considering log(ibh) no pairs ----Figuring out ylim ylim c(NA, NA) clip TRUE --plot.degree1(draw.plot=TRUE) plotmo grid: vh wind humidity temp ibh 5760 5 64 62 2112.5 degree1 plot1 (pmethod "plotmo") variable vh newdata[50,5]: vh wind humidity temp ibh 1 5320.000 5 64 62 2112.5 2 5332.857 5 64 62 2112.5 3 5345.714 5 64 62 2112.5 ... 5358.571 5 64 62 2112.5 50 5950.000 5 64 62 2112.5 stats::predict(lm.object, data.frame[50,5], type="response") predict returned[50,1] with no column names: 1 4.684507 2 4.700786 3 4.717064 ... 4.733343 50 5.482156 predict after processing with nresponse=1 is [50,1]: predict 1 4.684507 2 4.700786 3 4.717064 ... 4.733343 50 5.482156 graphics::plot.default(x=c(5320,5333,534...), y=c(4.685,4.701,4...), type="n", main="1 vh", xlab="", ylab="", xaxt="s", yaxt="s", xlim=c(5320,5951), ylim=NULL) Reducing trace level for subsequent degree1 plots degree1 plot2 (pmethod "plotmo") variable wind degree1 plot3 (pmethod "plotmo") variable humidity degree1 plot4 (pmethod "plotmo") variable temp degree1 plot5 (pmethod "plotmo") variable ibh > termplot(a) > par(org.par) > > caption <- "test lm(log(doy) ~ vh+wind+humidity+I(wind*humidity)+temp+log(ibh), data=ozone1)" > dopar(4,5,caption) test lm(log(doy) ~ vh+wind+humidity+I(wind*humidity)+temp+log(ibh), data=ozone1) > a <- lm(log(doy) ~ vh + wind + humidity + temp + log(ibh), data=ozone1) > set.seed(2020) > plotmo(a, do.par=FALSE, caption=caption, ylim=NA, col.resp=3, pt.pch=20, clip=FALSE, smooth.col="indianred") plotmo grid: vh wind humidity temp ibh 5760 5 64 62 2112.5 > termplot(a) > par(org.par) > > caption <- "test lm(doy ~ (vh+wind+humidity)^2, data=ozone1)" > dopar(4,3,caption) test lm(doy ~ (vh+wind+humidity)^2, data=ozone1) > a <- lm(doy ~ (vh+wind+humidity)^2, data=ozone1) > plotmo(a, do.par=FALSE, caption=caption, ylim=NULL) plotmo grid: vh wind humidity 5760 5 64 > # termplot(a) # termplot fails with Error in `[.data.frame`(mf, , i): undefined columns selected > par(org.par) > > caption <- "test lm(doy^2 ~ vh+wind+humidity+I(wind*humidity)+temp+log(ibh), data=ozone1)" > dopar(4,3,caption) test lm(doy^2 ~ vh+wind+humidity+I(wind*humidity)+temp+log(ibh), data=ozone1) > a <- lm(doy^2 ~ vh+wind+humidity+I(wind*humidity)+temp+log(ibh), data=ozone1) > plotmo(a, do.par=FALSE, caption=caption, ylim=NULL) plotmo grid: vh wind humidity temp ibh 5760 5 64 62 2112.5 > termplot(a) # termplot draws a funky second wind plot > par(org.par) > > caption <- "test lm with data=ozone versus attach(ozone)" > dopar(4,3,caption) test lm with data=ozone versus attach(ozone) > a <- lm(log(doy) ~ I(vh*wind) + wind + I(humidity*temp) + log(ibh), data=ozone1) > plotmo(a, do.par=FALSE, caption=caption, degree1=c(1,2,4,5)) plotmo grid: vh wind humidity temp ibh 5760 5 64 62 2112.5 > attach(ozone1) > a <- lm(log(doy) ~ I(vh*wind) + wind + I(humidity*temp) + log(ibh)) > plotmo(a, do.par=FALSE, degree1=c(1,2,4,5)) plotmo grid: vh wind humidity temp ibh 5760 5 64 62 2112.5 > detach(ozone1) > par(org.par) > > # commented out because "$" in names is not yet supported > # a <- lm(log(ozone1$doy) ~ I(ozone1$vh*ozone1$wind) + log(ozone1$ibh)) > # plotmo(a) > > set.seed(1) > caption <- "test lm and glm a900..a902: damage~temp family=binomial data=orings" > dopar(2,3,caption) test lm and glm a900..a902: damage~temp family=binomial data=orings > library(faraway) > data(orings) > a900 <- lm(I(damage/6) ~ temp, data=orings) > plotmo(a900, do.par=FALSE, caption=caption, col.response=2, nrug=-1, + main="lm(damage/6~temp)", smooth.col="indianred", trace=0) > response <- cbind(orings$damage, 6-orings$damage) > a901 <- glm(response ~ temp, family="binomial", data=orings) > set.seed(2020) > plotmo(a901, do.par=FALSE, col.response=2, nrug=-1, + main="glm(response~temp)", smooth.col="indianred", trace=2) plotmo trace 2: plotmo(object=a901, smooth.col="indianred", nrug=-1, do.par=FALSE, trace=2, col.response=2, main="glm(response~temp)") --get.model.env for object with class glm object call is glm(formula=response~temp, family="binomial", data=orings) using the environment saved in $terms of the glm model: R_GlobalEnv --plotmo_prolog for glm object 'a901' --plotmo_x for glm object get.object.x: object$x is NULL (and it has no colnames) object call is glm(formula=response~temp, family="binomial", data=orings) get.x.from.model.frame: formula(object) is response ~ temp naked formula is the same formula is valid, now looking for data for the model.frame object$model is usable and has column names response temp x=model.frame[,-1] is usable and has column name temp plotmo_x returned[23,1]: temp 1 53 2 57 3 58 ... 63 23 81 ----Metadata: plotmo_predict with nresponse=NULL and newdata=NULL plotmo_predict with NULL newdata (nrows=3), using plotmo_x to get the data --plotmo_x for glm object get.object.x: object$x is NULL (and it has no colnames) object call is glm(formula=response~temp, family="binomial", data=orings) get.x.from.model.frame: formula(object) is response ~ temp naked formula is the same formula is valid, now looking for data for the model.frame object$model is usable and has column names response temp x=model.frame[,-1] is usable and has column name temp plotmo_x returned[23,1]: temp 1 53 2 57 3 58 ... 63 23 81 will use the above data instead of newdata=NULL for predict.glm stats::predict(glm.object, data.frame[3,1], type="response") predict returned[3,1] with no column names: 1 0.5504788 2 0.3402166 3 0.2934757 predict after processing with nresponse=NULL is [3,1] with no column names: 1 0.5504788 2 0.3402166 3 0.2934757 ----Metadata: plotmo_fitted with nresponse=NULL stats::fitted(object=glm.object) fitted(object) returned[23,1] with no column names: 1 0.550478817 2 0.340216592 3 0.293475686 ... 0.123496147 23 0.002866088 fitted(object) after processing with nresponse=NULL is [23,1] with no column names: 1 0.550478817 2 0.340216592 3 0.293475686 ... 0.123496147 23 0.002866088 ----Metadata: plotmo_y with nresponse=NULL --plotmo_y with nresponse=NULL for glm object get.object.y: object$y is usable but without colnames so we will keep on searching object call is glm(formula=response~temp, family="binomial", data=orings) get.y.from.model.frame: formula(object) is response ~ temp formula is valid, now looking for data for the model.frame object$model is usable and has column names response temp y=model.frame[,1] is usable and has column name response the variable on the left side of the formula is a matrix or data.frame plotmo often cannot process such variables the number of dimensions of each variable in y is 2 and y is [23,1] with colname response, and values c(5, 1, 1, 1, 0, 0, 0, 0, 0, ... replacing y with y[[1]] y colnames were "response" and now "response[,1]" "response[,2]" plotmo_y returned[23,2]: response[,1] response[,2] 1 5 1 2 1 5 3 1 5 ... 1 5 23 0 6 plotmo_y after processing with nresponse=NULL is [23,2]: response[,1] response[,2] 1 5 1 2 1 5 3 1 5 ... 1 5 23 0 6 converted nresponse=NA to nresponse=1 nresponse=1 (was NA) ncol(fitted) 1 ncol(predict) 1 ncol(y) 2 ----Metadata: plotmo_y with nresponse=1 --plotmo_y with nresponse=1 for glm object get.object.y: object$y is usable but without colnames so we will keep on searching object call is glm(formula=response~temp, family="binomial", data=orings) get.y.from.model.frame: formula(object) is response ~ temp formula is valid, now looking for data for the model.frame object$model is usable and has column names response temp y=model.frame[,1] is usable and has column name response the variable on the left side of the formula is a matrix or data.frame plotmo often cannot process such variables the number of dimensions of each variable in y is 2 and y is [23,1] with colname response, and values c(5, 1, 1, 1, 0, 0, 0, 0, 0, ... replacing y with y[[1]] y colnames were "response" and now "response[,1]" "response[,2]" got model response from object$model yfrac[23,1] with colname response[,1], and values 0.8333, 0.1667, 0.1667, 0.166... created column "response.yfrac" from two column binomial response plotmo_y returned[23,1]: response.yfrac 1 0.8333333 2 0.1666667 3 0.1666667 ... 0.1666667 23 0.0000000 plotmo_y after processing with nresponse=1 is [23,1]: response.yfrac 1 0.8333333 2 0.1666667 3 0.1666667 ... 0.1666667 23 0.0000000 got response name "response[,1]" from yfull resp.levs is NULL ----Metadata: done number of x values: temp 16 ----plotmo_singles for glm object singles: 1 temp ----plotmo_pairs for glm object formula(object) returned response ~ temp formula.vars "temp" term.labels "temp" plotmo_pairs_from_term_labels term.labels: "temp" "temp" pred.names: "temp" considering temp considering temp no pairs ----Figuring out ylim ylim c(-0.1, 1.1) clip TRUE --plot.degree1(draw.plot=TRUE) degree1 plot1 (pmethod "plotmo") variable temp newdata[50,1]: temp 1 53.00000 2 53.57143 3 54.14286 ... 54.71429 50 81.00000 stats::predict(glm.object, data.frame[50,1], type="response") predict returned[50,1] with no column names: 1 0.550478817 2 0.519750569 3 0.488872165 ... 0.458078452 50 0.002866088 predict after processing with nresponse=1 is [50,1]: predict 1 0.550478817 2 0.519750569 3 0.488872165 ... 0.458078452 50 0.002866088 graphics::plot.default(x=c(53,53.57,54.1...), y=c(0.5505,0.5198...), type="n", main="glm(response~temp)", xlab="", ylab="", xaxt="s", yaxt="s", xlim=c(53,81.01), ylim=c(-0.1,1.1)) > a902 <- glm(cbind(damage, 6-damage)~temp, family="binomial", data=orings) > set.seed(2020) > plotmo(a902, do.par=FALSE, col.response=2, nrug=TRUE, + main="glm(cbind(damage,6-damage)~temp)", trace=0) > termplot(a902, main="termplot") > plotmo(a902, type="link", main="type=\"link\"", do.par=F) > set.seed(2020) > plotmo(a902, type="response", main="type=\"response\"", col.response=2, do.par=F) > par(org.par) > > set.seed(1) > caption <- "test glm(lot2~log(u),data=clotting,family=Gamma)" > dopar(2,2,caption) test glm(lot2~log(u),data=clotting,family=Gamma) > u = c(5,10,15,20,30,40,60,80,100) > lota = c(118,58,42,35,27,25,21,19,18) > clotting <- data.frame(u = u, lota = lota) > a <- glm(lota ~ log(u), data=clotting, family=Gamma) > set.seed(2020) > plotmo(a, do.par=FALSE, caption=caption, col.response=3, clip=FALSE, nrug=-1) > termplot(a) > plotmo(a, type="link", caption=paste("type=\"link\"", caption)) > par(org.par) > > if(length(grep("package:gam", search()))) + detach("package:gam") > library(mgcv) Loading required package: nlme This is mgcv 1.9-1. For overview type 'help("mgcv-package")'. > set.seed(1) > caption <- "test plot.gam, with mgcv::gam(y ~ s(x) + s(x,z)) with response and func (and extra image plot)" > dopar(3,2,caption) test plot.gam, with mgcv::gam(y ~ s(x) + s(x,z)) with response and func (and extra image plot) > par(mar = c(3, 5, 1.7, 0.5)) # more space for left and bottom axis > test1 <- function(x,sx=0.3,sz=0.4) + (pi**sx*sz)*(1.2*exp(-(x[,1]-0.2)^2/sx^2-(x[,2]-0.3)^2/sz^2)+ + 0.8*exp(-(x[,1]-0.7)^2/sx^2-(x[,2]-0.8)^2/sz^2)) > n <- 100 > set.seed(1) > x <- runif(n); > z1 <- runif(n); > y <- test1(cbind(x,z1)) + rnorm(n) * 0.1 > a <- gam(y ~ s(x) + s(x,z1)) > set.seed(2020) > plotmo(a, do.par=FALSE, type2="contour", caption=caption, + col.response=3, smooth.col="indianred", + func=test1, func.col="indianred", func.lwd=5, func.lty=2, smooth.lwd=3) plotmo grid: x z1 0.4878107 0.5185988 > > plotmo(a, do.par=FALSE, degree1=F, degree2=1, type2="image", ylim=NA) > plot(a, select=1) > plot(a, select=2) > plot(a, select=3) > n<-400 > sig<-2 > set.seed(1) > x0 <- runif(n, 0, 1) > x1 <- runif(n, 0, 1) > x2 <- runif(n, 0, 1) > x3 <- runif(n, 0, 1) > f0 <- function(x) 2 * sin(pi * x) > f1 <- function(x) exp(2 * x) > f2 <- function(x) 0.2*x^11*(10*(1-x))^6+10*(10*x)^3*(1-x)^10 > f <- f0(x0) + f1(x1) + f2(x2) > e <- rnorm(n, 0, sig) > y <- f + e > test.func <- function(x) f0(x[,1]) + f1(x[,2]) + f2(x[,3]) > library(mgcv) > caption <- "test mgcv::gam(y~s(x0,x1,k=12)+s(x2)+s(x3,k=20,fx=20)) (and extra persp plot)" > dopar(3,3,caption) test mgcv::gam(y~s(x0,x1,k=12)+s(x2)+s(x3,k=20,fx=20)) (and extra persp plot) > a <- gam(y~s(x0,x1,k=12)+s(x2)+s(x3,k=20,fx=20)) > plot(a, select=2) > plot(a, select=3) > plot(a, select=1) > plotmo(a, do.par=FALSE, type2="contour", caption=caption, xlab=NULL, main="", func=test.func, ngrid2=10, contour.drawlabels=FALSE) plotmo grid: x0 x1 x2 x3 0.474141 0.5151294 0.4460308 0.479208 > plotmo(a, do.par=FALSE, degree1=F, degree2=1, persp.the=-35) > par(org.par) > > set.seed(1) > caption <- "test plot.gam, with mgcv::gam(doy~s(wind)+s(humidity,wind)+s(vh)+temp,data=ozone1)" > dopar(3,3,caption) test plot.gam, with mgcv::gam(doy~s(wind)+s(humidity,wind)+s(vh)+temp,data=ozone1) > a <- gam(doy ~ s(wind) + s(humidity,wind) + s(vh) + temp, data=ozone1) > plotmo(a, do.par=FALSE, caption=caption, type2="contour", degree1=c("wind","vh"), swapxy=T, xlab=NULL, main="", clip=FALSE) plotmo grid: temp wind humidity vh 62 5 64 5760 > plot(a, select=1) > plot(a, select=3) > plot(a, select=2) > plot(a, select=4) > par(org.par) > > detach("package:mgcv") > library(gam) Loading required package: splines Loading required package: foreach Loaded gam 1.22-3 > caption <- "test gam:gam(Ozone^(1/3)~lo(Solar.R)+lo(Wind, Temp),data=airquality)" > set.seed(1) > dopar(3,2,caption) test gam:gam(Ozone^(1/3)~lo(Solar.R)+lo(Wind, Temp),data=airquality) > data(airquality) > airquality <- na.omit(airquality) # plotmo doesn't know how to deal with NAs yet > a <- gam(Ozone^(1/3) ~ lo(Solar.R) + lo(Wind, Temp), data = airquality) > set.seed(2020) > plotmo(a, do.par=FALSE, caption=caption, ylim=NA, col.response=3) plotmo grid: Solar.R Wind Temp 207 9.7 79 > # termplot gives fishy looking wind plot, plotmo looks ok > # termplot(a) #TODO this fails with R2.5: dim(data) <- dim: attempt to set an attribute on NULL > detach("package:gam") > par(org.par) > > library(mda) Loading required package: class Loaded mda 0.5-4 > caption <- "test mars and earth (expect not a close match)" > dopar(6,3,caption) test mars and earth (expect not a close match) > a <- mars( ozone1[, -1], ozone1[,1], degree=2) > b <- earth(ozone1[, -1], ozone1[,1], degree=2) > # this also tests trace=2 on a non formula model > plotmo(a, do.par=FALSE, caption=caption, trace=2) plotmo trace 2: plotmo(object=a, do.par=FALSE, caption=caption, trace=2) --get.model.env for object with class mars object call is mars(x=ozone1[, -1], y=ozone1[, 1], degree=2) assuming the environment of the mars model is that of plotmo's caller: R_GlobalEnv --plotmo_prolog for mars object 'a' --plotmo_x for mars object get.object.x: ignoring object$x for this mars object object call is mars(x=ozone1[, -1], y=ozone1[, 1], degree=2) get.x.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$x, R_GlobalEnv) getCall(object)$x is usable and has column names vh wind humidity temp ibh dpg ibt vis doy plotmo_x returned[330,9]: vh wind humidity temp ibh dpg ibt vis doy 1 5710 4 28 40 2693 -25 87 250 33 2 5700 3 37 45 590 -24 128 100 34 3 5760 3 51 54 1450 25 139 60 35 ... 5720 4 69 35 1568 15 121 60 36 330 5550 4 85 39 5000 8 44 100 390 ----Metadata: plotmo_predict with nresponse=NULL and newdata=NULL plotmo_predict with NULL newdata (nrows=3), using plotmo_x to get the data --plotmo_x for mars object get.object.x: ignoring object$x for this mars object object call is mars(x=ozone1[, -1], y=ozone1[, 1], degree=2) get.x.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$x, R_GlobalEnv) getCall(object)$x is usable and has column names vh wind humidity temp ibh dpg ibt vis doy plotmo_x returned[330,9]: vh wind humidity temp ibh dpg ibt vis doy 1 5710 4 28 40 2693 -25 87 250 33 2 5700 3 37 45 590 -24 128 100 34 3 5760 3 51 54 1450 25 139 60 35 ... 5720 4 69 35 1568 15 121 60 36 330 5550 4 85 39 5000 8 44 100 390 will use the above data instead of newdata=NULL for predict.mars stats::predict(mars.object, data.frame[3,9], type="response") predict returned[3,1] with no column names: 1 3.333568 2 1.865073 3 7.044289 predict after processing with nresponse=NULL is [3,1] with no column names: 1 3.333568 2 1.865073 3 7.044289 ----Metadata: plotmo_fitted with nresponse=NULL stats::fitted(object=mars.object) fitted(object) returned[330,1] with no column names: 1 3.333568 2 1.865073 3 7.044289 ... 6.925382 330 1.885331 fitted(object) after processing with nresponse=NULL is [330,1] with no column names: 1 3.333568 2 1.865073 3 7.044289 ... 6.925382 330 1.885331 ----Metadata: plotmo_y with nresponse=NULL --plotmo_y with nresponse=NULL for mars object get.object.y: object$y is NULL (and it has no colnames) object call is mars(x=ozone1[, -1], y=ozone1[, 1], degree=2) get.y.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$y, R_GlobalEnv) getCall(object)$y is usable but without colnames so we will keep on searching names(call) is "" "x" "y" "degree" the name of argument 2 is "y" so we will not process it with argn object$y is NULL call$y is usable but without colnames but we will use it anyway plotmo_y returned[330,1] with no column names: 1 3 2 5 3 5 ... 6 330 1 plotmo_y after processing with nresponse=NULL is [330,1] with no column names: 1 3 2 5 3 5 ... 6 330 1 converted nresponse=NA to nresponse=1 nresponse=1 (was NA) ncol(fitted) 1 ncol(predict) 1 ncol(y) 1 ----Metadata: plotmo_y with nresponse=1 --plotmo_y with nresponse=1 for mars object get.object.y: object$y is NULL (and it has no colnames) object call is mars(x=ozone1[, -1], y=ozone1[, 1], degree=2) get.y.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$y, R_GlobalEnv) getCall(object)$y is usable but without colnames so we will keep on searching names(call) is "" "x" "y" "degree" the name of argument 2 is "y" so we will not process it with argn object$y is NULL call$y is usable but without colnames but we will use it anyway got model response from getCall(object)$y plotmo_y returned[330,1] with no column names: 1 3 2 5 3 5 ... 6 330 1 plotmo_y after processing with nresponse=1 is [330,1]: plotmo_y 1 3 2 5 3 5 ... 6 330 1 response name is NULL resp.levs is NULL ----Metadata: done number of x values: vh 53 wind 11 humidity 65 temp 63 ibh 196 dpg 128 ibt 193... ----plotmo_singles for mars object singles: 1 vh, 2 wind, 3 humidity, 4 temp, 5 ibh, 6 dpg, 7 ibt, 8 vis, 9 doy ----plotmo_pairs for mars object Error in formula.default(object) : invalid formula formula(object) failed for mars object in plotmo.pairs.default Error in x$terms %||% attr(x, "terms") %||% stop("no terms component nor attribute") : no terms component nor attribute terms(object) failed for mars object in plotmo.pairs.default no pairs ----Figuring out ylim --get.ylim.by.dummy.plots --plot.degree1(draw.plot=FALSE) degree1 plot1 (pmethod "plotmo") variable vh newdata[50,9]: vh wind humidity temp ibh dpg ibt vis doy 1 5320.000 5 64 62 2112.5 24 167.5 120 205.5 2 5332.857 5 64 62 2112.5 24 167.5 120 205.5 3 5345.714 5 64 62 2112.5 24 167.5 120 205.5 ... 5358.571 5 64 62 2112.5 24 167.5 120 205.5 50 5950.000 5 64 62 2112.5 24 167.5 120 205.5 stats::predict(mars.object, data.frame[50,9], type="response") predict returned[50,1] with no column names: 1 8.123619 2 8.303007 3 8.482395 ... 8.661783 50 16.216014 predict after processing with nresponse=1 is [50,1]: predict 1 8.123619 2 8.303007 3 8.482395 ... 8.661783 50 16.216014 Reducing trace level for subsequent degree1 plots degree1 plot2 (pmethod "plotmo") variable wind degree1 plot3 (pmethod "plotmo") variable humidity degree1 plot4 (pmethod "plotmo") variable temp degree1 plot5 (pmethod "plotmo") variable ibh degree1 plot6 (pmethod "plotmo") variable dpg degree1 plot7 (pmethod "plotmo") variable ibt degree1 plot8 (pmethod "plotmo") variable vis degree1 plot9 (pmethod "plotmo") variable doy --done get.ylim.by.dummy.plots ylim c(6.671, 20.41) clip TRUE --plot.degree1(draw.plot=TRUE) plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 graphics::plot.default(x=c(5320,5333,534...), y=c(8.124,8.303,8...), type="n", main="1 vh", xlab="", ylab="", xaxt="s", yaxt="s", xlim=c(5320,5950), ylim=c(6.671,20.42)) > plotmo(b, do.par=FALSE) plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > par(org.par) > > caption <- "test mars and mars.to.earth(mars) (expect no degree2 for mars)" > dopar(6,3,caption) test mars and mars.to.earth(mars) (expect no degree2 for mars) > a <- mars(ozone1[, -1], ozone1[,1], degree=2) > b <- mars.to.earth(a) Converted mars(x=ozone1[,-1], y=ozone1[,1], degree=2) to earth(x=ozone1[,-1], y=ozone1[,1], degree=2) > plotmo(a, do.par=FALSE, caption=caption, ylim=NA) plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > plotmo(b, do.par=FALSE, ylim=NA) plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > par(org.par) > > # check fix for bug reported by Martin Maechler: > # form <- Volume ~ .; a <- earth(form, data = trees); plotmo(a) fails > > dopar(4,4, "test f <- O3 ~ .; a <- earth(f, data=ozone1)") test f <- O3 ~ .; a <- earth(f, data=ozone1) > fa <- log(O3) ~ . > a <- earth(fa, data=ozone1, degree=2) > print(summary(a)) Call: earth(formula=fa, data=ozone1, degree=2) coefficients (Intercept) 2.79412331 h(47-humidity) -0.01328663 h(52-temp) -0.01753702 h(temp-52) 0.02311792 h(1105-ibh) -0.00030601 h(13-dpg) -0.00523433 h(dpg-13) -0.00788042 h(194-ibt) -0.00459263 h(200-vis) 0.00195292 h(96-doy) -0.01324138 h(doy-96) -0.00278616 h(wind-7) * h(200-vis) -0.00153720 h(43-humidity) * h(52-temp) 0.00187488 h(humidity-67) * h(ibh-1105) -0.00000914 Selected 14 of 21 terms, and 8 of 9 predictors Termination condition: Reached nk 21 Importance: temp, ibt, doy, humidity, ibh, dpg, vis, wind, vh-unused Number of terms at each degree of interaction: 1 10 3 GCV 0.1058972 RSS 28.2111 GRSq 0.8114829 RSq 0.8468883 > plot(a, do.par=FALSE) > set.seed(2020) > plotmo(a, do.par=FALSE, degree1=2:3, degree2=c(1,2), col.response = "pink", smooth.col="indianred") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > a <- lm(log(doy) ~ I(vh*wind) + I(humidity*temp) + log(ibh), data=ozone1) > plotmo(a, do.par=FALSE, degree1=1:2) plotmo grid: vh wind humidity temp ibh 5760 5 64 62 2112.5 > fa <- log(doy) ~ I(vh*wind) + I(humidity*temp) + log(ibh) > a <- lm(fa, data=ozone1) > plotmo(a, do.par=FALSE, degree1=1:2) plotmo grid: vh wind humidity temp ibh 5760 5 64 62 2112.5 > par(org.par) > > # test inverse.func and func > > caption <- "test inverse.func=exp" > a <- lm(log(Volume) ~ Girth + Height + I(Girth*Height), data=trees) > my.func <- function(x) -60 + 5 * x[,1] + x[,2] / 3 > set.seed(2020) > plotmo(a, caption=caption, inverse.func = exp, col.response = "pink", func=my.func, func.col="gray", ngrid1=1000, type2="p", smooth.col="indianred") plotmo grid: Girth Height 12.9 76 > par(org.par) > > # se testing > > caption = "level=.95, lm(doy~., data=ozone1) versus termplot" > dopar(6,3,caption) level=.95, lm(doy~., data=ozone1) versus termplot > a <- lm(doy~., data=ozone1) > plotmo(a, level=.95, do.par=FALSE, caption=caption) plotmo grid: O3 vh wind humidity temp ibh dpg ibt vis 10 5760 5 64 62 2112.5 24 167.5 120 > termplot(a, se=2) > par(org.par) > > caption <- "test different se options, level=.95, lm(log(doy)~vh+wind+log(humidity),data=ozone1)" > dopar(4,3,caption) test different se options, level=.95, lm(log(doy)~vh+wind+log(humidity),data=ozone1) > a <- lm(log(doy) ~ vh + wind + log(humidity), data=ozone1) > plotmo(a, do.par=FALSE, caption=caption, ylim=NA, level=.95) plotmo grid: vh wind humidity 5760 5 64 > plotmo(a, do.par=FALSE, caption=caption, ylim=NA, level=.95, level.shade="pink", level.shade2=3) plotmo grid: vh wind humidity 5760 5 64 > plotmo(a, do.par=FALSE, caption=caption, ylim=NA, level=.95, level.shade=3) plotmo grid: vh wind humidity 5760 5 64 > plotmo(a, do.par=FALSE, caption=caption, ylim=NULL, level=.95, level.shade=3) plotmo grid: vh wind humidity 5760 5 64 > par(org.par) > > caption <- "test level=.95, lm(log(doy)~vh+wind+log(humidity),data=ozone1)" > dopar(2,3,caption) test level=.95, lm(log(doy)~vh+wind+log(humidity),data=ozone1) > a <- lm(log(doy) ~ vh + wind + log(humidity), data=ozone1) > plotmo(a, do.par=FALSE, caption=caption, ylim=NA, level=.95) plotmo grid: vh wind humidity 5760 5 64 > termplot(a, se=2) > par(org.par) > > caption <- "test level=.95 and inverse.func, lm(log(doy)~vh+wind+log(humidity),data=ozone1)" > dopar(3,3,caption) test level=.95 and inverse.func, lm(log(doy)~vh+wind+log(humidity),data=ozone1) > a <- lm(log(doy) ~ vh + wind + log(humidity), data=ozone1) > plotmo(a, do.par=FALSE, caption=caption, ylim=NA, level=.95) plotmo grid: vh wind humidity 5760 5 64 > plotmo(a, do.par=FALSE, caption=caption, ylim=NULL, level=.95, inverse.func=exp) plotmo grid: vh wind humidity 5760 5 64 > termplot(a, se=2) > par(org.par) > > caption <- "test level=.95, glm(lot2~log(u),data=clotting,family=Gamma)" > set.seed(1) > dopar(2,2,caption) test level=.95, glm(lot2~log(u),data=clotting,family=Gamma) > u = c(5,10,15,20,30,40,60,80,100) > lota = c(118,58,42,35,27,25,21,19,18) > clotting <- data.frame(u = u, lota = lota) > a <- glm(lota ~ log(u), data=clotting, family=Gamma) > set.seed(2020) > plotmo(a, do.par=FALSE, caption=caption, col.response=4, pt.pch=7, clip=FALSE, nrug=-1, level=.95, smooth.col="indianred") Warning: the level argument may not work correctly on glm objects built with weights > termplot(a, se=2) > par(org.par) > > if(length(grep("package:gam", search()))) + detach("package:gam") > library(mgcv) This is mgcv 1.9-1. For overview type 'help("mgcv-package")'. > set.seed(1) > caption <- "test level=.95, plot.gam, with mgcv::gam(y ~ s(x) + s(x,z1)) with response and func (and extra image plot)" > dopar(3,2,caption) test level=.95, plot.gam, with mgcv::gam(y ~ s(x) + s(x,z1)) with response and func (and extra image plot) > par(mar = c(3, 5, 1.7, 0.5)) # more space for left and bottom axis > test1 <- function(x,sx=0.3,sz=0.4) + (pi**sx*sz)*(1.2*exp(-(x[,1]-0.2)^2/sx^2-(x[,2]-0.3)^2/sz^2)+ + 0.8*exp(-(x[,1]-0.7)^2/sx^2-(x[,2]-0.8)^2/sz^2)) > n <- 100 > set.seed(1) > x <- runif(n); > z1 <- runif(n); > y <- test1(cbind(x,z1)) + rnorm(n) * 0.1 > a <- gam(y ~ s(x) + s(x,z1)) > set.seed(2020) > plotmo(a, do.par=FALSE, type2="contour", caption=caption, col.response=3, func=test1, func.col="magenta", level=.95) plotmo grid: x z1 0.4878107 0.5185988 > plotmo(a, do.par=FALSE, degree1=F, degree2=1, type2="image", image.col=topo.colors(10), + ylim=NA, level=.95, main="topo.colors") > plot(a, select=1) > plot(a, select=2) > plot(a, select=3) > par(org.par) > > # TODO Following commented out because it causes: > # Error: gam objects in the "gam" package do not support confidence intervals on new data > # detach("package:mgcv") > # library(gam) > # set.seed(1) > # caption <- "test level=.95, gam:gam(Ozone^(1/3)~lo(Solar.R)+lo(Wind, Temp),data=airquality)" > # dopar(3,2,caption) > # data(airquality) > # airquality <- na.omit(airquality) # plotmo doesn't know how to deal with NAs yet > # a <- gam(Ozone^(1/3) ~ lo(Solar.R) + lo(Wind, Temp), data = airquality) > # set.seed(2020) > # plotmo(a, do.par=FALSE, caption=caption, ylim=NA, col.response=3, level=.95) > # # termplot(a) #TODO this fails with R2.5: dim(data) <- dim: attempt to set an attribute on NULL > # detach("package:gam") > # par(org.par) > > # test factors by changing wind to a factor > > ozone2 <- ozone1 > ozone2[,"wind"] <- factor(ozone2[,"wind"], labels=c( + "wind0", "wind2", "wind3", "wind4", "wind5", "wind6", + "wind7", "wind8", "wind9", "wind10", "wind11")) > > # commented out because factors are not yet supported by plotmo.earth > # caption <- "test wind=factor, earth(O3 ~ ., data=ozone2)" > # a <- earth(doy ~ ., data=ozone2) > # set.seed(1) > # dopar(4,3,caption) > # set.seed(2020) > # plotmo(a, col.response="gray", level=.95, nrug=-1, do.par=FALSE, caption=caption) > # termplot(a) > # par(org.par) > > caption <- "test wind=factor, lm(doy ~ vh + wind + I(humidity*temp) + log(ibh), data=ozone2)" > a <- lm(doy ~ vh + wind + I(humidity*temp) + log(ibh), data=ozone2) > set.seed(1) > dopar(4,3,caption) test wind=factor, lm(doy ~ vh + wind + I(humidity*temp) + log(ibh), data=ozone2) > plotmo(a, col.response="gray", level=.95, nrug=-1, do.par=FALSE, caption=caption, smooth.col="indianred") plotmo grid: vh wind humidity temp ibh 5760 wind5 64 62 2112.5 > termplot(a, se=2) > par(org.par) > > caption <- "test level options" > dopar(2,2,caption) test level options > plotmo(a, do.par=FALSE, degree1=2, degree2=FALSE, level=.95, level.shade=0, caption=caption) plotmo grid: vh wind humidity temp ibh 5760 wind5 64 62 2112.5 > plotmo(a, do.par=FALSE, degree1=2, degree2=FALSE, level=.95, level.shade="orange") plotmo grid: vh wind humidity temp ibh 5760 wind5 64 62 2112.5 > plotmo(a, do.par=FALSE, degree1=2, degree2=FALSE, level=.95, level.shade2=0) plotmo grid: vh wind humidity temp ibh 5760 wind5 64 62 2112.5 > par(org.par) > > caption <- "test wind=factor, glm(y ~ i + j, family=poisson())" > y <- c(18,17,15,20,10,20,25,13,12) > i <- gl(3,1,9) > j <- gl(3,3) > a <- glm(y ~ i + j, family=poisson()) > set.seed(1) > dopar(2,2,caption) test wind=factor, glm(y ~ i + j, family=poisson()) > plotmo(a, do.par=F, level=.95, nrug=1, caption=caption) Warning: the level argument may not work correctly on glm objects built with weights Warning: the level argument may not work correctly on glm objects built with weights plotmo grid: i j 1 1 > termplot(a, se=1, rug=T) > par(org.par) > > if(length(grep("package:gam", search()))) + detach("package:gam") > caption <- "test wind=factor, gam(doy ~ vh + wind + s(humidity) + s(vh) + temp, data=ozone2)" > library(mgcv) > a <- gam(doy ~ vh + wind + s(humidity) + s(vh) + temp, data=ozone2) > plotmo(a, level=.95, caption=caption) plotmo grid: vh wind temp humidity 5760 wind5 62 64 > caption <- "test wind=factor, clip=TRUE, gam(doy ~ vh + wind + s(humidity) + s(vh) + temp, data=ozone2)" > plotmo(a, level=.95, caption=caption, clip=FALSE) plotmo grid: vh wind temp humidity 5760 wind5 62 64 > # termplot doesn't work here so code commented out > # dopar(3,3,caption) > # plotmo(a, do.par=FALSE) > # termplot(a) > par(org.par) > > # test lda and qda, and also col.response, pt.pch, and jitter > library(MASS) > etitanic2 <- etitanic > etitanic2$pclass <- as.numeric(etitanic$pclass) > etitanic2$sex <- as.numeric(etitanic$sex) > etitanic2$sibsp <- NULL > etitanic2$parch <- NULL > lda.model <- lda(survived ~ ., data=etitanic2) > set.seed(7) > plotmo(lda.model, caption="lda", clip=F, + col.response=as.numeric(etitanic2$survived)+2, type="posterior", nresponse=1, smooth.col="indianred", + all2=TRUE, type2="image") plotmo grid: pclass sex age 2 2 28 > set.seed(8) > plotmo(lda.model, caption="lda with no jitter", clip=F, + col.response=as.numeric(etitanic2$survived)+2, type="posterior", nresponse=1, + all2=TRUE, type2="image", jitter=0) plotmo grid: pclass sex age 2 2 28 > qda.model <- qda(survived ~ ., data=etitanic2) > set.seed(9) > plotmo(qda.model, caption="qda", clip=F, + col.response=as.numeric(etitanic2$survived)+2, type="post", nresponse=2, smooth.col="indianred", + all2=TRUE, type2="image", jitter.resp=.6, pch.resp=20) plotmo grid: pclass sex age 2 2 28 > > # test plotmo.y from the 2nd argument of the model function (non-formula interface) > lcush <- data.frame(Type=as.numeric(Cushings$Type), log(Cushings[,1:2]))[1:21,] > a <- qda(lcush[,2:3], lcush[,1]) > set.seed(2020) > plotmo(a, type="class", all2=TRUE, + caption= "plotmo.y from 2nd argument of call (qda)", + type2="contour", ngrid2=100, contour.nlevels=2, contour.drawlabels=FALSE, + col.response=as.numeric(lcush$Type)+1, + pt.pch=as.character(lcush$Type)) plotmo grid: Tetrahydrocortisone Pregnanetriol 2.04122 0.1823216 > par(org.par) > > # # example from MASS (works, but removed because unnecessary test) > # predplot <- function(object, main="", len = 100, ...) > # { > # plot(Cushings[,1], Cushings[,2], log="xy", type="n", > # xlab = "Tetrahydrocortisone", ylab = "Pregnanetriol", main = main) > # for(il in 1:4) { > # set <- Cushings$Type==levels(Cushings$Type)[il] > # text(Cushings[set, 1], Cushings[set, 2], > # labels=as.character(Cushings$Type[set]), col = 2 + il) } > # xp <- seq(0.6, 4.0, length=len) > # yp <- seq(-3.25, 2.45, length=len) > # cushT <- expand.grid(Tetrahydrocortisone = xp, > # Pregnanetriol = yp) > # Z <- predict(object, cushT, ...); zp <- as.numeric(Z$class) > # zp <- Z$post[,3] - pmax(Z$post[,2], Z$post[,1]) > # contour(exp(xp), exp(yp), matrix(zp, len), > # add = TRUE, levels = 0, labex = 0) > # zp <- Z$post[,1] - pmax(Z$post[,2], Z$post[,3]) > # contour(exp(xp), exp(yp), matrix(zp, len), > # add = TRUE, levels = 0, labex = 0) > # invisible() > # } > # par(mfrow=c(2,2)) > # cush <- log(as.matrix(Cushings[, -3])) > # tp <- Cushings$Type[1:21, drop = TRUE] > # set.seed(203) > # cush.data <- data.frame(tp, cush[1:21,]) > # a <- qda(tp~., data=cush.data) > # predplot(a, "QDA example from MASS") > # set.seed(2020) > # plotmo(a, type="class", all2=TRUE, type2="contour", degree1=NA, do.par=FALSE, > # col.response=as.numeric(cush.data$tp)+1) > # set.seed(2020) > # plotmo(a, type="class", all2=TRUE, type2="contour", degree1=NA, do.par=FALSE, > # col.response=as.numeric(cush.data$tp)+1, drawlabels=F, nlevels=2) > # set.seed(2020) > # plotmo(a, type="class", all2=TRUE, type2="contour", degree1=NA, do.par=FALSE, > # col.response=as.numeric(cush.data$tp)+1, drawlabels=F, nlevels=2, ngrid2=100) > # par(org.par) > > library(rpart) Attaching package: 'rpart' The following object is masked from 'package:faraway': solder > data(kyphosis) > # kyphosis data, earth model > a <- earth(Kyphosis ~ ., data=kyphosis, degree=2, glm=list(family=binomial)) > cat("summary(a): (Kyphosis)\n") summary(a): (Kyphosis) > print(summary(a)) Call: earth(formula=Kyphosis~., data=kyphosis, glm=list(family=binomial), degree=2) GLM coefficients present (Intercept) 12.4739052 h(97-Age) -0.1563678 h(6-Number) -3.8334755 h(Start-6) -0.3798750 h(Age-42) * h(Number-3) -0.0197570 h(114-Age) * h(Start-6) 0.0089521 h(Number-3) * h(Start-6) -0.3545004 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 83.2345 80 36.4652 74 0.562 50.47 8 1 Earth selected 7 of 19 terms, and 3 of 3 predictors Termination condition: Reached nk 21 Importance: Start, Age, Number Number of terms at each degree of interaction: 1 3 3 Earth GCV 0.1359306 RSS 7.090206 GRSq 0.2004084 RSq 0.4721446 > par(mfrow=c(3, 3)) > par(mar=c(3, 3, 2, .5)) # small margins to pack figs in > set.seed(9) # for jitter > set.seed(2020) > plotmo(a, do.par=F, type2="image", + col.response=ifelse(kyphosis$Kyphosis=="present", "red", "lightblue"), + clip=F) plotmo grid: Age Number Start 87 4 13 > plotmo(a, do.par=F, clip=F, degree1=0) > par(org.par) > > # kyphosis data, rpart models (also test ngrid2) > fit1 <- rpart(Kyphosis ~ ., data=kyphosis) > plotres(fit1, SHOWCALL=TRUE) > par(mfrow=c(3, 3)) > par(mar=c(.5, 0.5, 2, .5), mgp = c(1.6, 0.6, 0)) # b l t r small margins to pack figs in > library(rpart.plot) > prp(fit1, main="rpart kyphosis\nno prior") > plotmo(fit1, degree1=NA, do.par=F, main="", persp.theta=220, nresponse=2) > par(mar=c(4, 4, 2, .5)) > set.seed(2020) > plotmo(fit1, nresp=2, degree1=FALSE, do.par=F, main="", type2="image", # test default type="prob" + col.response=ifelse(kyphosis$Kyphosis=="present", "red", "lightblue"), + pt.pch=ifelse(kyphosis$Kyphosis=="present", "p", "a"), + image.col=gray(10:4/10), ngrid2=30) > par(mar=c(.5, 0.5, 2, .5)) # b l t r small margins to pack figs in > plotmo(fit1, type="class", degree1=NA, do.par=F, main="type=\"class\"") > # with type="prob" and response has two columns, > # nresponse should automatically default to column 2 > plotmo(fit1, type="prob", degree1=0, do.par=F, main="type=\"prob\"", + clip=F, ngrid2=50, persp.border=NA, trace=1) stats::predict(rpart.object, data.frame[3,3], type="prob") stats::fitted(object=rpart.object) fitted() was unsuccessful, will use predict() instead set nresponse=2 nresponse=2 but for plotmo_y using nresponse=1 because ncol(y) == 1 got model response from model.frame(Kyphosis ~ Age + Number + Start, data=call$data, na.action="na.pass") > set.seed(2020) > plotmo(fit1, type="prob", nresp=2, degree1=NA, do.par=F, main="", type2="image", + col.response=ifelse(kyphosis$Kyphosis=="present", "red", "lightblue"), + pt.pch=20, image.col=gray(10:4/10), ngrid2=5) > # better rpart model with prior > fit2 <- rpart(Kyphosis ~ ., data=kyphosis, parms=list(prior=c(.65,.35))) > prp(fit2, main="rpart kyphosis\nwith prior, better model") > plotmo(fit2, type="v", degree1=NA, do.par=F, main="", persp.theta=220, ngrid2=10) > par(mar=c(4, 4, 2, .5)) > set.seed(2020) > plotmo(fit2, type="v", degree1=NA, do.par=F, main="", type2="image", + col.response=ifelse(kyphosis$Kyphosis=="present", "red", "lightblue"), + pt.pch=20, image.col=gray(10:4/10), ngrid2=100) > par(org.par) > > plotmo(fit1, type="prob", nresponse=1, persp.border=NA, persp.col="pink", all1=TRUE, all2=TRUE, + caption="plotmo rpart fit1, all1=TRUE, all2=TRUE") plotmo grid: Age Number Start 87 4 13 > expect.err(try(plotmo(fit1, type="none.such1"))) Error : predict.rpart does not support type="none.such1" Got expected error from try(plotmo(fit1, type = "none.such1")) > > # rpart model with ozone data > data(ozone1) > par(mfrow=c(4,4)) > par(mar=c(.5, 0.5, 2, .5), cex=.6, mgp = c(1.6, 0.6, 0)) # b l t r small margins to pack figs in > a1 <- rpart(O3~temp+humidity, data=ozone1) > prp(a1, main="rpart model with ozone data\n(temp and humidity only)\n") > plotmo(a1, do.par=F, degree1=0, main="rpart", persp.ticktype="detail", persp.nticks=2) > expect.err(try(plotmo(a1, type="class"))) Error : predict.rpart does not support type="class" (for "anova" rpart objects) Got expected error from try(plotmo(a1, type = "class")) > # compare to a linear and earth model > a3 <- lm(O3~temp+humidity, data=ozone1) > plotmo(a3, do.par=F, clip=F, main="lm", degree1=0, all2=TRUE, persp.ticktype="detail", persp.nticks=2) > expect.err(try(plotmo(a3, type="none.such2"))) stats::predict(lm.object, NULL, type="none.such2") Error in match.arg(type) : 'arg' should be one of "response", "terms" Got expected error from try(plotmo(a3, type = "none.such2")) > a <- earth(O3~temp+humidity, data=ozone1, degree=2) > plotmo(a, do.par=F, clip=F, main="earth", degree1=NA, persp.ticktype="detail", persp.nticks=2) > expect.err(try(plotmo(a, type="none.such3"))) stats::predict(earth.object, NULL, type="none.such3") Error : type="none.such3" is not allowed Choose one of: "link" "response" "earth" "class" "terms" Got expected error from try(plotmo(a, type = "none.such3")) > expect.err(try(plotmo(a, type=c("abc", "def")))) Error : 'type' has more than one element type = c("abc" "def") Got expected error from try(plotmo(a, type = c("abc", "def"))) > par(org.par) > > # detailed rpart model > par(mfrow=c(3,3)) > a1 <- rpart(O3~., data=ozone1) > prp(a1, cex=.9, main="rpart model with full ozone data") > plotmo(a1, type="vector", do.par=F, degree1=NA, persp.ticktype="detail", + persp.nticks=3, degree2=2:3) > par(org.par) > > plotmo(a1, persp.border=NA, all1=TRUE, all2=TRUE, + caption="plotmo rpart a1, all1=TRUE, all2=TRUE") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > > library(tree) > tree1 <- tree(O3~., data=ozone1) > plotmo(tree1) plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > plotres(tree1) > > # rpart data with NAs > > rpart.airquality <- rpart(Ozone~., data=airquality) # airquality has NAs in response and variables > plotmo <- plotmo(rpart.airquality, trace=0, SHOWCALL=TRUE) plotmo grid: Solar.R Wind Temp Month Day 207 9.7 79 7 16 > print(rpart.rules(rpart.airquality)) Ozone 12 when Temp < 83 & Wind >= 7.2 & Solar.R < 80 21 when Temp < 78 & Wind >= 7.2 & Solar.R >= 80 35 when Temp is 78 to 83 & Wind >= 7.2 & Solar.R >= 80 49 when Temp >= 83 & Wind >= 10.6 61 when Temp < 83 & Wind < 7.2 75 when Temp is 83 to 89 & Wind < 10.6 93 when Temp >= 89 & Wind < 10.6 > > airquality.nonaOzone <- subset(airquality, !is.na(Ozone)) # no NAs in response but NAs in variables > rpart.nonaOzone <- rpart(Ozone~., data=airquality.nonaOzone) > print(rpart.rules(rpart.nonaOzone)) Ozone 12 when Temp < 83 & Wind >= 7.2 & Solar.R < 80 21 when Temp < 78 & Wind >= 7.2 & Solar.R >= 80 35 when Temp is 78 to 83 & Wind >= 7.2 & Solar.R >= 80 49 when Temp >= 83 & Wind >= 10.6 61 when Temp < 83 & Wind < 7.2 75 when Temp is 83 to 89 & Wind < 10.6 93 when Temp >= 89 & Wind < 10.6 > plotmo.nonaOzone <- plotmo(rpart.nonaOzone, trace=0, SHOWCALL=TRUE) plotmo grid: Solar.R Wind Temp Month Day 207 9.7 79 7 16 > airquality.nonaOzone$Ozone <- NULL > stopifnot(identical(plotmo.nonaOzone, airquality.nonaOzone)) > > # test xflip and yflip > > par(mfrow=c(4, 4)) > par(mgp = c(1.6, 0.6, 0)) > par(mar=c(4, 4, 2, .5)) > > flip.test1 <- rpart(Kyphosis ~ ., data=kyphosis) > set.seed(2020) > plotmo(flip.test1, type="prob", nresp=2, degree1=NA, do.par=F, main="", type2="image", + col.response=ifelse(kyphosis$Kyphosis=="present", "red", "lightblue"), + pt.pch=20, image.col=gray(10:4/10)) > set.seed(2020) > plotmo(flip.test1, type="prob", nresp=2, degree1=NA, do.par=F, main="xflip", type2="image", + col.response=ifelse(kyphosis$Kyphosis=="present", "red", "lightblue"), + pt.pch=20, image.col=gray(10:4/10), + xflip=T) > set.seed(2020) > plotmo(flip.test1, type="prob", nresp=2, degree1=NA, do.par=F, main="yflip", type2="image", + col.response=ifelse(kyphosis$Kyphosis=="present", "red", "lightblue"), + pt.pch=20, image.col=gray(10:4/10), + yflip=T) > set.seed(2020) > plotmo(flip.test1, type="prob", nresp=2, degree1=NA, do.par=F, main="xflip and yflip", type2="image", + col.response=ifelse(kyphosis$Kyphosis=="present", "red", "lightblue"), + pt.pch=20, image.col=gray(10:4/10), + xflip=T, yflip=T) > > flip.test2 <- earth(O3~., data=ozone1, degree=2) > plotmo(flip.test2, degree1=NA, degree2=2, do.par=F, main="", type2="cont") > plotmo(flip.test2, degree1=NA, degree2=2, do.par=F, main="xflip", type2="cont", + xflip=T) > plotmo(flip.test2, degree1=NA, degree2=2, do.par=F, main="yflip", type2="cont", + yflip=T) > plotmo(flip.test2, degree1=NA, degree2=2, do.par=F, main="xflip and yflip", type2="cont", + xflip=T, yflip=T) > > cat("Expect warnings: ignoring xflip=TRUE for persp plot\n") Expect warnings: ignoring xflip=TRUE for persp plot > plotmo(flip.test2, degree1=NA, degree2=2, do.par=F, main="xflip and yflip", type2="persp", + xflip=T, yflip=T) Warning: ignoring xflip=TRUE for persp plot Warning: ignoring yflip=TRUE for persp plot > > library(randomForest) randomForest 4.7-1.1 Type rfNews() to see new features/changes/bug fixes. > data(etitanic) > etit <- etitanic[1:300,] > > cat("=== rf.regression ===\n") === rf.regression === > set.seed(2016) > # Expect Warning: The response has five or fewer unique values. Are you sure you want to do regression? > rf.regression <- randomForest(survived~., data=etit, ntree=100, importance = FALSE) Warning in randomForest.default(m, y, ...) : The response has five or fewer unique values. Are you sure you want to do regression? > plotmo(rf.regression, trace=1) stats::predict(randomForest.formula.object, data.frame[3,5], type="response") stats::fitted(object=randomForest.formula.object) fitted() was unsuccessful, will use predict() instead got model response from model.frame(survived ~ pclass + sex + age + sibsp..., data=call$data, na.action="na.fail") randomForest built with importance=FALSE, ranking variables on IncNodePurity plotmo grid: pclass sex age sibsp parch 1st male 38 0 0 > > cat("=== rf.regression.importance ===\n") === rf.regression.importance === > set.seed(2016) > # Expect Warning: The response has five or fewer unique values. Are you sure you want to do regression? > rf.regression.importance <- randomForest(survived~., data=etit, ntree=100, importance = TRUE) Warning in randomForest.default(m, y, ...) : The response has five or fewer unique values. Are you sure you want to do regression? > plotmo(rf.regression.importance, trace=1) stats::predict(randomForest.formula.object, data.frame[3,5], type="response") stats::fitted(object=randomForest.formula.object) fitted() was unsuccessful, will use predict() instead got model response from model.frame(survived ~ pclass + sex + age + sibsp..., data=call$data, na.action="na.fail") randomForest built with importance=TRUE, ranking variables on %IncMSE plotmo grid: pclass sex age sibsp parch 1st male 38 0 0 > > etit <- etitanic[1:300,] > etit$survived <- factor(ifelse(etit$survived == 1, "survived", "died"), + levels = c("survived", "died")) > cat("=== rf.classification ===\n") === rf.classification === > set.seed(2016) > rf.classification <- randomForest(survived~., data=etit, ntree=100, importance = FALSE) > plotmo(rf.classification, trace=1, type="prob", nresponse="surv", SHOWCALL=TRUE) stats::predict(randomForest.formula.object, data.frame[3,5], type="prob") stats::fitted(object=randomForest.formula.object) fitted() was unsuccessful, will use predict() instead got model response from model.frame(survived ~ pclass + sex + age + sibsp..., data=call$data, na.action="na.fail") randomForest built with importance=FALSE, ranking variables on MeanDecreaseGini plotmo grid: pclass sex age sibsp parch 1st male 38 0 0 > plotmo(rf.classification, trace=1, type="prob", nresponse="died", degree2=0, SHOWCALL=TRUE) stats::predict(randomForest.formula.object, data.frame[3,5], type="prob") stats::fitted(object=randomForest.formula.object) fitted() was unsuccessful, will use predict() instead nresponse=2 but for plotmo_y using nresponse=1 because ncol(y) == 1 got model response from model.frame(survived ~ pclass + sex + age + sibsp..., data=call$data, na.action="na.fail") randomForest built with importance=FALSE, ranking variables on MeanDecreaseGini plotmo grid: pclass sex age sibsp parch 1st male 38 0 0 > > cat("=== rf.classification.importance ===\n") === rf.classification.importance === > set.seed(2016) > rf.classification.importance <- randomForest(survived~., data=etit, ntree=100, importance = TRUE) > plotmo(rf.classification.importance, trace=1, type="prob", nresponse="surv", SHOWCALL=TRUE) stats::predict(randomForest.formula.object, data.frame[3,5], type="prob") stats::fitted(object=randomForest.formula.object) fitted() was unsuccessful, will use predict() instead got model response from model.frame(survived ~ pclass + sex + age + sibsp..., data=call$data, na.action="na.fail") randomForest built with importance=TRUE, ranking variables on MeanDecreaseAccuracy plotmo grid: pclass sex age sibsp parch 1st male 38 0 0 > > cat("=== plotres randomForest ===\n") === plotres randomForest === > plotres(rf.regression) > plotres(rf.regression.importance) > # TODO residuals are in range 0 to 1 > plotres(rf.classification, type="prob", nresponse="surv") > plotres(rf.classification.importance, type="prob", nresponse="surv") > > #--- fda ------------------------------------------------------------------------------ > > par(org.par) > par(mfrow=c(4,5)) > par(mar = c(3, 2, 3, .1)) # b, l, t, r > par(mgp = c(1.5, .5, 0)) > fda.earth <- fda(Species~., data=iris, keep.fitted=TRUE, method=earth, keepxy=TRUE) > fda.polyreg <- fda(Species~., data=iris, keep.fitted=TRUE, keepxy=TRUE) > fda.bruto <- fda(Species~., data=iris, keep.fitted=TRUE, method=bruto) > > # 'fda.polyreg$fit' does not have a 'call' field or 'x' and 'y' fields > expect.err(try(plotmo(fda.polyreg$fit, type="variates", nresponse=1, clip=F, do.par=F))) Error : 'fda.polyreg$fit' does not have a 'call' field or 'x' and 'y' fields Got expected error from try(plotmo(fda.polyreg$fit, type = "variates", nresponse = 1, clip = F, do.par = F)) > > plot(1, main="plotmo with fda", xaxt="n", yaxt="n", xlab="", ylab="", + type="n", bty="n", cex.main=1.2, xpd=NA) > > plotmo(fda.earth, type="variates", nresponse=1, clip=F, do.par=F) plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 5.8 3 4.35 1.3 > > plot(1, main="plotmo with fda.earth$fit", xaxt="n", yaxt="n", xlab="", ylab="", + type="n", bty="n", cex.main=1.2, xpd=NA) > > plotmo(fda.earth$fit, nresponse=1, clip=F, do.par=F) plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 5.8 3 4.35 1.3 > > plot(1, main="", xaxt="n", yaxt="n", xlab="", ylab="", + type="n", bty="n", cex.main=1.5, xpd=NA) > > plot(fda.earth) > plotmo(fda.earth, clip=F, do.par=F) # default type is class plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 5.8 3 4.35 1.3 > > plot(fda.polyreg) > plotmo(fda.polyreg, type="variates", nresponse=1, clip=F, do.par=F, degree1=c(1,3,4)) plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 5.8 3 4.35 1.3 > plot(1, main="", xaxt="n", yaxt="n", xlab="", ylab="", + type="n", bty="n", cex.main=1.5, xpd=NA) > > par(mfrow=c(3,3)) > par(mar = c(3, 2, 3, .1)) # b, l, t, r > par(mgp = c(1.5, .5, 0)) > plot(fda.bruto) > plotmo(fda.bruto, type="variates", nresponse=1, do.par=F) plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 5.8 3 4.35 1.3 > par(org.par) > > # neural net package > # for speed we use artificial data because neuralnet is very slow on say trees > library(neuralnet) > n <- 20 > set.seed(3) > x1 <- runif(n, min=-1, max=1) > x2 <- runif(n, min=-1, max=1) # x2 is noise > y <- x1^2 > data <- data.frame(y=y, x1=x1, x2=x2) > colnames(data) <- c("y","x1", "x2") > set.seed(3) > nn <- neuralnet(y~x1+x2, data=data, hidden=3, rep=3) > print(head(plotmo:::predict.nn(nn, rep="best", trace=TRUE))) predict.nn: rep = "best" is rep = 2 [,1] [1,] 0.46903930 [2,] 0.36653551 [3,] 0.02542870 [4,] 0.10970959 [5,] 0.06457524 [6,] 0.04182985 > set.seed(2020) > plotmo(nn, trace=1, col.response=2, all2=TRUE, SHOWCALL=TRUE) stats::predict(nn.object, data.frame[3,2], trace=TRUE) predict.nn: rep = "mean" will take the mean of 3 reps stats::fitted(object=nn.object) fitted() was unsuccessful, will use predict() instead assuming "y" in the model.frame is the response, because terms(object) did not return the terms assuming "y" in the model.frame is the response, because terms(object) did not return the terms got model response from model.frame(y ~ x1 + x2, data=object$data, na.action="na.fail") plotmo grid: x1 x2 0.09128479 -0.2904531 > # trace=0 below to test hushing of message "assuming "y" in the model.frame is the response, because object$terms is NULL" > set.seed(2020) > plotmo(nn, trace=0, col.response=2, predict.rep="best", SHOWCALL=TRUE) plotmo grid: x1 x2 0.09128479 -0.2904531 > plotres(nn, trace=0, info=TRUE, SHOWCALL=TRUE) > plotres(nn, trace=1, info=TRUE, predict.rep="best", SHOWCALL=TRUE) stats::residuals(object=nn.object, type="response") residuals() was unsuccessful, will use predict() instead stats::predict(nn.object, data.frame[3,2], trace=TRUE, rep="best") predict.nn: rep = "best" is rep = 2 stats::fitted(object=nn.object) fitted() was unsuccessful, will use predict() instead assuming "y" in the model.frame is the response, because terms(object) did not return the terms assuming "y" in the model.frame is the response, because terms(object) did not return the terms got model response from model.frame(y ~ x1 + x2, data=object$data, na.action="na.fail") assuming "y" in the model.frame is the response, because terms(object) did not return the terms training rsq 0.99 > > library(nnet) Attaching package: 'nnet' The following object is masked from 'package:mgcv': multinom > data(iris3) > set.seed(301) > samp <- c(sample(1:50,25), sample(51:100,25), sample(101:150,25)) > ird <- data.frame(rbind(iris3[,,1], iris3[,,2], iris3[,,3]), + species=factor(c(rep("seto",50), rep("vers", 50), rep("virg", 50)))) > ir.nn2 <- nnet(species ~ ., data = ird, subset = samp, size = 2, rang = 0.1, + decay = 5e-4, maxit = 20) # weights: 19 initial value 82.506969 iter 10 value 21.754594 iter 20 value 8.896424 final value 8.896424 stopped after 20 iterations > plotmo(ir.nn2, nresponse=1, type="class", all2=T, degree2=2:6) plotmo grid: Sepal.L. Sepal.W. Petal.L. Petal.W. 5.8 3 4.4 1.3 > plotmo(ir.nn2, nresponse=2, clip=F, all2=T, degree2=1:5) plotmo grid: Sepal.L. Sepal.W. Petal.L. Petal.W. 5.8 3 4.4 1.3 > plotres(ir.nn2, nresponse=2) > > library(biglm) Loading required package: DBI > data(trees) > ff <- log(Volume)~log(Girth)+log(Height) > chunk1 <- trees[1:20,] > chunk2 <- trees[20:31,] > biglm <- biglm(ff,chunk1) > biglm <- update(biglm, chunk2) > plotmo(biglm, pt.col=2, SHOWCALL=TRUE) plotmo grid: Girth Height 11.25 75 > plotres(biglm, SHOWCALL=TRUE) Warning: plotting 20 cases but the model was built with 32 cases > > library(adabag) Loading required package: caret Loading required package: ggplot2 Attaching package: 'ggplot2' The following object is masked from 'package:randomForest': margin Loading required package: lattice Attaching package: 'lattice' The following object is masked from 'package:faraway': melanoma Loading required package: doParallel Loading required package: iterators Loading required package: parallel > data(iris) > set.seed(2015) > # mfinal=3 for speed during testing > mod.boosting <- boosting(Species~., data=iris, mfinal=3) > mod.bagging <- bagging(Species~., data=iris, mfinal=3) > dopar(4, 4, caption="adabag package") adabag package > plotmo(mod.boosting, nresponse=1, ylim=c(0,1), do.par=FALSE) # default type="prob" plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 5.8 3 4.35 1.3 > plotmo(mod.boosting, type="class", do.par=FALSE) plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 5.8 3 4.35 1.3 > plotmo(mod.bagging, nresponse=1, ylim=c(0,1), do.par=FALSE) plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 5.8 3 4.35 1.3 > plotmo(mod.bagging, nresponse=1, type="votes", do.par=FALSE) plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 5.8 3 4.35 1.3 > par(org.par) > > library(e1071) > data(iris) > x.iris <- subset(iris, select=-Species) > y.iris <- iris$Species > set.seed(2016) > svm.xy <- svm(x.iris, y.iris, probability=FALSE) > par(mfrow = c(3, 3), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) > expect.err(try(plotmo(svm.xy, prob=TRUE, nresponse="vers", do.par=TRUE, all2=TRUE))) # probability=FALSE in call to svm stats::predict(svm.object, data.frame[3,4], prob=TRUE) Error in predict.svm(structure(list(call = svm.default(x = x.iris, y = y.iris, : (converted from warning) SVM has not been trained using `probability = TRUE`, probabilities not available for predictions. Got expected error from try(plotmo(svm.xy, prob = TRUE, nresponse = "vers", do.par = TRUE, all2 = TRUE)) > plotmo(svm.xy, decision=TRUE, + nresponse="vers", do.par=FALSE, all2=TRUE, degree1=2:3, degree2=6) plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 5.8 3 4.35 1.3 > svm.xy <- svm(x.iris, y.iris, probability=TRUE) > plotmo(svm.xy, prob=TRUE, + nresponse="vers", do.par=FALSE, all2=TRUE, degree1=2:3, degree2=6) plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 5.8 3 4.35 1.3 > set.seed(2016) > svm.form <- svm(Species ~ ., data=iris, probability=T) > plotmo(svm.form, predict.p=TRUE, + nresponse="vers", do.par=FALSE, all2=TRUE, degree1=2:3, degree2=6) plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 5.8 3 4.35 1.3 > expect.err(try(plotmo(svm.form, decision.values=TRUE, probab=TRUE))) # not both Error : predict.svm: specify either 'decision.values' or 'probability' (not both) Got expected error from try(plotmo(svm.form, decision.values = TRUE, probab = TRUE)) > plotres(svm.form, predict.prob=TRUE, nresponse="vers", info=TRUE) Cannot get training rsq (nresponse is 2 but the number of columns is only 1) > plotres(svm.form, jitter=5, info=TRUE) > par(org.par) > > source("test.epilog.R") plotmo/inst/slowtests/test.caret.R0000644000176200001440000001041513737416673017031 0ustar liggesusers# test.caret.R: test plotmo on caret models # # TODO This is a minimal set of tests. source("test.prolog.R") library(plotmo) library(earth) library(caret) data(ozone1) data(etitanic) dopar <- function(nrows, ncols, caption = "") { cat(" ", caption, "\n") par(mfrow=c(nrows, ncols)) par(oma = c(0, 0, 3, 0)) par(mar = c(3, 3, 1.7, 0.5)) par(mgp = c(1.6, 0.6, 0)) par(cex = 0.7) } set.seed(2010) caret.earth.mod <- train(O3~., data=ozone1, method="earth", tuneGrid=data.frame(degree=2, nprune=10)) # SHOWCALL is just a testing thing, so we can see who created the plot on the plot itself plotmo(caret.earth.mod, trace=1, SHOWCALL=TRUE) plotmo(caret.earth.mod$finalModel, trace=1, SHOWCALL=TRUE) plotres(caret.earth.mod, trace=1, SHOWCALL=TRUE) # plotres(caret.earth.mod$finalModel, trace=1, SHOWCALL=TRUE) set.seed(2015) bag <- bagEarth(O3~., data=ozone1, degree=2, B=3) print(bag$fit) # pairs are plotted correctly (I think) plotmo(bag, type="response", trace=1, SHOWCALL=TRUE) plotres(bag, type="response", trace=1, SHOWCALL=TRUE) set.seed(2015) a.bag1 <- bagEarth(trees[,-3], trees[,3], degree=2, B = 3) plotmo(a.bag1, trace=1, SHOWCALL=TRUE, all2=TRUE, caption="bagEarth, trees") plotres(a.bag1, trace=1, SHOWCALL=TRUE) # trace=1 to display "Fixed rank deficient bx by removing 1 term" messages set.seed(2015) a.bag3 <- bagEarth(survived~., data=etitanic, degree=2, B=3, trace=1) plotmo(a.bag3, clip=F, caption="bagEarth, etitanic", trace=1, SHOWCALL=TRUE) plotres(a.bag3, clip=F, trace=1, SHOWCALL=TRUE) # following based on example by Max Kuhn on stackoverflow etit <- etitanic etit$survived <- factor(ifelse(etit$survived == 1, "yes", "no"), levels = c("yes", "no")) set.seed(2015) caret.earth.mod2 <- train(survived ~ ., data = etit, method = "earth", tuneGrid = data.frame(degree = 2, nprune = 9), trControl = trainControl(method = "none", classProbs = TRUE)) # Following gives expected warning (because factors in caret-earth model) # Warning: Cannot determine which variables to plot (use all1=TRUE?) plotmo(caret.earth.mod2, trace=1, SHOWCALL=TRUE) # changed Sep 2020: following with all2=2 generates the same plot as above (because with warning, above defaults to all2=TRUE) plotmo(caret.earth.mod2, trace=1, all2=TRUE, SHOWCALL=TRUE, caption="caret.earth.mod2: all2=2") plotres(caret.earth.mod2, trace=1, SHOWCALL=TRUE) # Sep 2020: test with a logical variable (check that get.earth.vars.for.plotmo strips "sexTRUE" to "sex") # following should be exactly the same model as caret.earth.mod2 except for the variable naming for sex etit.bool <- etitanic etit.bool$survived <- factor(ifelse(etit.bool$survived == 1, "yes", "no"), levels = c("yes", "no")) etit.bool$sex <- etit.bool$sex == "male" # to bool set.seed(2015) # same random seed as above (may not be necessary) caret.earth.boolfac <- train(survived ~ ., data = etit.bool, method = "earth", tuneGrid = data.frame(degree = 2, nprune = 9), trControl = trainControl(method = "none", classProbs = TRUE)) print(summary(caret.earth.boolfac)) plotmo(caret.earth.boolfac, trace=0, SHOWCALL=TRUE) # Warning: Cannot determine which variables to plot (use all1=TRUE?) # changed Sep 2020: following with all1=TRUE, all2=TRUE generates the same plot as above plotmo(caret.earth.boolfac, trace=0, all1=TRUE, all2=TRUE, SHOWCALL=TRUE, caption="caret.earth.mod2: all1=T, all2=T") data(ozone1) set.seed(2020) a <- train(O3 ~ ., data = ozone1, method = "earth", tuneGrid = data.frame(degree = 2, nprune = 14)) plotmo(a, trace=1, SHOWCALL=TRUE) plotres(a, trace=1, SHOWCALL=TRUE) cat("=== method=\"svmRadial\" (S4 model wrapped in an S3 model) ===\n") data(trees) set.seed(2019) library(kernlab) mod <- train(Girth~., data=trees, method="svmRadial", trControl=trainControl(method="cv", number=2), tuneLength=2, preProcess = c("center", "scale")) plotres(mod, info=TRUE) set.seed(2020) plotmo(mod, pt.col=2, all2=TRUE, pmethod="partdep") source("test.epilog.R") plotmo/inst/slowtests/test.non.earth.R0000644000176200001440000007155313740162254017624 0ustar liggesusers# test.non.earth.R: test plotmo on non-earth models # Stephen Milborrow, Basley KwaZulu-Natal Mar 2011 source("test.prolog.R") library(plotmo) library(earth) data(ozone1) data(etitanic) dopar <- function(nrows, ncols, caption = "") { cat(" ", caption, "\n") par(mfrow=c(nrows, ncols)) par(oma = c(0, 0, 3, 0)) par(mar = c(3, 3, 1.7, 0.5)) par(mgp = c(1.6, 0.6, 0)) par(cex = 0.7) } caption <- "test lm(log(doy) ~ vh+wind+humidity+temp+log(ibh), data=ozone1)" dopar(4,5,caption) a <- lm(log(doy) ~ vh + wind + humidity + temp + log(ibh), data=ozone1) set.seed(2020) plotmo(a, do.par=FALSE, caption=caption, ylim=NA, col.response=3, pt.pch=20, smooth.col="indianred", trace=2) termplot(a) par(org.par) caption <- "test lm(log(doy) ~ vh+wind+humidity+I(wind*humidity)+temp+log(ibh), data=ozone1)" dopar(4,5,caption) a <- lm(log(doy) ~ vh + wind + humidity + temp + log(ibh), data=ozone1) set.seed(2020) plotmo(a, do.par=FALSE, caption=caption, ylim=NA, col.resp=3, pt.pch=20, clip=FALSE, smooth.col="indianred") termplot(a) par(org.par) caption <- "test lm(doy ~ (vh+wind+humidity)^2, data=ozone1)" dopar(4,3,caption) a <- lm(doy ~ (vh+wind+humidity)^2, data=ozone1) plotmo(a, do.par=FALSE, caption=caption, ylim=NULL) # termplot(a) # termplot fails with Error in `[.data.frame`(mf, , i): undefined columns selected par(org.par) caption <- "test lm(doy^2 ~ vh+wind+humidity+I(wind*humidity)+temp+log(ibh), data=ozone1)" dopar(4,3,caption) a <- lm(doy^2 ~ vh+wind+humidity+I(wind*humidity)+temp+log(ibh), data=ozone1) plotmo(a, do.par=FALSE, caption=caption, ylim=NULL) termplot(a) # termplot draws a funky second wind plot par(org.par) caption <- "test lm with data=ozone versus attach(ozone)" dopar(4,3,caption) a <- lm(log(doy) ~ I(vh*wind) + wind + I(humidity*temp) + log(ibh), data=ozone1) plotmo(a, do.par=FALSE, caption=caption, degree1=c(1,2,4,5)) attach(ozone1) a <- lm(log(doy) ~ I(vh*wind) + wind + I(humidity*temp) + log(ibh)) plotmo(a, do.par=FALSE, degree1=c(1,2,4,5)) detach(ozone1) par(org.par) # commented out because "$" in names is not yet supported # a <- lm(log(ozone1$doy) ~ I(ozone1$vh*ozone1$wind) + log(ozone1$ibh)) # plotmo(a) set.seed(1) caption <- "test lm and glm a900..a902: damage~temp family=binomial data=orings" dopar(2,3,caption) library(faraway) data(orings) a900 <- lm(I(damage/6) ~ temp, data=orings) plotmo(a900, do.par=FALSE, caption=caption, col.response=2, nrug=-1, main="lm(damage/6~temp)", smooth.col="indianred", trace=0) response <- cbind(orings$damage, 6-orings$damage) a901 <- glm(response ~ temp, family="binomial", data=orings) set.seed(2020) plotmo(a901, do.par=FALSE, col.response=2, nrug=-1, main="glm(response~temp)", smooth.col="indianred", trace=2) a902 <- glm(cbind(damage, 6-damage)~temp, family="binomial", data=orings) set.seed(2020) plotmo(a902, do.par=FALSE, col.response=2, nrug=TRUE, main="glm(cbind(damage,6-damage)~temp)", trace=0) termplot(a902, main="termplot") plotmo(a902, type="link", main="type=\"link\"", do.par=F) set.seed(2020) plotmo(a902, type="response", main="type=\"response\"", col.response=2, do.par=F) par(org.par) set.seed(1) caption <- "test glm(lot2~log(u),data=clotting,family=Gamma)" dopar(2,2,caption) u = c(5,10,15,20,30,40,60,80,100) lota = c(118,58,42,35,27,25,21,19,18) clotting <- data.frame(u = u, lota = lota) a <- glm(lota ~ log(u), data=clotting, family=Gamma) set.seed(2020) plotmo(a, do.par=FALSE, caption=caption, col.response=3, clip=FALSE, nrug=-1) termplot(a) plotmo(a, type="link", caption=paste("type=\"link\"", caption)) par(org.par) if(length(grep("package:gam", search()))) detach("package:gam") library(mgcv) set.seed(1) caption <- "test plot.gam, with mgcv::gam(y ~ s(x) + s(x,z)) with response and func (and extra image plot)" dopar(3,2,caption) par(mar = c(3, 5, 1.7, 0.5)) # more space for left and bottom axis test1 <- function(x,sx=0.3,sz=0.4) (pi**sx*sz)*(1.2*exp(-(x[,1]-0.2)^2/sx^2-(x[,2]-0.3)^2/sz^2)+ 0.8*exp(-(x[,1]-0.7)^2/sx^2-(x[,2]-0.8)^2/sz^2)) n <- 100 set.seed(1) x <- runif(n); z1 <- runif(n); y <- test1(cbind(x,z1)) + rnorm(n) * 0.1 a <- gam(y ~ s(x) + s(x,z1)) set.seed(2020) plotmo(a, do.par=FALSE, type2="contour", caption=caption, col.response=3, smooth.col="indianred", func=test1, func.col="indianred", func.lwd=5, func.lty=2, smooth.lwd=3) plotmo(a, do.par=FALSE, degree1=F, degree2=1, type2="image", ylim=NA) plot(a, select=1) plot(a, select=2) plot(a, select=3) n<-400 sig<-2 set.seed(1) x0 <- runif(n, 0, 1) x1 <- runif(n, 0, 1) x2 <- runif(n, 0, 1) x3 <- runif(n, 0, 1) f0 <- function(x) 2 * sin(pi * x) f1 <- function(x) exp(2 * x) f2 <- function(x) 0.2*x^11*(10*(1-x))^6+10*(10*x)^3*(1-x)^10 f <- f0(x0) + f1(x1) + f2(x2) e <- rnorm(n, 0, sig) y <- f + e test.func <- function(x) f0(x[,1]) + f1(x[,2]) + f2(x[,3]) library(mgcv) caption <- "test mgcv::gam(y~s(x0,x1,k=12)+s(x2)+s(x3,k=20,fx=20)) (and extra persp plot)" dopar(3,3,caption) a <- gam(y~s(x0,x1,k=12)+s(x2)+s(x3,k=20,fx=20)) plot(a, select=2) plot(a, select=3) plot(a, select=1) plotmo(a, do.par=FALSE, type2="contour", caption=caption, xlab=NULL, main="", func=test.func, ngrid2=10, contour.drawlabels=FALSE) plotmo(a, do.par=FALSE, degree1=F, degree2=1, persp.the=-35) par(org.par) set.seed(1) caption <- "test plot.gam, with mgcv::gam(doy~s(wind)+s(humidity,wind)+s(vh)+temp,data=ozone1)" dopar(3,3,caption) a <- gam(doy ~ s(wind) + s(humidity,wind) + s(vh) + temp, data=ozone1) plotmo(a, do.par=FALSE, caption=caption, type2="contour", degree1=c("wind","vh"), swapxy=T, xlab=NULL, main="", clip=FALSE) plot(a, select=1) plot(a, select=3) plot(a, select=2) plot(a, select=4) par(org.par) detach("package:mgcv") library(gam) caption <- "test gam:gam(Ozone^(1/3)~lo(Solar.R)+lo(Wind, Temp),data=airquality)" set.seed(1) dopar(3,2,caption) data(airquality) airquality <- na.omit(airquality) # plotmo doesn't know how to deal with NAs yet a <- gam(Ozone^(1/3) ~ lo(Solar.R) + lo(Wind, Temp), data = airquality) set.seed(2020) plotmo(a, do.par=FALSE, caption=caption, ylim=NA, col.response=3) # termplot gives fishy looking wind plot, plotmo looks ok # termplot(a) #TODO this fails with R2.5: dim(data) <- dim: attempt to set an attribute on NULL detach("package:gam") par(org.par) library(mda) caption <- "test mars and earth (expect not a close match)" dopar(6,3,caption) a <- mars( ozone1[, -1], ozone1[,1], degree=2) b <- earth(ozone1[, -1], ozone1[,1], degree=2) # this also tests trace=2 on a non formula model plotmo(a, do.par=FALSE, caption=caption, trace=2) plotmo(b, do.par=FALSE) par(org.par) caption <- "test mars and mars.to.earth(mars) (expect no degree2 for mars)" dopar(6,3,caption) a <- mars(ozone1[, -1], ozone1[,1], degree=2) b <- mars.to.earth(a) plotmo(a, do.par=FALSE, caption=caption, ylim=NA) plotmo(b, do.par=FALSE, ylim=NA) par(org.par) # check fix for bug reported by Martin Maechler: # form <- Volume ~ .; a <- earth(form, data = trees); plotmo(a) fails dopar(4,4, "test f <- O3 ~ .; a <- earth(f, data=ozone1)") fa <- log(O3) ~ . a <- earth(fa, data=ozone1, degree=2) print(summary(a)) plot(a, do.par=FALSE) set.seed(2020) plotmo(a, do.par=FALSE, degree1=2:3, degree2=c(1,2), col.response = "pink", smooth.col="indianred") a <- lm(log(doy) ~ I(vh*wind) + I(humidity*temp) + log(ibh), data=ozone1) plotmo(a, do.par=FALSE, degree1=1:2) fa <- log(doy) ~ I(vh*wind) + I(humidity*temp) + log(ibh) a <- lm(fa, data=ozone1) plotmo(a, do.par=FALSE, degree1=1:2) par(org.par) # test inverse.func and func caption <- "test inverse.func=exp" a <- lm(log(Volume) ~ Girth + Height + I(Girth*Height), data=trees) my.func <- function(x) -60 + 5 * x[,1] + x[,2] / 3 set.seed(2020) plotmo(a, caption=caption, inverse.func = exp, col.response = "pink", func=my.func, func.col="gray", ngrid1=1000, type2="p", smooth.col="indianred") par(org.par) # se testing caption = "level=.95, lm(doy~., data=ozone1) versus termplot" dopar(6,3,caption) a <- lm(doy~., data=ozone1) plotmo(a, level=.95, do.par=FALSE, caption=caption) termplot(a, se=2) par(org.par) caption <- "test different se options, level=.95, lm(log(doy)~vh+wind+log(humidity),data=ozone1)" dopar(4,3,caption) a <- lm(log(doy) ~ vh + wind + log(humidity), data=ozone1) plotmo(a, do.par=FALSE, caption=caption, ylim=NA, level=.95) plotmo(a, do.par=FALSE, caption=caption, ylim=NA, level=.95, level.shade="pink", level.shade2=3) plotmo(a, do.par=FALSE, caption=caption, ylim=NA, level=.95, level.shade=3) plotmo(a, do.par=FALSE, caption=caption, ylim=NULL, level=.95, level.shade=3) par(org.par) caption <- "test level=.95, lm(log(doy)~vh+wind+log(humidity),data=ozone1)" dopar(2,3,caption) a <- lm(log(doy) ~ vh + wind + log(humidity), data=ozone1) plotmo(a, do.par=FALSE, caption=caption, ylim=NA, level=.95) termplot(a, se=2) par(org.par) caption <- "test level=.95 and inverse.func, lm(log(doy)~vh+wind+log(humidity),data=ozone1)" dopar(3,3,caption) a <- lm(log(doy) ~ vh + wind + log(humidity), data=ozone1) plotmo(a, do.par=FALSE, caption=caption, ylim=NA, level=.95) plotmo(a, do.par=FALSE, caption=caption, ylim=NULL, level=.95, inverse.func=exp) termplot(a, se=2) par(org.par) caption <- "test level=.95, glm(lot2~log(u),data=clotting,family=Gamma)" set.seed(1) dopar(2,2,caption) u = c(5,10,15,20,30,40,60,80,100) lota = c(118,58,42,35,27,25,21,19,18) clotting <- data.frame(u = u, lota = lota) a <- glm(lota ~ log(u), data=clotting, family=Gamma) set.seed(2020) plotmo(a, do.par=FALSE, caption=caption, col.response=4, pt.pch=7, clip=FALSE, nrug=-1, level=.95, smooth.col="indianred") termplot(a, se=2) par(org.par) if(length(grep("package:gam", search()))) detach("package:gam") library(mgcv) set.seed(1) caption <- "test level=.95, plot.gam, with mgcv::gam(y ~ s(x) + s(x,z1)) with response and func (and extra image plot)" dopar(3,2,caption) par(mar = c(3, 5, 1.7, 0.5)) # more space for left and bottom axis test1 <- function(x,sx=0.3,sz=0.4) (pi**sx*sz)*(1.2*exp(-(x[,1]-0.2)^2/sx^2-(x[,2]-0.3)^2/sz^2)+ 0.8*exp(-(x[,1]-0.7)^2/sx^2-(x[,2]-0.8)^2/sz^2)) n <- 100 set.seed(1) x <- runif(n); z1 <- runif(n); y <- test1(cbind(x,z1)) + rnorm(n) * 0.1 a <- gam(y ~ s(x) + s(x,z1)) set.seed(2020) plotmo(a, do.par=FALSE, type2="contour", caption=caption, col.response=3, func=test1, func.col="magenta", level=.95) plotmo(a, do.par=FALSE, degree1=F, degree2=1, type2="image", image.col=topo.colors(10), ylim=NA, level=.95, main="topo.colors") plot(a, select=1) plot(a, select=2) plot(a, select=3) par(org.par) # TODO Following commented out because it causes: # Error: gam objects in the "gam" package do not support confidence intervals on new data # detach("package:mgcv") # library(gam) # set.seed(1) # caption <- "test level=.95, gam:gam(Ozone^(1/3)~lo(Solar.R)+lo(Wind, Temp),data=airquality)" # dopar(3,2,caption) # data(airquality) # airquality <- na.omit(airquality) # plotmo doesn't know how to deal with NAs yet # a <- gam(Ozone^(1/3) ~ lo(Solar.R) + lo(Wind, Temp), data = airquality) # set.seed(2020) # plotmo(a, do.par=FALSE, caption=caption, ylim=NA, col.response=3, level=.95) # # termplot(a) #TODO this fails with R2.5: dim(data) <- dim: attempt to set an attribute on NULL # detach("package:gam") # par(org.par) # test factors by changing wind to a factor ozone2 <- ozone1 ozone2[,"wind"] <- factor(ozone2[,"wind"], labels=c( "wind0", "wind2", "wind3", "wind4", "wind5", "wind6", "wind7", "wind8", "wind9", "wind10", "wind11")) # commented out because factors are not yet supported by plotmo.earth # caption <- "test wind=factor, earth(O3 ~ ., data=ozone2)" # a <- earth(doy ~ ., data=ozone2) # set.seed(1) # dopar(4,3,caption) # set.seed(2020) # plotmo(a, col.response="gray", level=.95, nrug=-1, do.par=FALSE, caption=caption) # termplot(a) # par(org.par) caption <- "test wind=factor, lm(doy ~ vh + wind + I(humidity*temp) + log(ibh), data=ozone2)" a <- lm(doy ~ vh + wind + I(humidity*temp) + log(ibh), data=ozone2) set.seed(1) dopar(4,3,caption) plotmo(a, col.response="gray", level=.95, nrug=-1, do.par=FALSE, caption=caption, smooth.col="indianred") termplot(a, se=2) par(org.par) caption <- "test level options" dopar(2,2,caption) plotmo(a, do.par=FALSE, degree1=2, degree2=FALSE, level=.95, level.shade=0, caption=caption) plotmo(a, do.par=FALSE, degree1=2, degree2=FALSE, level=.95, level.shade="orange") plotmo(a, do.par=FALSE, degree1=2, degree2=FALSE, level=.95, level.shade2=0) par(org.par) caption <- "test wind=factor, glm(y ~ i + j, family=poisson())" y <- c(18,17,15,20,10,20,25,13,12) i <- gl(3,1,9) j <- gl(3,3) a <- glm(y ~ i + j, family=poisson()) set.seed(1) dopar(2,2,caption) plotmo(a, do.par=F, level=.95, nrug=1, caption=caption) termplot(a, se=1, rug=T) par(org.par) if(length(grep("package:gam", search()))) detach("package:gam") caption <- "test wind=factor, gam(doy ~ vh + wind + s(humidity) + s(vh) + temp, data=ozone2)" library(mgcv) a <- gam(doy ~ vh + wind + s(humidity) + s(vh) + temp, data=ozone2) plotmo(a, level=.95, caption=caption) caption <- "test wind=factor, clip=TRUE, gam(doy ~ vh + wind + s(humidity) + s(vh) + temp, data=ozone2)" plotmo(a, level=.95, caption=caption, clip=FALSE) # termplot doesn't work here so code commented out # dopar(3,3,caption) # plotmo(a, do.par=FALSE) # termplot(a) par(org.par) # test lda and qda, and also col.response, pt.pch, and jitter library(MASS) etitanic2 <- etitanic etitanic2$pclass <- as.numeric(etitanic$pclass) etitanic2$sex <- as.numeric(etitanic$sex) etitanic2$sibsp <- NULL etitanic2$parch <- NULL lda.model <- lda(survived ~ ., data=etitanic2) set.seed(7) plotmo(lda.model, caption="lda", clip=F, col.response=as.numeric(etitanic2$survived)+2, type="posterior", nresponse=1, smooth.col="indianred", all2=TRUE, type2="image") set.seed(8) plotmo(lda.model, caption="lda with no jitter", clip=F, col.response=as.numeric(etitanic2$survived)+2, type="posterior", nresponse=1, all2=TRUE, type2="image", jitter=0) qda.model <- qda(survived ~ ., data=etitanic2) set.seed(9) plotmo(qda.model, caption="qda", clip=F, col.response=as.numeric(etitanic2$survived)+2, type="post", nresponse=2, smooth.col="indianred", all2=TRUE, type2="image", jitter.resp=.6, pch.resp=20) # test plotmo.y from the 2nd argument of the model function (non-formula interface) lcush <- data.frame(Type=as.numeric(Cushings$Type), log(Cushings[,1:2]))[1:21,] a <- qda(lcush[,2:3], lcush[,1]) set.seed(2020) plotmo(a, type="class", all2=TRUE, caption= "plotmo.y from 2nd argument of call (qda)", type2="contour", ngrid2=100, contour.nlevels=2, contour.drawlabels=FALSE, col.response=as.numeric(lcush$Type)+1, pt.pch=as.character(lcush$Type)) par(org.par) # # example from MASS (works, but removed because unnecessary test) # predplot <- function(object, main="", len = 100, ...) # { # plot(Cushings[,1], Cushings[,2], log="xy", type="n", # xlab = "Tetrahydrocortisone", ylab = "Pregnanetriol", main = main) # for(il in 1:4) { # set <- Cushings$Type==levels(Cushings$Type)[il] # text(Cushings[set, 1], Cushings[set, 2], # labels=as.character(Cushings$Type[set]), col = 2 + il) } # xp <- seq(0.6, 4.0, length=len) # yp <- seq(-3.25, 2.45, length=len) # cushT <- expand.grid(Tetrahydrocortisone = xp, # Pregnanetriol = yp) # Z <- predict(object, cushT, ...); zp <- as.numeric(Z$class) # zp <- Z$post[,3] - pmax(Z$post[,2], Z$post[,1]) # contour(exp(xp), exp(yp), matrix(zp, len), # add = TRUE, levels = 0, labex = 0) # zp <- Z$post[,1] - pmax(Z$post[,2], Z$post[,3]) # contour(exp(xp), exp(yp), matrix(zp, len), # add = TRUE, levels = 0, labex = 0) # invisible() # } # par(mfrow=c(2,2)) # cush <- log(as.matrix(Cushings[, -3])) # tp <- Cushings$Type[1:21, drop = TRUE] # set.seed(203) # cush.data <- data.frame(tp, cush[1:21,]) # a <- qda(tp~., data=cush.data) # predplot(a, "QDA example from MASS") # set.seed(2020) # plotmo(a, type="class", all2=TRUE, type2="contour", degree1=NA, do.par=FALSE, # col.response=as.numeric(cush.data$tp)+1) # set.seed(2020) # plotmo(a, type="class", all2=TRUE, type2="contour", degree1=NA, do.par=FALSE, # col.response=as.numeric(cush.data$tp)+1, drawlabels=F, nlevels=2) # set.seed(2020) # plotmo(a, type="class", all2=TRUE, type2="contour", degree1=NA, do.par=FALSE, # col.response=as.numeric(cush.data$tp)+1, drawlabels=F, nlevels=2, ngrid2=100) # par(org.par) library(rpart) data(kyphosis) # kyphosis data, earth model a <- earth(Kyphosis ~ ., data=kyphosis, degree=2, glm=list(family=binomial)) cat("summary(a): (Kyphosis)\n") print(summary(a)) par(mfrow=c(3, 3)) par(mar=c(3, 3, 2, .5)) # small margins to pack figs in set.seed(9) # for jitter set.seed(2020) plotmo(a, do.par=F, type2="image", col.response=ifelse(kyphosis$Kyphosis=="present", "red", "lightblue"), clip=F) plotmo(a, do.par=F, clip=F, degree1=0) par(org.par) # kyphosis data, rpart models (also test ngrid2) fit1 <- rpart(Kyphosis ~ ., data=kyphosis) plotres(fit1, SHOWCALL=TRUE) par(mfrow=c(3, 3)) par(mar=c(.5, 0.5, 2, .5), mgp = c(1.6, 0.6, 0)) # b l t r small margins to pack figs in library(rpart.plot) prp(fit1, main="rpart kyphosis\nno prior") plotmo(fit1, degree1=NA, do.par=F, main="", persp.theta=220, nresponse=2) par(mar=c(4, 4, 2, .5)) set.seed(2020) plotmo(fit1, nresp=2, degree1=FALSE, do.par=F, main="", type2="image", # test default type="prob" col.response=ifelse(kyphosis$Kyphosis=="present", "red", "lightblue"), pt.pch=ifelse(kyphosis$Kyphosis=="present", "p", "a"), image.col=gray(10:4/10), ngrid2=30) par(mar=c(.5, 0.5, 2, .5)) # b l t r small margins to pack figs in plotmo(fit1, type="class", degree1=NA, do.par=F, main="type=\"class\"") # with type="prob" and response has two columns, # nresponse should automatically default to column 2 plotmo(fit1, type="prob", degree1=0, do.par=F, main="type=\"prob\"", clip=F, ngrid2=50, persp.border=NA, trace=1) set.seed(2020) plotmo(fit1, type="prob", nresp=2, degree1=NA, do.par=F, main="", type2="image", col.response=ifelse(kyphosis$Kyphosis=="present", "red", "lightblue"), pt.pch=20, image.col=gray(10:4/10), ngrid2=5) # better rpart model with prior fit2 <- rpart(Kyphosis ~ ., data=kyphosis, parms=list(prior=c(.65,.35))) prp(fit2, main="rpart kyphosis\nwith prior, better model") plotmo(fit2, type="v", degree1=NA, do.par=F, main="", persp.theta=220, ngrid2=10) par(mar=c(4, 4, 2, .5)) set.seed(2020) plotmo(fit2, type="v", degree1=NA, do.par=F, main="", type2="image", col.response=ifelse(kyphosis$Kyphosis=="present", "red", "lightblue"), pt.pch=20, image.col=gray(10:4/10), ngrid2=100) par(org.par) plotmo(fit1, type="prob", nresponse=1, persp.border=NA, persp.col="pink", all1=TRUE, all2=TRUE, caption="plotmo rpart fit1, all1=TRUE, all2=TRUE") expect.err(try(plotmo(fit1, type="none.such1"))) # rpart model with ozone data data(ozone1) par(mfrow=c(4,4)) par(mar=c(.5, 0.5, 2, .5), cex=.6, mgp = c(1.6, 0.6, 0)) # b l t r small margins to pack figs in a1 <- rpart(O3~temp+humidity, data=ozone1) prp(a1, main="rpart model with ozone data\n(temp and humidity only)\n") plotmo(a1, do.par=F, degree1=0, main="rpart", persp.ticktype="detail", persp.nticks=2) expect.err(try(plotmo(a1, type="class"))) # compare to a linear and earth model a3 <- lm(O3~temp+humidity, data=ozone1) plotmo(a3, do.par=F, clip=F, main="lm", degree1=0, all2=TRUE, persp.ticktype="detail", persp.nticks=2) expect.err(try(plotmo(a3, type="none.such2"))) a <- earth(O3~temp+humidity, data=ozone1, degree=2) plotmo(a, do.par=F, clip=F, main="earth", degree1=NA, persp.ticktype="detail", persp.nticks=2) expect.err(try(plotmo(a, type="none.such3"))) expect.err(try(plotmo(a, type=c("abc", "def")))) par(org.par) # detailed rpart model par(mfrow=c(3,3)) a1 <- rpart(O3~., data=ozone1) prp(a1, cex=.9, main="rpart model with full ozone data") plotmo(a1, type="vector", do.par=F, degree1=NA, persp.ticktype="detail", persp.nticks=3, degree2=2:3) par(org.par) plotmo(a1, persp.border=NA, all1=TRUE, all2=TRUE, caption="plotmo rpart a1, all1=TRUE, all2=TRUE") library(tree) tree1 <- tree(O3~., data=ozone1) plotmo(tree1) plotres(tree1) # rpart data with NAs rpart.airquality <- rpart(Ozone~., data=airquality) # airquality has NAs in response and variables plotmo <- plotmo(rpart.airquality, trace=0, SHOWCALL=TRUE) print(rpart.rules(rpart.airquality)) airquality.nonaOzone <- subset(airquality, !is.na(Ozone)) # no NAs in response but NAs in variables rpart.nonaOzone <- rpart(Ozone~., data=airquality.nonaOzone) print(rpart.rules(rpart.nonaOzone)) plotmo.nonaOzone <- plotmo(rpart.nonaOzone, trace=0, SHOWCALL=TRUE) airquality.nonaOzone$Ozone <- NULL stopifnot(identical(plotmo.nonaOzone, airquality.nonaOzone)) # test xflip and yflip par(mfrow=c(4, 4)) par(mgp = c(1.6, 0.6, 0)) par(mar=c(4, 4, 2, .5)) flip.test1 <- rpart(Kyphosis ~ ., data=kyphosis) set.seed(2020) plotmo(flip.test1, type="prob", nresp=2, degree1=NA, do.par=F, main="", type2="image", col.response=ifelse(kyphosis$Kyphosis=="present", "red", "lightblue"), pt.pch=20, image.col=gray(10:4/10)) set.seed(2020) plotmo(flip.test1, type="prob", nresp=2, degree1=NA, do.par=F, main="xflip", type2="image", col.response=ifelse(kyphosis$Kyphosis=="present", "red", "lightblue"), pt.pch=20, image.col=gray(10:4/10), xflip=T) set.seed(2020) plotmo(flip.test1, type="prob", nresp=2, degree1=NA, do.par=F, main="yflip", type2="image", col.response=ifelse(kyphosis$Kyphosis=="present", "red", "lightblue"), pt.pch=20, image.col=gray(10:4/10), yflip=T) set.seed(2020) plotmo(flip.test1, type="prob", nresp=2, degree1=NA, do.par=F, main="xflip and yflip", type2="image", col.response=ifelse(kyphosis$Kyphosis=="present", "red", "lightblue"), pt.pch=20, image.col=gray(10:4/10), xflip=T, yflip=T) flip.test2 <- earth(O3~., data=ozone1, degree=2) plotmo(flip.test2, degree1=NA, degree2=2, do.par=F, main="", type2="cont") plotmo(flip.test2, degree1=NA, degree2=2, do.par=F, main="xflip", type2="cont", xflip=T) plotmo(flip.test2, degree1=NA, degree2=2, do.par=F, main="yflip", type2="cont", yflip=T) plotmo(flip.test2, degree1=NA, degree2=2, do.par=F, main="xflip and yflip", type2="cont", xflip=T, yflip=T) cat("Expect warnings: ignoring xflip=TRUE for persp plot\n") plotmo(flip.test2, degree1=NA, degree2=2, do.par=F, main="xflip and yflip", type2="persp", xflip=T, yflip=T) library(randomForest) data(etitanic) etit <- etitanic[1:300,] cat("=== rf.regression ===\n") set.seed(2016) # Expect Warning: The response has five or fewer unique values. Are you sure you want to do regression? rf.regression <- randomForest(survived~., data=etit, ntree=100, importance = FALSE) plotmo(rf.regression, trace=1) cat("=== rf.regression.importance ===\n") set.seed(2016) # Expect Warning: The response has five or fewer unique values. Are you sure you want to do regression? rf.regression.importance <- randomForest(survived~., data=etit, ntree=100, importance = TRUE) plotmo(rf.regression.importance, trace=1) etit <- etitanic[1:300,] etit$survived <- factor(ifelse(etit$survived == 1, "survived", "died"), levels = c("survived", "died")) cat("=== rf.classification ===\n") set.seed(2016) rf.classification <- randomForest(survived~., data=etit, ntree=100, importance = FALSE) plotmo(rf.classification, trace=1, type="prob", nresponse="surv", SHOWCALL=TRUE) plotmo(rf.classification, trace=1, type="prob", nresponse="died", degree2=0, SHOWCALL=TRUE) cat("=== rf.classification.importance ===\n") set.seed(2016) rf.classification.importance <- randomForest(survived~., data=etit, ntree=100, importance = TRUE) plotmo(rf.classification.importance, trace=1, type="prob", nresponse="surv", SHOWCALL=TRUE) cat("=== plotres randomForest ===\n") plotres(rf.regression) plotres(rf.regression.importance) # TODO residuals are in range 0 to 1 plotres(rf.classification, type="prob", nresponse="surv") plotres(rf.classification.importance, type="prob", nresponse="surv") #--- fda ------------------------------------------------------------------------------ par(org.par) par(mfrow=c(4,5)) par(mar = c(3, 2, 3, .1)) # b, l, t, r par(mgp = c(1.5, .5, 0)) fda.earth <- fda(Species~., data=iris, keep.fitted=TRUE, method=earth, keepxy=TRUE) fda.polyreg <- fda(Species~., data=iris, keep.fitted=TRUE, keepxy=TRUE) fda.bruto <- fda(Species~., data=iris, keep.fitted=TRUE, method=bruto) # 'fda.polyreg$fit' does not have a 'call' field or 'x' and 'y' fields expect.err(try(plotmo(fda.polyreg$fit, type="variates", nresponse=1, clip=F, do.par=F))) plot(1, main="plotmo with fda", xaxt="n", yaxt="n", xlab="", ylab="", type="n", bty="n", cex.main=1.2, xpd=NA) plotmo(fda.earth, type="variates", nresponse=1, clip=F, do.par=F) plot(1, main="plotmo with fda.earth$fit", xaxt="n", yaxt="n", xlab="", ylab="", type="n", bty="n", cex.main=1.2, xpd=NA) plotmo(fda.earth$fit, nresponse=1, clip=F, do.par=F) plot(1, main="", xaxt="n", yaxt="n", xlab="", ylab="", type="n", bty="n", cex.main=1.5, xpd=NA) plot(fda.earth) plotmo(fda.earth, clip=F, do.par=F) # default type is class plot(fda.polyreg) plotmo(fda.polyreg, type="variates", nresponse=1, clip=F, do.par=F, degree1=c(1,3,4)) plot(1, main="", xaxt="n", yaxt="n", xlab="", ylab="", type="n", bty="n", cex.main=1.5, xpd=NA) par(mfrow=c(3,3)) par(mar = c(3, 2, 3, .1)) # b, l, t, r par(mgp = c(1.5, .5, 0)) plot(fda.bruto) plotmo(fda.bruto, type="variates", nresponse=1, do.par=F) par(org.par) # neural net package # for speed we use artificial data because neuralnet is very slow on say trees library(neuralnet) n <- 20 set.seed(3) x1 <- runif(n, min=-1, max=1) x2 <- runif(n, min=-1, max=1) # x2 is noise y <- x1^2 data <- data.frame(y=y, x1=x1, x2=x2) colnames(data) <- c("y","x1", "x2") set.seed(3) nn <- neuralnet(y~x1+x2, data=data, hidden=3, rep=3) print(head(plotmo:::predict.nn(nn, rep="best", trace=TRUE))) set.seed(2020) plotmo(nn, trace=1, col.response=2, all2=TRUE, SHOWCALL=TRUE) # trace=0 below to test hushing of message "assuming "y" in the model.frame is the response, because object$terms is NULL" set.seed(2020) plotmo(nn, trace=0, col.response=2, predict.rep="best", SHOWCALL=TRUE) plotres(nn, trace=0, info=TRUE, SHOWCALL=TRUE) plotres(nn, trace=1, info=TRUE, predict.rep="best", SHOWCALL=TRUE) library(nnet) data(iris3) set.seed(301) samp <- c(sample(1:50,25), sample(51:100,25), sample(101:150,25)) ird <- data.frame(rbind(iris3[,,1], iris3[,,2], iris3[,,3]), species=factor(c(rep("seto",50), rep("vers", 50), rep("virg", 50)))) ir.nn2 <- nnet(species ~ ., data = ird, subset = samp, size = 2, rang = 0.1, decay = 5e-4, maxit = 20) plotmo(ir.nn2, nresponse=1, type="class", all2=T, degree2=2:6) plotmo(ir.nn2, nresponse=2, clip=F, all2=T, degree2=1:5) plotres(ir.nn2, nresponse=2) library(biglm) data(trees) ff <- log(Volume)~log(Girth)+log(Height) chunk1 <- trees[1:20,] chunk2 <- trees[20:31,] biglm <- biglm(ff,chunk1) biglm <- update(biglm, chunk2) plotmo(biglm, pt.col=2, SHOWCALL=TRUE) plotres(biglm, SHOWCALL=TRUE) library(adabag) data(iris) set.seed(2015) # mfinal=3 for speed during testing mod.boosting <- boosting(Species~., data=iris, mfinal=3) mod.bagging <- bagging(Species~., data=iris, mfinal=3) dopar(4, 4, caption="adabag package") plotmo(mod.boosting, nresponse=1, ylim=c(0,1), do.par=FALSE) # default type="prob" plotmo(mod.boosting, type="class", do.par=FALSE) plotmo(mod.bagging, nresponse=1, ylim=c(0,1), do.par=FALSE) plotmo(mod.bagging, nresponse=1, type="votes", do.par=FALSE) par(org.par) library(e1071) data(iris) x.iris <- subset(iris, select=-Species) y.iris <- iris$Species set.seed(2016) svm.xy <- svm(x.iris, y.iris, probability=FALSE) par(mfrow = c(3, 3), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) expect.err(try(plotmo(svm.xy, prob=TRUE, nresponse="vers", do.par=TRUE, all2=TRUE))) # probability=FALSE in call to svm plotmo(svm.xy, decision=TRUE, nresponse="vers", do.par=FALSE, all2=TRUE, degree1=2:3, degree2=6) svm.xy <- svm(x.iris, y.iris, probability=TRUE) plotmo(svm.xy, prob=TRUE, nresponse="vers", do.par=FALSE, all2=TRUE, degree1=2:3, degree2=6) set.seed(2016) svm.form <- svm(Species ~ ., data=iris, probability=T) plotmo(svm.form, predict.p=TRUE, nresponse="vers", do.par=FALSE, all2=TRUE, degree1=2:3, degree2=6) expect.err(try(plotmo(svm.form, decision.values=TRUE, probab=TRUE))) # not both plotres(svm.form, predict.prob=TRUE, nresponse="vers", info=TRUE) plotres(svm.form, jitter=5, info=TRUE) par(org.par) source("test.epilog.R") plotmo/inst/slowtests/test.c50.R0000644000176200001440000000412613725307662016316 0ustar liggesusers# test.c50.R: c50 tests for plotmo and plotres source("test.prolog.R") library(C50) library(rpart.plot) # for ptitanic, want data with NAs for testing library(plotmo) library(earth) # for etitanic data(etitanic) get.tit <- function() # abbreviated titanic data { tit <- etitanic pclass <- as.character(tit$pclass) # change the order of the factors so not alphabetical pclass[pclass == "1st"] <- "first" pclass[pclass == "2nd"] <- "class2" pclass[pclass == "3rd"] <- "classthird" tit$pclass <- factor(pclass, levels=c("class2", "classthird", "first")) # log age is so we have a continuous predictor even when model is age~. set.seed(2015) tit$logage <- log(tit$age) + rnorm(nrow(tit)) tit$parch <- NULL # by=12 gives us a small fast model with an additive and a interaction term tit <- tit[seq(1, nrow(etitanic), by=12), ] } tit <- get.tit() c50.tree.xy <- C5.0(x=tit[,-1], y=tit[,1]) # predict pclass plotmo(c50.tree.xy, type="prob", nresponse="first", pmethod="apartdep") plotmo(c50.tree.xy, type="class") # TODO following gives error: type should be either 'class', 'confidence' or 'prob' # try(plotmo(c50.tree.xy, type="confidence")) plotres(c50.tree.xy, type="prob", nresponse="first") c50.tree.form <- C5.0(pclass~., data=tit) # predict pclass plotmo(c50.tree.form, type="prob", nresponse="first") plotmo(c50.tree.form, type="class") # TODO following gives error: type should be either 'class', 'confidence' or 'prob' # try(plotmo(c50.tree.form, type="confidence")) plotres(c50.tree.form, type="prob", nresponse="first") tit$survived <- factor(ifelse(tit$survived == 1, "yes", "no"), levels = c("yes", "no")) c50.tree.survived <- C5.0(survived~., data=tit, trials=5) # predict survived plotmo(c50.tree.survived, type="prob", nresponse="yes") plotmo(c50.tree.survived, type="class") # TODO following gives error: type should be either 'class', 'confidence' or 'prob' # try(plotmo(c50.tree.survived, type="confidence")) plotres(c50.tree.survived, type="prob", nresponse="yes") source("test.epilog.R") plotmo/inst/slowtests/test.non.earth.bat0000755000176200001440000000162014563571565020175 0ustar liggesusers@rem test.non.earth.bat: test plotmo on non-earth models @rem Stephen Milborrow, Basley KwaZulu-Natal Mar 2011 @echo test.non.earth.bat @"C:\PROGRA~1\R\R-4.3.2\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.non.earth.R @if %errorlevel% equ 0 goto good1: @echo R returned errorlevel %errorlevel%, see test.non.earth.Rout: @echo. @tail test.non.earth.Rout @echo test.non.earth.R @exit /B 1 :good1 mks.diff test.non.earth.Rout test.non.earth.Rout.save @if %errorlevel% equ 0 goto good2: @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.non.earth.save.ps @exit /B 1 :good2 @rem test.non.earth.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.non.earth.save.ps @if %errorlevel% equ 0 goto good3: @echo === Files are different === @exit /B 1 :good3 @rm -f test.non.earth.Rout @rm -f Rplots.ps @exit /B 0 plotmo/inst/slowtests/make.README.bat0000755000176200001440000000024714563571565017200 0ustar liggesusers@rem Create README.html from README.md "C:\PROGRA~1\R\R-4.3.2\bin\x64\R.exe" CMD BATCH --quiet --vanilla make.README.R cat make.readme.Rout rm -f make.readme.Rout plotmo/inst/slowtests/test.plotmo.R0000644000176200001440000010461513727235376017251 0ustar liggesusers# test.plotmo.R: regression tests for plotmo # Stephen Milborrow, Petaluma Jan 2007 print(R.version.string) source("test.prolog.R") library(earth) options(warn=1) # print warnings as they occur data(etitanic) make.space.for.caption <- function(caption="CAPTION") { oma <- par("oma") needed <- 3 # adjust for newlines in caption newlines <- grep("\n", caption) if(length(newlines) > 0) needed <- needed + .5 * newlines # .5 seems enough although 1 in theory if(!is.null(caption) && any(nchar(caption)) && oma[3] <= needed) { oma[3] <- needed par(oma=oma) } } dopar <- function(nrows, ncols, caption = "") { cat(" ", caption, "\n") make.space.for.caption(caption) par(mfrow=c(nrows, ncols)) par(mar = c(3, 3, 1.7, 0.5)) par(mgp = c(1.6, 0.6, 0)) par(cex = 0.7) } example(plotmo) caption <- "basic earth test of plotmo" a <- earth(O3 ~ ., data=ozone1, degree=2) plotmo(a, degree1=2, degree2=4, caption=caption, trace=-1) caption <- "test 5 x 5 layout" dopar(1,1,caption) a <- earth(O3 ~ ., data=ozone1, nk=51, pmethod="n", degree=2) plotmo(a, caption=caption, trace=1) caption <- "test 4 x 4 layout with ylab" dopar(1,1,caption) a <- earth(O3 ~ ., data=ozone1, nk=30, pmethod="n", degree=2) plotmo(a, caption=caption, trace=2) caption <- "test 3 x 3 layout" dopar(1,1,caption) a <- earth(O3 ~ ., data=ozone1, nk=16, pmethod="n", degree=2) plotmo(a, caption=caption, trace=3) caption <- "test 2 x 2 layout" dopar(1,1,caption) a <- earth(O3 ~ ., data=ozone1, nk=9, pmethod="n", degree=2) plotmo(a, caption=caption) caption <- "test 1 x 1 layout" dopar(1,1,caption) a <- earth(O3 ~ ., data=ozone1, nk=4, pmethod="n", degree=2) plotmo(a, caption=caption) caption <- "test plotmo basic params" a <- earth(O3 ~ ., data=ozone1, degree=2) dopar(3,2,caption) plotmo(a, do.par=FALSE, degree1=1, nrug=-1, degree2=F, caption=caption, main="test main", xlab="test xlab", ylab="test ylab") plotmo(a, do.par=FALSE, degree1=F, degree2=4, grid.func=mean, persp.col="white", ngrid2=10, persp.phi=40) set.seed(2016) plotmo(a, do.par=FALSE, degree1=1, degree1.lty=2, degree1.lwd=4, degree1.col=2, nrug=TRUE, degree2=F, main="nrug=300") plotmo(a, do.par=FALSE, degree1=1, nrug=-1, degree2=F, main="nrug=TRUE") set.seed(2016) plotmo(a, do.par=FALSE, degree1=1, nrug=10, ngrid1=50, degree2=F, main="ngrid1=50 nrug=10") plotmo(a, do.par=FALSE, degree1=NA, degree2=1, persp.phi=60) # graph args caption <- "test plotmo xlim and ylim" a <- earth(O3 ~ ., data=ozone1, degree=2) dopar(5,3,caption) plotmo(a, do.par=FALSE, degree1=2:3, degree2=4, caption=caption, xlab="ylim=default") plotmo(a, do.par=FALSE, degree1=2:3, degree2=4, ylim=NA, xlab="ylim=NA") plotmo(a, do.par=FALSE, degree1=2:3, degree2=4, ylim=c(0,20), xlab="ylim=c(0,20)") plotmo(a, do.par=FALSE, degree1=2:3, degree2=4, xlim=c(190,250), xlab="xlim=c(190,250)") plotmo(a, do.par=FALSE, degree1=2:3, degree2=4, xlim=c(190,250), ylim=c(11,18), xlab="xlim=c(190,250), ylim=c(11,18)") # check various types of predictors with grid.func and ndiscrete varied.type.data <- data.frame( y = 1:13, num = c(1, 3, 2, 3, 4, 5, 6, 4, 5, 6.5, 3, 6, 5), # 7 unique values (but one is non integral) int = c(1L, 1L, 3L, 3L, 4L, 4L, 3L, 5L, 3L, 6L, 7L, 8L, 10L), # 8 unique values bool = c(F, F, F, F, F, T, T, T, T, T, T, T, T), date = as.Date( c("2018-08-01", "2018-08-02", "2018-08-03", "2018-08-04", "2018-08-05", "2018-08-06", "2018-08-07", "2018-08-08", "2018-08-08", "2018-08-08", "2018-08-10", "2018-08-11", "2018-08-11")), ord = ordered(c("ord3", "ord3", "ord3", "ord1", "ord2", "ord3", "ord1", "ord2", "ord3", "ord1", "ord1", "ord1", "ord1"), levels=c("ord1", "ord3", "ord2")), fac = as.factor(c("fac1", "fac1", "fac1", "fac2", "fac2", "fac2", "fac3", "fac3", "fac3", "fac1", "fac2", "fac3", "fac3")), str = c("str1", "str1", "str1", # will be treated like a factor "str2", "str2", "str2", "str3", "str3", "str3", "str3", "str3", "str3", "str3")) varied.type.lm <- lm(y ~ ., data = varied.type.data) print(summary(varied.type.lm)) set.seed(2018) plotres(varied.type.lm, info=TRUE) plotmo(varied.type.lm, pmethod="apartdep", all2=TRUE, ticktype="d", col.response="red", caption="varied.type.lm\npmethod=\"apartdep\" default grid func") plotmo(varied.type.lm, all2=TRUE, ticktype="d", col.response="red", caption="varied.type.lm\ndefault grid func") plotmo(varied.type.lm, all2=TRUE, ndiscre=1, caption="varied.type.lm\nndiscrete=1") plotmo(varied.type.lm, all2=TRUE, ndiscr=2, caption="varied.type.lm\nndiscrete=2") plotmo(varied.type.lm, all2=TRUE, ndis=100, caption="varied.type.lm\nndiscrete=100") cat("grid.func=median:\n") plotmo(varied.type.lm, all2=TRUE, grid.func=median, caption="varied.type.lm\ngrid.func=median") cat("grid.func=quantile:\n") plotmo(varied.type.lm, all2=TRUE, grid.func=function(x, ...) quantile(x, 0.5), caption="varied.type.lm\ngrid.func=function(x, ...) quantile(x, 0.5)") cat("grid.func=mean:\n") plotmo(varied.type.lm, all2=TRUE, grid.func=mean, caption="varied.type.lm\ngrid.func=mean") varied.type.earth <- earth(y ~ ., data = varied.type.data, thresh=0, penalty=-1, trace=1) print(summary(varied.type.earth)) set.seed(2018) plotres(varied.type.earth, info=TRUE) plotmo(varied.type.earth, all1=TRUE, all2=TRUE, persp.ticktype="d", col.response="red") # term.plot calls predict.earth with an se parameter, even with termplot(se=FALSE) caption <- "basic earth test against termplot" dopar(4,4,caption) make.space.for.caption("test caption1") a <- earth(O3 ~ ., data=ozone1, degree=2) plotmo(a, do.par=FALSE, ylim=NA, caption=caption, degree2=FALSE) cat("Ignore warning: predict.earth ignored argument \"se.fit\"\n") termplot(a) caption <- "test change order of earth predictors and cex" dopar(4,4,caption) # minspan=1 to force two degree2 graphs for the test (wasn't necessary in old versions of earth) a <- earth(doy ~ humidity + temp + wind, data=ozone1, degree=2, minspan=1) plotmo(a, do.par=FALSE, ylim=NA, caption=caption, degree2=c(1,2), cex=1.2) termplot(a) caption <- "test all1=TRUE" a <- earth(doy ~ humidity + temp + wind, data=ozone1, degree=2) plotmo(a, caption=caption, all1=TRUE, persp.ticktype="d", persp.nticks=2) caption <- "test all2=TRUE" print(summary(a)) plotmo(a, caption=caption, all2=TRUE) oz <- ozone1[150:200,c("O3","temp","humidity","ibh")] a.glob <- earth(O3~temp+humidity, data=oz, degree=2) ad.glob <- earth(oz[,2:3], oz[,1], degree=2) func1 <- function() { caption <- "test environments and finding the correct data" dopar(4,4,caption) set.seed(2016) plotmo(a.glob, do.par=FALSE, main="a.glob oz", degree1=1, all2=1, degree2=1, type2="im", col.response=3, pt.pch=20, trace=2) mtext(caption, outer=TRUE, font=2, line=1.5, cex=1) plotmo(ad.glob, do.par=FALSE, main="ad.glob oz", degree1=1, all2=1, degree2=1, type2="im", col.response=3, pch.response=20, trace=2) # pch.response test backcompat a <- earth(O3~temp+humidity, data=oz, degree=2) plotmo(a, do.par=FALSE, main="a oz", degree1=1, all2=1, degree2=1, type2="im", col.response=3, pt.pch=20) ad <- earth(oz[,2:3], oz[,1], degree=2) plotmo(ad, do.par=FALSE, main="ad oz", degree1=1, all2=1, degree2=1, type2="im", col.response=3, pt.pch=20) oz.org <- oz oz10 <- 10 * oz # multiply by 10 so we can see by the axis labels if right data is being used oz <- oz10 # oz is now local to this function, but multiplied by 10 a.oz10 <- earth(O3~temp+humidity, data=oz, degree=2) a.oz10.keep <- earth(O3~temp+humidity, data=oz, degree=2, keepxy=TRUE) plotmo(a.oz10, do.par=FALSE, main="a oz10", degree1=1, all2=1, degree2=1, type2="im", col.response=3, pt.pch=20) ad.oz10 <- earth(oz[,2:3], oz[,1], degree=2) ad.oz10.keep <- earth(oz[,2:3], oz[,1], degree=2, keepxy=TRUE) plotmo(ad.oz10, do.par=FALSE, main="ad oz10", degree1=1, all2=1, degree2=1, type2="im", col.response=3, pt.pch=20) func2 <- function() { a.func <- earth(O3 ~ temp + humidity, data=oz10, degree=2) plotmo(a.func, do.par=FALSE, main="a.func oz10", degree1=1, all2=1, degree2=1, type2="im", col.response=3, pt.pch=20) ad.func <- earth(oz10[,2:3], oz10[,1], degree=2) plotmo(ad.func, do.par=FALSE, main="ad.func oz10", degree1=1, all2=1, degree2=1, type2="im", col.response=3, pt.pch=20) caption <- "test environments and finding the correct data, continued" dopar(4,4,caption) oz <- .1 * oz.org a.func <- earth(O3~temp+ humidity , data=oz, degree=2) plotmo(a.func, do.par=FALSE, main="a.func oz.1", degree1=1, all2=1, degree2=1, type2="im", col.response=3, pt.pch=20) ad.func <- earth(oz[,2:3], oz[,1], degree=2) plotmo(ad.func, do.par=FALSE, main="ad.func oz.1", degree1=1, all2=1, degree2=1, type2="im", col.response=3, pt.pch=20) plotmo(a.oz10.keep, do.par=FALSE, main="func1:a.oz10.keep", degree1=1, all2=1, degree2=1, type2="im", col.response=3, pt.pch=20) plotmo(ad.oz10.keep, do.par=FALSE, main="func1:ad.oz10.keep", degree1=1, all2=1, degree2=1, type2="im", col.response=3, pt.pch=20) cat("Expect error msg: formal argument \"do.par\" matched by multiple actual arguments\n") expect.err(try(plotmo(a.oz10, do.par=FALSE, main="func1:a.oz10", degree1=1, all2=1, degree2=1, type2="im", col.response=3, pt.pch=20, do.par=FALSE))) } func2() y <- 3:11 x1 <- c(1,3,2,4,5,6,6,6,6) x2 <- c(2,3,4,5,6,7,8,9,10) frame <- data.frame(y=y, x1=x1, x2=x2) foo <- function() { lm.18.out <- lm(y~x1+x2, model=FALSE) x1[2] <- 18 y[3] <- 19 frame <- data.frame(y=y, x1=x1, x2=x2) list(lm.18.out = lm.18.out, lm.18 = lm(y~x1+x2), lm.18.keep = lm(y~x1+x2, x=TRUE, y=TRUE), lm.18.frame = lm(y~x1+x2, data=frame)) } temp <- foo() lm.18.out <- temp$lm.18.out lm.18 <- temp$lm.18 lm.18.keep <- temp$lm.18.keep lm.18.frame <- temp$lm.18.frame # following should all use the x1 and y inside foo cat("==lm.18.out\n") plotmo(lm.18.out, main="lm.18.out", do.par=FALSE, degree1=1, clip=FALSE, ylim=c(0,20), col.response=2, pt.pch=20) cat("==lm.18\n") plotmo(lm.18, main="lm.18", do.par=FALSE, degree1=1, clip=FALSE, ylim=c(0,20), col.response=2, pt.pch=20) cat("==lm.18.keep\n") plotmo(lm.18.keep, main="lm.18.keep", trace=2, do.par=FALSE, degree1=1, clip=FALSE, ylim=c(0,20), col.response=2, pt.pch=20) cat("==lm.18.frame\n") plotmo(lm.18.frame, main="lm.18.frame", do.par=FALSE, degree1=1, clip=FALSE, ylim=c(0,20), col.response=2, pt.pch=20) } func1() caption <- "test earth formula versus x,y model" # dopar(4,4,caption) # mtext(caption, outer=TRUE, font=2, line=1.5, cex=1) a <- earth(O3 ~ ., data=ozone1, degree=2) plotmo(a, caption="test earth formula versus xy model (formula)") a <- earth(ozone1[, -1], ozone1[,1], degree=2) plotmo(a, caption="test earth formula versus xy model (xy)") # single predictor caption <- "test earth(O3~wind, data=ozone1, degree=2), single predictor" dopar(2,2,caption) a <- earth(O3~wind, data=ozone1, degree=2) plotmo(a) caption = "se=2, earth(doy~humidity+temp+wind, data=ozone1) versus termplot (expect no se lines)" dopar(3,3,caption) mtext(caption, outer=TRUE, font=2, line=1.5, cex=1) # minspan=1 to force two degree2 graphs for the test (wasn't necessary in old versions of earth) a <- earth(doy~humidity + temp + wind, data=ozone1, degree=2, minspan=1) cat("Ignore warning: predict.earth ignored argument \"se\"\n") termplot(a) plotmo(a, do.par=FALSE, ylim=NA, degree2=c(1:2), clip=FALSE, caption=caption) # test fix to bug reported by Joe Retzer, FIXED Dec 7, 2007 N <- 650 set.seed(2007) q_4 <- runif(N, -1, 1) q_2102 <- runif(N, -1, 1) q_2104 <- runif(N, -1, 1) q_3105 <- runif(N, -1, 1) q_3106 <- runif(N, -1, 1) q_4104 <- runif(N, -1, 1) q_6101 <- runif(N, -1, 1) q_6103 <- runif(N, -1, 1) q_7104 <- runif(N, -1, 1) q_3109 <- runif(N, -1, 1) q_4103 <- runif(N, -1, 1) q_2111 <- runif(N, -1, 1) q_3107 <- runif(N, -1, 1) q_3101 <- runif(N, -1, 1) q_3104 <- runif(N, -1, 1) q_7107 <- runif(N, -1, 1) depIndex <- sin(1.0 * q_4 + rnorm(650, sd=.8)) + sin(1.8 * q_2102 + rnorm(650, sd=.8)) + sin(1.3 * q_2104 + rnorm(650, sd=.8)) + sin(1.4 * q_3105 + rnorm(650, sd=.8)) + sin(1.5 * q_3106 + rnorm(650, sd=.8)) + sin(1.6 * q_4104 + rnorm(650, sd=.8)) + sin(1.8 * q_6101 + rnorm(650, sd=.8)) + sin(1.8 * q_6103 + rnorm(650, sd=.8)) + sin(1.9 * q_7104 + rnorm(650, sd=.8)) + sin(2.0 * q_3109 + rnorm(650, sd=.8)) regDatCWD <- as.data.frame(cbind(depIndex, q_4, q_2102, q_2104, q_3105, q_3106, q_4104, q_6101, q_6103, q_7104, q_3109, q_4103, q_2111, q_3107, q_3101, q_3104, q_7107)) cat("--plotmo(earthobj5)--\n") earthobj5 <- earth(depIndex ~ q_4+q_2102+q_2104+q_3105+q_3106+q_4104+q_6101+q_6103+q_7104+q_3109+q_4103+q_2111+q_3107+q_3101+q_3104+q_7107, data=regDatCWD) print(summary(earthobj5, digits = 2)) plotmo(earthobj5) # long predictor names a.rather.long.in.fact.very.long.name.q_4 <- q_4 a.rather.long.in.fact.very.long.name.q_2102 <- q_2102 a.rather.long.in.fact.very.long.name.q_2104 <- q_2104 a.rather.long.in.fact.very.long.name.q_3105 <- q_3105 a.rather.long.in.fact.very.long.name.q_3106 <- q_3106 a.rather.long.in.fact.very.long.name.q_4104 <- q_4104 a.rather.long.in.fact.very.long.name.q_6101 <- q_6101 a.rather.long.in.fact.very.long.name.q_6103 <- q_6103 a.rather.long.in.fact.very.long.name.q_7104 <- q_7104 a.rather.long.in.fact.very.long.name.q_3109 <- q_3109 a.rather.long.in.fact.very.long.name.q_4103 <- q_4103 a.rather.long.in.fact.very.long.name.q_2111 <- q_2111 a.rather.long.in.fact.very.long.name.q_3107 <- q_3107 a.rather.long.in.fact.very.long.name.q_3101 <- q_3101 a.rather.long.in.fact.very.long.name.q_3104 <- q_3104 a.rather.long.in.fact.very.long.name.q_7107 <- q_7107 a.rather.long.in.fact.very.long.name.for.the.response <- depIndex a.rather.long.in.fact.very.long.name.for.the.dataframe <- as.data.frame(cbind( a.rather.long.in.fact.very.long.name.for.the.response, a.rather.long.in.fact.very.long.name.q_4, a.rather.long.in.fact.very.long.name.q_2102, a.rather.long.in.fact.very.long.name.q_2104, a.rather.long.in.fact.very.long.name.q_3105, a.rather.long.in.fact.very.long.name.q_3106, a.rather.long.in.fact.very.long.name.q_4104, a.rather.long.in.fact.very.long.name.q_6101, a.rather.long.in.fact.very.long.name.q_6103, a.rather.long.in.fact.very.long.name.q_7104, a.rather.long.in.fact.very.long.name.q_3109, a.rather.long.in.fact.very.long.name.q_4103, a.rather.long.in.fact.very.long.name.q_2111, a.rather.long.in.fact.very.long.name.q_3107, a.rather.long.in.fact.very.long.name.q_3101, a.rather.long.in.fact.very.long.name.q_3104, a.rather.long.in.fact.very.long.name.q_7107)) cat("--a.rather.long.in.fact.very.long.name.for.the...A--\n") a.rather.long.in.fact.very.long.name.for.the.modelA <- earth(a.rather.long.in.fact.very.long.name.for.the.response ~ a.rather.long.in.fact.very.long.name.q_4 + a.rather.long.in.fact.very.long.name.q_2102 + a.rather.long.in.fact.very.long.name.q_2104 + a.rather.long.in.fact.very.long.name.q_3105 + a.rather.long.in.fact.very.long.name.q_3106 + a.rather.long.in.fact.very.long.name.q_4104 + a.rather.long.in.fact.very.long.name.q_6101 + a.rather.long.in.fact.very.long.name.q_6103 + a.rather.long.in.fact.very.long.name.q_7104 + a.rather.long.in.fact.very.long.name.q_3109 + a.rather.long.in.fact.very.long.name.q_4103 + a.rather.long.in.fact.very.long.name.q_2111 + a.rather.long.in.fact.very.long.name.q_3107 + a.rather.long.in.fact.very.long.name.q_3101 + a.rather.long.in.fact.very.long.name.q_3104 + a.rather.long.in.fact.very.long.name.q_7107, data = a.rather.long.in.fact.very.long.name.for.the.dataframe) print(summary(a.rather.long.in.fact.very.long.name.for.the.modelA, digits = 2)) plot(a.rather.long.in.fact.very.long.name.for.the.modelA) plotmo(a.rather.long.in.fact.very.long.name.for.the.modelA) cat("--a.rather.long.in.fact.very.long.name.for.the...C--\n") a.rather.long.in.fact.very.long.name.for.the.modelC <- earth(x = a.rather.long.in.fact.very.long.name.for.the.dataframe[,-1], y = a.rather.long.in.fact.very.long.name.for.the.response, degree = 3) print(summary(a.rather.long.in.fact.very.long.name.for.the.modelC, digits = 2)) plot(a.rather.long.in.fact.very.long.name.for.the.modelC) plotmo(a.rather.long.in.fact.very.long.name.for.the.modelC) a <- earth(survived ~ pclass+sex+age, data=etitanic, degree=2) print(summary(a)) plotmo(a, caption="plotmo with facs: pclass+sex+age") plotmo(a, caption="plotmo with facs: pclass+sex+age, all1=T, grid.col=\"gray\"", all1=T, grid.col="gray") plotmo(a, caption="plotmo with facs: pclass+sex+age, all2=T, col.grid=\"green\"", all2=T, col.grid="green") plotmo(a, caption="plotmo with facs: pclass+sex+age, all1=T, all2=T, grid=2", all1=T, all2=T, grid.col=2) plotmo(a, clip=FALSE, degree2=FALSE, caption="plotmo (no degree2) with facs: pclass+sex+age") plotmo(a, clip=FALSE, grid.levels=list(pclass="2n", sex="ma"), caption="plotmo with grid.levels: pclass+sex+age") # in above tests, all degree2 terms use facs # now build a model with some degree2 term that use facs, some that don't a <- earth(survived ~ pclass+age+sibsp, data=etitanic, degree=2) print(summary(a)) plotmo(a, caption="plotmo with mixed fac and non-fac degree2 terms", persp.border=NA) plotmo(a, caption="plotmo with mixed fac and non-fac degree2 terms and grid.levels", grid.levels=list(pclass="2n", age=20), # test partial matching of grid levels, and numeric preds persp.ticktype="d", persp.nticks=2) # check detection of illegal grid.levels argument expect.err(try(plotmo(a, grid.levels=list(pcla="1", pclass="2"))), 'illegal grid.levels argument ("pcla" and "pclass" both match "pclass")') expect.err(try(plotmo(a, grid.levels=list(pclass="1", pcla="2"))), 'illegal grid.levels argument ("pclass" and "pcla" both match "pclass")') expect.err(try(plotmo(a, grid.levels=list(pcla="nonesuch"))), 'illegal level "nonesuch" for "pclass" in grid.levels (allowed levels are "1st" "2nd" "3rd")') expect.err(try(plotmo(a, grid.levels=list(pcla="1sx"))), 'illegal level "1sx" for "pclass" in grid.levels (allowed levels are "1st" "2nd" "3rd")') expect.err(try(plotmo(a, grid.levels=list(pcla=1))), 'illegal level for "pclass" in grid.levels (specify factor levels with a string)') expect.err(try(plotmo(a, grid.levels=list(pcla=c("ab", "cd")))), "length(pclass) in grid.levels is not 1") expect.err(try(plotmo(a, grid.levels=list(pcla=NA))), 'pclass in grid.levels is NA') expect.err(try(plotmo(a, grid.levels=list(pcla=Inf))), 'pclass in grid.levels is infinite') expect.err(try(plotmo(a, grid.levels=list(pcla=9))), 'illegal level for "pclass" in grid.levels (specify factor levels with a string)') options(warn=2) expect.err(try(plotmo(a, grid.levels=list(age="ab"))), 'grid.levels returned class \"character\" for age, so will use the default grid.func for age') options(warn=1) expect.err(try(plotmo(a, grid.levels=list(age=NA))), 'age in grid.levels is NA') expect.err(try(plotmo(a, grid.levels=list(age=Inf))), 'age in grid.levels is infinite') expect.err(try(plotmo(a, grid.lev=list(age=list(1,2)))), 'length(age) in grid.levels is not 1') # more-or-less repeat above, but with glm models a <- earth(survived ~ pclass+age+sibsp, data=etitanic, degree=2, glm=list(family=binomial)) print(summary(a)) plotmo(a, ylim=c(0, 1), caption="plotmo glm with mixed fac and non-fac degree2 terms") plotmo(a, ylim=c(0, 1), caption="plotmo glm with mixed fac and non-fac degree2 terms and grid.levels", grid.levels=list(pcl="2nd")) # test partial matching of variable name in grid levels plotmo(a, type="earth", ylim=c(0, 1), caption="type=\"earth\" plotmo glm with mixed fac and non-fac degree2 terms") plotmo(a, type="link", ylim=c(0, 1), clip=FALSE, caption="type=\"link\" plotmo glm with mixed fac and non-fac degree2 terms") plotmo(a, type="class", ylim=c(0, 1), caption="type=\"class\" plotmo glm with mixed fac and non-fac degree2 terms") plotmo(a, ylim=c(0, 1), caption="default type (\"response\")\nplotmo glm with mixed fac and non-fac degree2 terms") # now with different type2s set.seed(2016) plotmo(a, do.par=FALSE, type2="persp", persp.theta=-20, degree1=FALSE, grid.levels=list(pclass="2nd")) mtext("different type2s", outer=TRUE, font=2, line=1.5, cex=1) plotmo(a, do.par=FALSE, type2="contour", degree1=FALSE, grid.levels=list(pclass="2nd")) plotmo(a, do.par=FALSE, type2="image", degree1=FALSE, grid.levels=list(pclass="2nd"), col.response=as.numeric(etitanic$survived)+2, pt.pch=20) plotmo(a, do.par=FALSE, type="earth", type2="image", degree1=FALSE, grid.levels=list(pclass="2")) # grid.levels with partdep set.seed(2018) x1 <- (1:11) + runif(11) x2 <- (1:11) + runif(11) x3 <- as.integer((1:11) + runif(11)) x4 <- runif(11) > .5 # logical y <- x1 - x2 + x3 + x4 data <- data.frame(y=y, x1=x1, x2=x2, x3=x3, x4=x4) lm.x1.x2.x3 <- lm(y ~ x1 + x2 + x3 + x4 + x1*x2 + x1*x3, data=data) cat("summary(lm.x1.x2.x3):\n") print(summary(lm.x1.x2.x3)) par(mfrow = c(5, 6), mar = c(2, 3, 2, 1), mgp = c(1.5, 0.5, 0), cex = 0.6, oma=c(0,0,8,0)) plotmo(lm.x1.x2.x3, do.par=0, ylim=c(0,16), pt.col=2, caption="row1 default\nrow2 grid.levels=list(x3=15)\nrow3 partdep\nrow4 partdetp grid.levels=list(x3=15)") plotmo(lm.x1.x2.x3, do.par=0, ylim=c(0,16), pt.col=2, grid.levels=list(x3=15)) plotmo(lm.x1.x2.x3, do.par=0, ylim=c(0,16), pt.col=2, pmethod="partdep") plotmo(lm.x1.x2.x3, do.par=0, ylim=c(0,16), pt.col=2, pmethod="partdep", grid.levels=list(x3=15)) # check auto type convert in grid.levels plotmo(lm.x1.x2.x3, degree1="x1", degree2=0, main="x1 (x2=5L))", ylim=c(0,16), do.par=0, pmethod="partdep", grid.levels=list(x2=15L)) # integer to numeric plotmo(lm.x1.x2.x3, degree1="x1", degree2=0, main="x1 (x3=5))", ylim=c(0,16), do.par=0, pmethod="partdep", grid.levels=list(x3=15)) # numeric to integer plotmo(lm.x1.x2.x3, degree1="x1", degree2=0, main="x1 (x4=1))", ylim=c(0,16), do.par=0, pmethod="partdep", grid.levels=list(x4=1)) # numeric to logical expect.err(try(plotmo(lm.x1.x2.x3, degree1="x1", degree2=0, main="x1 (x4=1))", ylim=c(0,16), do.par=0, pmethod="partdep", grid.levels=list(x4="x"))), "expected a logical value in grid.levels for x4") # char to logical expect.err(try(plotmo(lm.x1.x2.x3, degree1="x2", do.par=0, pmethod="partdep", grid.levels=list(x1="1"))), "the class \"character\" of \"x1\" in grid.levels does not match its class \"numeric\" in the input data") par(org.par) # test vector main a20 <- earth(O3 ~ humidity + temp + doy, data=ozone1, degree=2, glm=list(family=Gamma)) dopar(2, 2) plotmo(a20, nrug=-1) set.seed(2016) plotmo(a20, nrug=10, caption="Test plotmo with a vector main (and npoints=200)", main=c("Humidity", "Temperature", "Day of year", "Humidity: Temperature", "Temperature: Day of Year"), col.response="darkgray", pt.pch=".", cex.response=3, npoints=200) # cex.response tests back compat cat("Expect warning below (missing double titles)\n") plotmo(a20, nrug=-1, caption="Test plotmo with a vector main (and plain smooth)", main=c("Humidity", "Temperature", "Day of year", "Humidity: Temperature", "Temp: Doy"), smooth.col="indianred") cat("Expect warning below (missing single titles)\n") plotmo(a20, nrug=-1, caption="Test plotmo with a vector main (and smooth args)", main=c("Humidity", "Temperature"), smooth.col="indianred", smooth.lwd=2, smooth.lty=2, smooth.f=.1, col.response="gray", npoints=500) plotmo(a20, nrug=-1, caption="Test plotmo with pt.pch=paste(1:nrow(ozone1))", type2="im", col.response=2, pt.cex=.8, pt.pch=paste(1:nrow(ozone1)), npoints=100) aflip <- earth(O3~vh + wind + humidity + temp, data=ozone1, degree=2) # test all1 and all2, with and without degree1 and degree2 plotmo(aflip, all2=T, caption="all2=T", npoints=TRUE) plotmo(aflip, all2=T, degree2=c(4, 2), caption="all2=T, degree2=c(4, 2)") plotmo(aflip, all1=T, caption="all1=T") plotmo(aflip, all1=T, degree1=c(3,1), degree2=NA, caption="all1=T, degree1=c(3,1), degree2=NA") options(warn=2) expect.err(try(plotmo(aflip, no.such.arg=9)), "(converted from warning) predict.earth ignored argument 'no.such.arg'") expect.err(try(plotmo(aflip, ycolumn=1)), "(converted from warning) predict.earth ignored argument 'ycolumn'") expect.err(try(plotmo(aflip, title="abc")), "(converted from warning) predict.earth ignored argument 'title'") expect.err(try(plotmo(aflip, persp.ticktype="d", persp.ntick=3, tic=3, tick=9)), "(converted from warning) predict.earth ignored argument 'tic'") expect.err(try(plotmo(aflip, persp.ticktype="d", ntick=3, tic=3)), "(converted from warning) predict.earth ignored argument 'ntick'") options(warn=1) # expect.err(try(plotmo(aflip, adj1=8, adj2=9))) # Error : plotmo: illegal argument "adj1" # expect.err(try(plotmo(aflip, yc=8, x2=9))) # "ycolumn" is no longer legal, use "nresponse" instead # expect.err(try(plotmo(aflip, persp.ticktype="d", ntick=3, ti=3))) # Error : "title" is illegal, use "caption" instead ("ti" taken to mean "title") # expect.err(try(plotmo(aflip, persp.ticktype="d", ntick=3, title=3))) # Error : "title" is illegal, use "caption" instead # expect.err(try(plotmo(aflip, persp.ticktype="d", ntick=3, tit=3, titl=7))) # Error : "title" is illegal, use "caption" instead ("tit" taken to mean "title") # expect.err(try(plotmo(aflip, zlab="abc"))) # "zlab" is illegal, use "ylab" instead # expect.err(try(plotmo(aflip, z="abc"))) # "zlab" is illegal, use "ylab" instead ("z" taken to mean "zlab") expect.err(try(plotmo(aflip, degree1=c(4,1))), "'degree1' is out of range, allowed values are 1 to 2") # expect.err(try(plotmo(aflip, none.such=TRUE))) # illegal argument "all1" # expect.err(try(plotmo(aflip, ntick=3, type2="im"))) # the ntick argument is illegal for type2="image" # expect.err(try(plotmo(aflip, breaks=3, type2="persp"))) # the breaks argument is illegal for type2="persp" # expect.err(try(plotmo(aflip, breaks=99, type2="cont"))) # the breaks argument is illegal for type2="contour" # Test error handling when accessing the original data lm.bad <- lm.fit(as.matrix(ozone1[,-1]), as.matrix(ozone1[,1])) expect.err(try(plotmo(lm.bad)), "'lm.bad' is a plain list, not an S3 model") expect.err(try(plotmo(99)), "'99' is not an S3 model") x <- matrix(c(1,3,2,4,5,6,7,8,9,10, 2,3,4,5,6,7,8,9,8,9), ncol=2) colnames(x) <- c("c1", "c2") x1 <- x[,1] x2 <- x[,2] y <- 3:12 df <- data.frame(y=y, x1=x1, x2=x2) foo1 <- function() { a.foo1 <- lm(y~x1+x2, model=FALSE) x1 <- NULL expect.err(try(plotmo(a.foo1)), "cannot get the original model predictors") } foo1() foo2 <- function() { a.foo2 <- lm(y~x1+x2, data=df, model=FALSE) df <- 99 # note that df <- NULL here will not cause an error msg y <- 99 # also needed else model.frame in plotmo will find the global y expect.err(try(plotmo(a.foo2)), "cannot get the original model predictors") } foo2() foo3 <- function() { a.foo3 <- lm(y~x) # lm() builds an lm model for which predict doesn't work expect.err(try(plotmo(a.foo3)), "predict returned the wrong length (got 10 but expected 50)") } foo3() foo3a <- function() { a.foo3a <- lm(y~x) # lm() builds an lm model for which predict doesn't work # this tests "ngrid1 <- ngrid1 + 1" in plotmo.R expect.err(try(plotmo(a.foo3a, ngrid1=nrow(x))), "predict returned the wrong length (got 10 but expected 11)") } foo3a() foo4 <- function() { a.foo4 <- lm(y~x[,1]+x[,2]) # builds an lm model for which predict doesn't work # causes 'newdata' had 8 rows but variables found have 10 rows expect.err(try(plotmo(a.foo4)), "predict returned the wrong length (got 10 but expected 50)") } foo4() foo5 <- function() { a.foo5 <- lm(y~x1+x2, model=FALSE) x1 <- c(1,2,3) # causes Error in model.frame.default: variable lengths differ (found for 'x1') expect.err(try(plotmo(a.foo5)), "cannot get the original model predictors") } foo5() foo6 <- function() { a.foo6 <- lm(y~x1+x2, model=FALSE) y[1] <- NA # Error in na.fail.default: missing values in object expect.err(try(plotmo(a.foo6, col.response=3)), "cannot get the original model predictors") } foo6() foo7 <- function() { a.foo7 <- lm(y~x1+x2, model=FALSE) y[1] <- Inf options <- options("warn") on.exit(options(warn=options$warn)) options(warn=2) expect.err(try(plotmo(a.foo7, col.response=3)), "non-finite values returned by plotmo_y") } foo7() options(warn=1) foo8 <- function() { i <- 1 a.foo8 <- lm(y~x[,i]+x[,2]) options <- options("warn") on.exit(options(warn=options$warn)) options(warn=2) expect.err(try(plotmo(a.foo8)), "Cannot determine which variables to plot in degree2 plots (use all2=TRUE?)") options(warn=options$warn) expect.err(try(plotmo(a.foo8)), "predict returned the wrong length (got 10 but expected 50)") } foo8() options(warn=1) foo9 <- function() { my.list <- list(j=2) a.foo9 <- lm(y~x[,1]+x[,my.list$j]) expect.err(try(plotmo(a.foo9)), "cannot get the original model predictors") } foo9() foo9a <- function() { df <- data.frame(y=y, x1=x[,1], x2=x[,2]) a.foo9a <- lm(y~x1+x2, data=df) par(mfrow = c(2, 2), oma=c(0,0,4,0)) set.seed(2018) plotmo(a.foo9a, col.resp=2, do.par=FALSE, caption="top two plots should be identical to bottom two plots") x2 <- rep(99, length(x2)) a.foo9b <- lm(y~x1+x2, data=df) x2 <- rep(199, length(x2)) plotmo(a.foo9b, col.resp=2, do.par=FALSE) } foo9a() par(org.par) foo20.func <- function() { par(mfrow = c(2, 2), oma=c(0,0,4,0)) foo20 <- lm(y~x1+x2) set.seed(2018) plotmo(foo20, degree1=1:2, col.resp=2, do.par=FALSE, caption="top two plots should be identical to bottom two plots\nbecause we use saved lm$model") x1 <- 99 plotmo(foo20, degree1=1:2, col.resp=2, do.par=FALSE) } foo20.func() par(org.par) set.seed(1235) tit <- etitanic tit <- tit[c(30:80,330:380,630:680), ] a <- earth(survived~., data=tit, glm=list(family=binomial), degree=2) plotmo(a, grid.levels=list(sex="ma"), caption="smooth: survived, sex=\"m\" jitter=1", smooth.col="indianred", smooth.lwd=2, col.response=as.numeric(tit$survived)+2, pt.pch=".", type2="im", pt.cex=3, jitter=1) # big jitter set.seed(1238) a <- earth(pclass~., data=tit) plotmo(a, type="class", nresponse=1, grid.levels=list(sex="ma"), caption="smooth: pclass, sex=\"m\"", SHOWCALL=TRUE, smooth.col="indianred", smooth.lwd=2, col.response=as.numeric(tit$pclass)+1, type2="im", pt.pch=".", pt.cex=3) plotmo(a, type="class", nresponse=1, grid.levels=list(sex="ma"), caption="smooth: pclass, sex=\"m\" jitter=.3", SHOWCALL=TRUE, smooth.col="indianred", smooth.lwd=2, col.response=as.numeric(tit$pclass)+1, type2="im", pt.pch="x", jit=.3) # small jitter plotmo(a, nresponse=1, type="class", grid.levels=list(sex="ma"), caption="smooth: pclass, sex=\"m\"", SHOWCALL=TRUE, smooth.col="indianred", smooth.lwd=2, col.response=as.numeric(tit$pclass)+1, type2="im", pt.pch=paste(1:nrow(tit))) # test the extend argument plotmo(a, nresponse=1, pt.col=2, degree2=0, SHOWCALL=TRUE, caption="test extend: extend=0 (reference plot)") plotmo(a, nresponse=1, extend=.5, pt.col=2, SHOWCALL=TRUE, caption="test extend: extend=.5") plotmo(a, nresponse=1, degree1=0, extend=.2, pt.col=2, SHOWCALL=TRUE) # nothing to plot a <- earth(survived~pclass+age, data=etitanic, degree=2) # expect warning: extend=.5 not degree2 plots plotmo(a, extend=.5, pt.col=2, SHOWCALL=TRUE, caption="test extend: extend=.5") # intercept only models dopar(2, 2, caption = "intercept-only models") set.seed(1) x <- 1:10 y <- runif(length(x)) earth.intercept.only <- earth(x, y) plotmo(earth.intercept.only, do.par=FALSE, main="earth intercept-only model") plotmo(earth.intercept.only, do.par=FALSE, col.response=1, pt.pch=20) # TODO following draws a plot but it shouldn't (very minor bug because int-only model with a bad degree1 spec) plotmo(earth.intercept.only, do.par=FALSE, degree1=3) # expect warning: 'degree1' specified but no degree1 plots plotmo(earth.intercept.only, do.par=FALSE, degree1=0) # expect warning: plotmo: nothing to plot library(rpart) rpart.intercept.only <- rpart(y~x) plotmo(rpart.intercept.only, do.par=FALSE, main="rpart.plot intercept-only model") plotmo(rpart.intercept.only, do.par=FALSE, degree1=0) par(org.par) # nrug argument par(mfrow=c(3,3), mar=c(3,3,3,1), mgp=c(1.5, 0.5, 0)) mod.nrug <- earth(survived~age, data=etitanic) set.seed(2016) plotmo(mod.nrug, do.par=0, nrug=-1, main="nrug=-1") plotmo(mod.nrug, do.par=0, nrug=TRUE, main="nrug=TRUE") plotmo(mod.nrug, do.par=0, nrug=10, rug.col=2, main="nrug=10, rug.col=2") plotmo(mod.nrug, do.par=0, nrug=5, rug.col=2, rug.lwd=2, main="nrug=5, rug.col=2, rug.lwd=2") plotmo(mod.nrug, do.par=0, nrug="density", main="nrug=\"density\"") plotmo(mod.nrug, do.par=0, nrug="density", density.col=2, density.lwd=2, main="nrug=\"density\"\ndensity.col=2, density.lwd=2") plotmo(mod.nrug, do.par=0, nrug="density", density.adj=.2, density.col=1, main="nrug=\"density\"\ndensity.adj=.2, density.col=1") par(org.par) # a <- earth(ozone1[,3]~ozone1[,1]+ozone1[,2]+ozone1[,4]+ozone1[,5]+ozone1[,6], data=ozone1) # # TODO fails: actual.nrows=330 expected.nrows=50 fitted.nrows=330 # plotmo(a) # # TODO following fails in plotmo with # # Error : get.earth.x from model.matrix.earth from predict.earth: x has 2 columns, expected 4 to match: 1 2 3 Girth # a <- earth(Volume~poly(Height, degree=3)+Girth, data=trees, subset=4:23, linpreds=TRUE) # plotmo(a, trace=-1, do.par=FALSE, caption="all three rows should be the same") source("test.epilog.R") plotmo/inst/slowtests/test.partdep.bat0000755000176200001440000000150714563571565017744 0ustar liggesusers@rem test.partdep.bat: partdep tests for plotmo and plotres @echo test.partdep.bat @"C:\PROGRA~1\R\R-4.3.2\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.partdep.R @if %errorlevel% equ 0 goto good1: @echo R returned errorlevel %errorlevel%, see test.partdep.Rout: @echo. @tail test.partdep.Rout @echo test.partdep.R @exit /B 1 :good1 mks.diff test.partdep.Rout test.partdep.Rout.save @if %errorlevel% equ 0 goto good2: @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.partdep.save.ps @exit /B 1 :good2 @rem test.partdep.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.partdep.save.ps @if %errorlevel% equ 0 goto good3: @echo === Files are different === @exit /B 1 :good3 @rm -f test.partdep.Rout @rm -f Rplots.ps @exit /B 0 plotmo/inst/slowtests/test.gbm.Rout.save0000644000176200001440000006247314563614021020161 0ustar liggesusers> # test.gbm.R: gbm tests for plotmo and plotres > > source("test.prolog.R") > library(gbm) Loaded gbm 2.1.9 This version of gbm is no longer under development. Consider transitioning to gbm3, https://github.com/gbm-developers/gbm3 > library(rpart.plot) # for ptitanic, want data with NAs for testing Loading required package: rpart > library(plotmo) Loading required package: Formula Loading required package: plotrix > data(ptitanic) > > cat("--- distribution=\"gaussian\", formula interface ----------------------------------\n") --- distribution="gaussian", formula interface ---------------------------------- > > set.seed(2016) > ptit <- ptitanic[sample(1:nrow(ptitanic), size=70), ] # small data for fast test > set.seed(2016) > # # TODO bug in gbm: following causes error: survived is not of type numeric, ordered, or factor > # ptit$survived <- ptit$survived == "survived" > ptit <- ptit[!is.na(ptit$age), ] > train.frac <- .8 > set.seed(2016) > gbm.gaussian <- gbm(age~., data=ptit, train.frac=train.frac, + distribution="gaussian", + n.trees=50, shrinkage=.1, keep.data=FALSE) > expect.err(try(plotres(gbm.gaussian)), "use keep.data=TRUE in the call to gbm") Error : use keep.data=TRUE in the call to gbm (cannot determine the variable importances) Got expected error from try(plotres(gbm.gaussian)) > set.seed(2016) > gbm.gaussian <- gbm(age~., data=ptit, train.frac=train.frac, + distribution="gaussian", + n.trees=50, shrinkage=.1) > par(mfrow=c(2,2), mar=c(3,3,4,1)) > w1 <- plotres(gbm.gaussian, which=1, do.par=FALSE, w1.smooth=TRUE, + w1.main="gbm.gaussian") > cat("w1 plot for gbm.gaussian returned (w1.smooth=TRUE):\n") w1 plot for gbm.gaussian returned (w1.smooth=TRUE): > print(w1) train test CV OOB 50 1 0 1 > plot(0, 0) # dummy plot > w3 <- plotres(gbm.gaussian, which=3, do.par=FALSE, info=TRUE, + smooth.col=0, col=ptit$sex, # ylim=c(-40,40), + wmain="nresponse=1") > # compare to manual residuals > iused <- 1:(train.frac * nrow(ptit)) > y <- ptit$age[iused] > n.trees <- plotmo:::gbm.n.trees(gbm.gaussian) > # TODO following fails in the new version of gbm (version 2.2) (you have to provide newdata) > # yhat <- predict(gbm.gaussian, type="response", n.trees=n.trees) > yhat <- predict(gbm.gaussian, newdata=ptit, type="response", n.trees=n.trees) > yhat <- yhat[iused] > plot(yhat, y - yhat, + col=ptit$sex[iused], main="manual gaussian residuals", + pch=20, ylim=c(-40,40)) > abline(h=0, col="gray") > stopifnot(all(yhat == w3$x)) > stopifnot(all(y - yhat == w3$y)) > par(org.par) > > w1 <- plotres(gbm.gaussian, predict.n.trees=13, w1.grid.col=1, trace=1, SHOWCALL=TRUE, + w1.smooth=TRUE, + w1.main="predict.n.trees=13 w1.grid.col=1") importance: survived pclass parch sibsp sex stats::residuals(object=gbm.object, type="response") residuals() was unsuccessful, will use predict() instead stats::predict(gbm.object, data.frame[3,5], type="response", n.trees=13) stats::fitted(object=gbm.object) fitted() was unsuccessful, will use predict() instead plot_gbm(gbm.object, main="predict.n.trees=13 w1.grid.col=1", n.trees=13, grid.col=1, smooth=TRUE) training rsq 0.07 > cat("second w1 plot for gbm.gaussian returned (w1.smooth=TRUE):\n") second w1 plot for gbm.gaussian returned (w1.smooth=TRUE): > print(w1) train test CV OOB 50 1 0 1 > plotmo(gbm.gaussian, trace=-1, SHOWCALL=TRUE) > # plotmo(gbm.gaussian, trace=-1, all1=TRUE, SHOWCALL=TRUE) > # plotmo(gbm.gaussian, trace=-1, all2=TRUE, SHOWCALL=TRUE) > > # test color argument > par(mfrow=c(2,2), mar=c(3,3,4,1)) > plotres(gbm.gaussian, which=1) > title("test color argument") > plotres(gbm.gaussian, which=1, w1.col=c(1,2,3,0)) > plotres(gbm.gaussian, which=1, w1.col=c(1,0,0,4), w1.legend.x=40, w1.legend.y=.3) > plotres(gbm.gaussian, which=1, w1.col=c(2,3,4,1), w1.legend.x="topright") > par(org.par) > > par(mfrow=c(2,2), mar=c(3,3,4,1)) > plot_gbm(gbm.gaussian) > title("test plot_gbm") > w1 <- plot_gbm(gbm.gaussian, col=c(1,2,3,0), grid.col=1, smooth=TRUE, + main="col=c(1,2,3,0), grid.col=1") > cat("third w1 plot for gbm.gaussian returned (smooth=TRUE):\n") third w1 plot for gbm.gaussian returned (smooth=TRUE): > print(w1) train test CV OOB 50 1 0 1 > par(org.par) > > # test xlim and ylim > par(mfrow=c(2,3), mar=c(3,3,4,1)) > plot_gbm(gbm.gaussian, main="test xlim and ylim default") > plot_gbm(gbm.gaussian, ylim=NULL, main="ylim=NULL") > plot_gbm(gbm.gaussian, xlim=c(5, 50), main="xlim=c(5, 50)") > plot_gbm(gbm.gaussian, ylim=c(100, 250), main="ylim=c(100, 250)") > plot_gbm(gbm.gaussian, xlim=c(10, 25), + ylim=c(150, 170), main="xlim=c(10, 25), ylim=c(150, 170)") > plot_gbm(gbm.gaussian, xlim=c(-10, 40), ylim=c(-10, 300), legend.x=NA, + main="xlim=c(-10, 40), ylim=c(-10, 300)\nlegend.x=NA") > par(org.par) > > # test the smooth argument > par(mfrow=c(3,3), mar=c(3,3,4,1)) > imin <- plot_gbm(gbm.gaussian, main="smooth=default") > imin.default <- imin > cat("smooth=default imin=c(", imin[1], ",", imin[2], ",", imin[3], ",", imin[4], ")\n", sep="") smooth=default imin=c(50,2,0,1) > > imin <- plot_gbm(gbm.gaussian, smooth=c(1,0,0,0), main="smooth=c(1,0,0,0)") > cat("smooth=c(1,0,0,0) imin=c(", imin[1], ",", imin[2], ",", imin[3], ",", imin[4], ")\n", sep="") smooth=c(1,0,0,0) imin=c(50,2,0,6) > > imin <- plot_gbm(gbm.gaussian, smooth=c(0,1,0,0), main="smooth=c(0,1,0,0)") > cat("smooth=c(0,1,0,0) imin=c(", imin[1], ",", imin[2], ",", imin[3], ",", imin[4], ")\n", sep="") smooth=c(0,1,0,0) imin=c(50,1,0,6) > > imin <- plot_gbm(gbm.gaussian, smooth=c(0,0,1,0), main="smooth=c(0,0,1,0)") > cat("smooth=c(0,0,1,0) imin=c(", imin[1], ",", imin[2], ",", imin[3], ",", imin[4], ")\n", sep="") smooth=c(0,0,1,0) imin=c(50,2,0,6) > > imin <- plot_gbm(gbm.gaussian, smooth=c(0,0,0,1), main="smooth=c(0,0,0,1)\nsame as default") > cat("smooth=c(0,0,0,1) imin=c(", imin[1], ",", imin[2], ",", imin[3], ",", imin[4], ")\n", sep="") smooth=c(0,0,0,1) imin=c(50,2,0,1) > > imin <- plot_gbm(gbm.gaussian, smooth=c(0,0,0,0), main="smooth=c(0,0,0,0)") > cat("smooth=c(0,0,0,0) imin=c(", imin[1], ",", imin[2], ",", imin[3], ",", imin[4], ")\n", sep="") smooth=c(0,0,0,0) imin=c(50,2,0,6) > > imin <- plot_gbm(gbm.gaussian, smooth=c(0,0,1,1), main="smooth=c(0,0,1,1)") > cat("smooth=c(0,0,1,1) imin=c(", imin[1], ",", imin[2], ",", imin[3], ",", imin[4], ")\n", sep="") smooth=c(0,0,1,1) imin=c(50,2,0,1) > > imin <- plot_gbm(gbm.gaussian, smooth=1, main="smooth=1") # gets recycled > cat("smooth=1 imin=c(", imin[1], ",", imin[2], ",", imin[3], ",", imin[4], ")\n", sep="") smooth=1 imin=c(50,1,0,1) > imin.smooth <- imin > > imin.noplot <- plot_gbm(gbm.gaussian, col=0) # will not be plotted > print(imin.default) train test CV OOB 50 2 0 1 > print(imin.noplot) train test CV OOB 50 2 0 1 > stopifnot(identical(imin.default, imin.noplot)) > > imin.noplot <- plot_gbm(gbm.gaussian, col=0, smooth=1) # will not be plotted > print(imin.smooth) train test CV OOB 50 1 0 1 > print(imin.noplot) train test CV OOB 50 1 0 1 > stopifnot(identical(imin.smooth, imin.noplot)) > > par(org.par) > > cat("--- distribution=\"gaussian\", glm.fit interface ----------------------------------\n") --- distribution="gaussian", glm.fit interface ---------------------------------- > > set.seed(2016) > ptit <- ptitanic[sample(1:nrow(ptitanic), size=70), ] > set.seed(2016) > ptit <- ptit[!is.na(ptit$age), ] > train.frac <- .8 > set.seed(2016) > gbm.gaussian.fit <- gbm.fit(ptit[,-4], ptit[,4], nTrain=floor(train.frac * nrow(ptit)), + distribution="gaussian", verbose=FALSE, + n.trees=50, shrinkage=.1) > par(mfrow=c(2,2), mar=c(3,3,4,1)) > w1 <- plotres(gbm.gaussian.fit, which=1, do.par=FALSE, w1.smooth=TRUE, + w1.main="gbm.gaussian.fit") > > cat("w1 plot for gbm.gaussian.fit returned (w1.smooth=TRUE):\n") w1 plot for gbm.gaussian.fit returned (w1.smooth=TRUE): > print(w1) train test CV OOB 50 1 0 1 > > plot(0, 0) # dummy plot > > w3 <- plotres(gbm.gaussian.fit, which=3, do.par=FALSE, info=TRUE, trace=0, + smooth.col=0, col=ptit$sex, # ylim=c(-40,40), + wmain="nresponse=1") > > # compare to manual residuals > iused <- 1:(train.frac * nrow(ptit)) > y.fit <- ptit$age[iused] > n.trees <- plotmo:::gbm.n.trees(gbm.gaussian.fit) > # TODO following fails in the new version of gbm (version 2.2) (you have to provide newdata) > # yhat.fit <- predict(gbm.gaussian.fit, type="response", n.trees=n.trees) > yhat.fit <- predict(gbm.gaussian.fit, newdata=ptit[,-4], type="response", n.trees=n.trees) > yhat.fit <- yhat.fit[iused] > # plot(yhat.fit, y.fit - yhat.fit, > # col=ptit$sex[iused], main="manual gaussian residuals\n(TODO gbm.fit don't match)", > # pch=20, ylim=c(-40,40)) > # abline(h=0, col="gray") > # --- TODO known issue, these fail --- > # compare to formual interface > # stopifnot(all(yhat.fit == yhat)) > stopifnot(all(y.fit == y)) > # # sanity check > # stopifnot(all(yhat.fit == w3$x)) > # stopifnot(all(y.fit - yhat.fit == w3$y.fit)) > plotmo(gbm.gaussian.fit, trace=-1, SHOWCALL=TRUE) > par(org.par) > > cat("--- distribution=\"laplace\" ----------------------------------\n") --- distribution="laplace" ---------------------------------- > > set.seed(2016) > ptit <- ptitanic[sample(1:nrow(ptitanic), size=70), ] > ptit <- ptit[!is.na(ptit$age), ] > ptit$survived <- ptit$parch <- ptit$sex <- NULL > train.frac <- .8 > set.seed(2016) > gbm.laplace <- gbm(age~., data=ptit, train.frac=train.frac, + distribution="laplace", + n.trees=100, shrinkage=.1) > par(mfrow=c(2,2), mar=c(3,3,4,1)) > w1 <- plotres(gbm.laplace, which=1:2, do.par=FALSE, w1.smooth=TRUE, + w1.main="gbm.laplace") > > cat("w1 plot for gbm.laplace returned (w1.smooth=TRUE):\n") w1 plot for gbm.laplace returned (w1.smooth=TRUE): > print(w1) train test CV OOB 75 100 0 1 > > w3 <- plotres(gbm.laplace, which=3, do.par=FALSE, info=TRUE) > > # compare to manual residuals > iused <- 1:(train.frac * nrow(ptit)) > y <- ptit$age[iused] > n.trees <- plotmo:::gbm.n.trees(gbm.laplace) > # TODO following fails in the new version of gbm (version 2.2) (you have to provide newdata) > # yhat <- predict(gbm.laplace, type="response", n.trees=n.trees) > yhat <- predict(gbm.laplace, newdata=ptit, type="response", n.trees=n.trees) > yhat <- yhat[iused] > plot(yhat, y - yhat, + main="manual laplace residuals", + pch=20, ylim=c(-40,40)) > abline(h=0, col="gray") > stopifnot(all(yhat == w3$x)) > stopifnot(all(y - yhat == w3$y)) > plotmo(gbm.laplace, trace=-1, SHOWCALL=TRUE) > par(org.par) > > # # TODO commented out because gives random slightly different results per invocation > # cat("--- distribution=\"tdist\" ----------------------------------\n") > # > # set.seed(2016) > # ptit <- ptitanic[sample(1:nrow(ptitanic), size=70), ] > # ptit <- ptit[!is.na(ptit$age), ] > # ptit$survived <- ptit$parch <- ptit$sex <- NULL > # train.frac <- .8 > # set.seed(2016) > # gbm.tdist <- gbm(age~., data=ptit, train.frac=train.frac, > # distribution="tdist", > # n.trees=100, shrinkage=.1) > # par(mfrow=c(2,2), mar=c(3,3,4,1)) > # set.seed(2016) > # w1 <- plotres(gbm.tdist, which=1:2, do.par=FALSE, > # w1.main="gbm.tdist") > # > # cat("w1 plot for gbm.tdist returned (w1.smooth=default):\n") > # print(w1) > # > # set.seed(2016) > # w3 <- plotres(gbm.tdist, which=3, do.par=FALSE, info=TRUE) > # > # # compare to manual residuals > # iused <- 1:(train.frac * nrow(ptit)) > # y <- ptit$age[iused] > # n.trees <- plotmo:::gbm.n.trees(gbm.tdist) > # # TODO following fails in the new version of gbm (version 2.2) (you have to provide newdata) > # # yhat <- predict(gbm.tdist, type="response", n.trees=n.trees) > # yhat <- predict(gbm.tdist, newdata=ptit, type="response", n.trees=n.trees) > # yhat <- yhat[iused] > # plot(yhat, y - yhat, > # main="manual tdist residuals", > # pch=20, ylim=c(-40,40)) > # abline(h=0, col="gray") > # stopifnot(all(yhat == w3$x)) > # stopifnot(all(y - yhat == w3$y)) > # plotmo(gbm.tdist, trace=-1, SHOWCALL=TRUE) > # par(org.par) > > cat("--- distribution=\"bernoulli\" ----------------------------------\n") --- distribution="bernoulli" ---------------------------------- > > set.seed(2016) > ptit <- ptitanic[sample(1:nrow(ptitanic), size=80), ] > ptit$survived <- ptit$survived == "survived" > temp <- ptit$pclass # put pclass at the end so can check ordering of importances > ptit$pclass <- NULL > ptit$pclass <- factor(as.numeric(temp), labels=c("first", "second", "third")) > train.frac <- .9 > set.seed(2016) > gbm.bernoulli <- gbm(survived~., data=ptit, train.frac=train.frac, + distribution="bernoulli", + n.trees=100, shrinkage=.1, cv.folds=3) > par(mfrow=c(2,2)) > par(mar=c(3.5, 3, 2, 0.5)) # small margins and text to pack figs in > par(mgp=c(1.5, .4, 0)) # squash axis annotations > w1 <- plotres(gbm.bernoulli, which=c(1,4), + col=ptit$survived+2, trace=0, do.par=FALSE, + w1.main="gbm.bernoulli") > cat("w1 plot for gbm.bernoulli with cv.folds=3 returned:\n") w1 plot for gbm.bernoulli with cv.folds=3 returned: > print(w1) train test CV OOB 100 24 99 16 > > w3 <- plotres(gbm.bernoulli, which=3, predict.n.trees=40, + ylim=c(-.6, 1), xlim=c(.1, .6), + col=ptit$sex, trace=0, do.par=FALSE, smooth.col=0) > > # compare to manual residuals > iused <- 1:(train.frac * nrow(ptit)) > y <- ptit$survived[iused] > # TODO following fails in the new version of gbm (version 2.2) (you have to provide newdata) > # yhat <- predict(gbm.bernoulli, type="response", n.trees=40) > yhat <- predict(gbm.bernoulli, newdata=ptit, type="response", n.trees=40) > yhat <- yhat[iused] > plot(yhat, y - yhat, col=ptit$sex, + main="manual bernoulli residuals", pch=20, cex=1, + ylim=c(-.6, 1), xlim=c(.1, .6)) > abline(h=0, col="gray") > stopifnot(all(yhat == w3$x)) > stopifnot(all(y - yhat == w3$y)) > par(org.par) > > plotmo(gbm.bernoulli, do.par=2) plotmo grid: sex age sibsp parch pclass male 27 0 0 third > print(summary(gbm.bernoulli)) # will also plot var rel.inf age age 32.307096 sex sex 29.921593 pclass pclass 17.323084 parch parch 13.277759 sibsp sibsp 7.170468 > par(org.par) > > cat("--- distribution=\"huberized\" ----------------------------------\n") --- distribution="huberized" ---------------------------------- > > set.seed(2016) > ptit <- ptitanic[sample(1:nrow(ptitanic), size=100), ] > ptit$survived <- ptit$survived == "survived" > ptit$sibsp <- ptit$parch <- ptit$pclass <- NULL > train.frac <- 1 > set.seed(2016) > gbm.huberized <- gbm(survived~., data=ptit, train.frac=train.frac, + distribution="huberized", + n.trees=200, shrinkage=.1) > par(mfrow=c(2,2)) > par(mar=c(3.5, 3, 2, 0.5)) # small margins and text to pack figs in > par(mgp=c(1.5, .4, 0)) # squash axis annotations > w1 <- plotres(gbm.huberized, which=c(1,4), + col=ptit$survived+2, trace=0, do.par=FALSE, + w1.main="gbm.huberized") Warning: plot_gbm: cannot plot OOB curve (it has some non-finite values) > cat("w1 plot for gbm.huberized returned (smooth=default):\n") w1 plot for gbm.huberized returned (smooth=default): > print(w1) train test CV OOB 169 0 0 0 > > # TODO huberized residuals look weird > w3 <- plotres(gbm.huberized, which=3, predict.n.trees=40, + col=ptit$sex, trace=0, do.par=FALSE, smooth.col=0) > > # compare to manual residuals > iused <- 1:(train.frac * nrow(ptit)) > y <- ptit$survived[iused] > # TODO following fails in the new version of gbm (version 2.2) (you have to provide newdata) > # yhat <- predict(gbm.huberized, type="response", n.trees=40) > yhat <- predict(gbm.huberized, newdata=ptit, type="response", n.trees=40) > yhat <- yhat[iused] > plot(yhat, y - yhat, col=ptit$sex, ylim=c(-2.5, 2.5), + main="manual huberized residuals", pch=20) > abline(h=0, col="gray") > stopifnot(all(yhat == w3$x)) > stopifnot(all(y - yhat == w3$y)) > par(org.par) > > plotmo(gbm.huberized, do.par=2) plotmo grid: sex age male 28 > print(summary(gbm.huberized)) # will also plot var rel.inf age age 68.12613 sex sex 31.87387 > par(org.par) > > cat("--- distribution=\"adaboost\" ----------------------------------\n") --- distribution="adaboost" ---------------------------------- > > set.seed(2016) > ptit <- ptitanic[sample(1:nrow(ptitanic), size=100), ] > ptit$survived <- ptit$survived == "survived" > ptit$sibsp <- ptit$parch <- ptit$pclass <- NULL > train.frac <- .8 > set.seed(2016) > gbm.adaboost <- gbm(survived~., data=ptit, train.frac=train.frac, + distribution="adaboost", + n.trees=150, shrinkage=.01) > par(mfrow=c(2,2)) > par(mar=c(3.5, 3, 2, 0.5)) # small margins and text to pack figs in > par(mgp=c(1.5, .4, 0)) # squash axis annotations > w1 <- plotres(gbm.adaboost, which=c(1,4), + col=ptit$survived+2, trace=0, do.par=FALSE, + w1.main="gbm.adaboost") > cat("w1 plot for gbm.adaboost returned (smooth=default):\n") w1 plot for gbm.adaboost returned (smooth=default): > print(w1) train test CV OOB 150 150 0 117 > > w3 <- plotres(gbm.adaboost, which=3, predict.n.trees=40, + col=ptit$sex, trace=0, do.par=FALSE, smooth.col=0) > > # compare to manual residuals > iused <- 1:(train.frac * nrow(ptit)) > y <- ptit$survived[iused] > # TODO following fails in the new version of gbm (version 2.2) (you have to provide newdata) > # yhat <- predict(gbm.adaboost, type="response", n.trees=40) > yhat <- predict(gbm.adaboost, newdata=ptit, type="response", n.trees=40) > yhat <- yhat[iused] > plot(yhat, y - yhat, col=ptit$sex, + main="manual adaboost residuals", pch=20) > abline(h=0, col="gray") > stopifnot(all(yhat == w3$x)) > stopifnot(all(y - yhat == w3$y)) > par(org.par) > > plotmo(gbm.adaboost, do.par=2) plotmo grid: sex age male 27.5 > print(summary(gbm.adaboost)) # will also plot var rel.inf sex sex 75.09661 age age 24.90339 > par(org.par) > > # test gbm multinomial model, also test very small number of trees in plot_gbm > > data(iris) > set.seed(2016) > gbm.iris <- gbm(Species~., data=iris, distribution="multinomial", n.tree=5) Warning: Setting `distribution = "multinomial"` is ill-advised as it is currently broken. It exists only for backwards compatibility. Use at your own risk. > expect.err(try(plotres(gbm.iris)), + "gbm distribution=\"multinomial\" is not yet supported") Error : gbm distribution="multinomial" is not yet supported (A direct call to plot_gbm may work) Got expected error from try(plotres(gbm.iris)) > expect.err(try(plotmo(gbm.iris)), + "gbm distribution=\"multinomial\" is not yet supported") Error : gbm distribution="multinomial" is not yet supported (A direct call to plot_gbm may work) Got expected error from try(plotmo(gbm.iris)) > plot_gbm(gbm.iris) > > # TODO following fails in the new version of gbm (version 2.2) > # (distribution "multinomial" is no longer supported) > # > # cat("--- distribution=\"multinomial\" ----------------------------------\n") > # > # set.seed(2016) > # ptit <- ptitanic[sample(1:nrow(ptitanic), size=500), ] > # set.seed(2016) > # gbm.multinomial <- gbm(pclass~., > # data=ptit, train.frac=.7, > # distribution="multinomial", > # n.trees=100, shrinkage=.1) > # > # w1 <- plot_gbm(gbm.multinomial, main="gbm.multinomial", smooth=T) > # cat("plot_gbm for gbm.multinomial returned (smooth=TRUE):\n") > # print(w1) > # > # expect.err(try(plotres(gbm.multinomial)), > # "gbm distribution=\"multinomial\" is not yet supported") > # > # expect.err(try(plotmo(gbm.multinomial)), > # "gbm distribution=\"multinomial\" is not yet supported") > > # cat("--- gbmt distribution=\"Gaussian\", formula interface ----------------------------------\n") > # > # set.seed(2016) > # ptit <- ptitanic[sample(1:nrow(ptitanic), size=70), ] # small data for fast test > # set.seed(2016) > # # # TODO bug in gbm: following causes error: survived is not of type numeric, ordered, or factor > # # ptit$survived <- ptit$survived == "survived" > # ptit <- ptit[!is.na(ptit$age), ] > # # TODO change this to build same model as gbm.gaussian > # train_params <- > # training_params(num_trees = 50, > # shrinkage = 0.1, > # bag_fraction = 0.5, > # num_train = round(.8 * nrow(ptit))) > # par(mfrow=c(2,2), mar=c(3,3,4,1)) > # set.seed(2016) > # gbmt.gaussian <- gbmt(age~., data=ptit, > # distribution=gbm_dist("Gaussian"), > # train_params = train_params, > # is_verbose = FALSE) > # expect.err(try(plotres(gbmt.gaussian)), > # "use keep.data=TRUE in the call to gbm") > # set.seed(2016) > # gbmt.gaussian <- gbmt(age~., data=ptit, > # distribution=gbm_dist("Gaussian"), > # train_params = train_params, > # is_verbose = FALSE, keep_gbm_data=TRUE) > # w1 <- plotres(gbmt.gaussian, which=1, do.par=FALSE, w1.smooth=TRUE, > # w1.main="gbmt.gaussian") > # cat("w1 plot for gbmt.gaussian returned (w1.smooth=TRUE):\n") > # print(w1) > # plot(0, 0) # dummy plot > # set.seed(2016) > # w3 <- plotres(gbmt.gaussian, which=3, do.par=FALSE, info=TRUE, > # smooth.col=0, col=ptit$sex, # ylim=c(-40,40), > # wmain="nresponse=1") > # > # # compare to manual residuals > # iused <- 1:(train.frac * nrow(ptit)) > # y <- ptit$age[iused] > # n.trees <- plotmo:::gbm.n.trees(gbmt.gaussian) > # # TODO following fails in the new version of gbm (version 2.2) (you have to provide newdata) > # # yhat <- predict(gbmt.gaussian, type="response", n.trees=n.trees) > # yhat <- predict(gbmt.gaussian, newdata=ptit, type="response", n.trees=n.trees) > # yhat <- yhat[iused] > # plot(yhat, y - yhat, > # col=ptit$sex[iused], main="manual gaussian residuals", > # pch=20, ylim=c(-40,40)) > # abline(h=0, col="gray") > # stopifnot(all(yhat == w3$x)) > # stopifnot(all(y - yhat == w3$y)) > # par(org.par) > # > # w1 <- plotres(gbmt.gaussian, predict.n.trees=13, w1.grid.col=1, trace=1, SHOWCALL=TRUE, > # w1.smooth=TRUE, > # w1.main="predict.n.trees=13 w1.grid.col=1") > # cat("second w1 plot for gbmt.gaussian returned (w1.smooth=TRUE):\n") > # print(w1) > # plotmo(gbmt.gaussian, trace=-1, SHOWCALL=TRUE) > # > # par(org.par) > # > # cat("--- distribution=\"bernoulli\" ----------------------------------\n") > # > # set.seed(2016) > # ptit <- ptitanic[sample(1:nrow(ptitanic), size=80), ] > # ptit$survived <- ptit$survived == "survived" > # temp <- ptit$pclass # put pclass at the end so can check ordering of importances > # ptit$pclass <- NULL > # ptit$pclass <- factor(as.numeric(temp), labels=c("first", "second", "third")) > # # TODO change this to build same model as gbm.bernoulli > # train_params <- > # training_params(num_trees = 100, > # shrinkage = 0.1, > # bag_fraction = 0.5, > # num_train = round(.8 * nrow(ptit))) > # set.seed(2016) > # gbmt.bernoulli <- gbmt(survived~., data=ptit, > # distribution=gbm_dist("Bernoulli"), > # train_params = train_params, > # cv_folds = 3, > # is_verbose = FALSE, keep_gbm_data=TRUE) > # par(mfrow=c(2,2)) > # par(mar=c(3.5, 3, 2, 0.5)) # small margins and text to pack figs in > # par(mgp=c(1.5, .4, 0)) # squash axis annotations > # w1 <- plotres(gbmt.bernoulli, which=c(1,4), > # col=ptit$survived+2, trace=0, do.par=FALSE, > # w1.main="gbmt.bernoulli") > # cat("w1 plot for gbmt.bernoulli with cv.folds=3 returned:\n") > # print(w1) > # > # w3 <- plotres(gbmt.bernoulli, which=3, predict.n.trees=40, > # ylim=c(-.6, 1), xlim=c(.1, .6), > # col=ptit$sex, trace=0, do.par=FALSE, smooth.col=0) > # > # # compare to manual residuals > # iused <- 1:(train.frac * nrow(ptit)) > # y <- ptit$survived[iused] > # # TODO following fails in the new version of gbm (version 2.2) (you have to provide newdata) > # # yhat <- predict(gbmt.bernoulli, type="response", n.trees=40) > # yhat <- predict(gbmt.bernoulli, newdata=ptit, type="response", n.trees=40) > # yhat <- yhat[iused] > # plot(yhat, y - yhat, col=ptit$sex, > # main="manual bernoulli residuals", pch=20, cex=1, > # ylim=c(-.6, 1), xlim=c(.1, .6)) > # abline(h=0, col="gray") > # stopifnot(all(yhat == w3$x)) > # stopifnot(all(y - yhat == w3$y)) > # par(org.par) > # > # plotmo(gbmt.bernoulli, do.par=2) > # print(summary(gbmt.bernoulli)) # will also plot > # par(org.par) > > source("test.epilog.R") plotmo/inst/slowtests/test.center.Rout.save0000644000176200001440000001277714563614021020676 0ustar liggesusers> # test.center.R: test plotmo's center and ndiscrete args > # Stephen Milborrow, Berea Apr 2011 > > source("test.prolog.R") > library(rpart.plot) Loading required package: rpart > library(plotmo) Loading required package: Formula Loading required package: plotrix > library(earth) > data(etitanic) > > et <- etitanic[, c("survived", "pclass", "sex", "age")] > et$pclassn <- as.numeric(et$pclass) > et <- et[c(30:80,330:380,630:680), ] > > par(mfrow=c(3,3)) > par(mar=c(3, 3.5, 3, 0.5)) > par(mgp=c(1.5, .5, 0)) > > ndiscrete <- 0 > > #--- row 1 > > set.seed(844) > a1 <- lm(survived~pclassn+sex, data=et) > plotmo(a1, all2=T, do.par=F, degree1=NA, degree2=1, center=TRUE, clip=F, + main="a1: survived~pclassn+sex\n(default ndiscrete)", + pt.col=ifelse(et$survived, "black", "red"), + pt.pch=".", pt.cex=2.5, lab=c(1,1,1)) > > set.seed(844) > plotmo(a1, degree1=1, all2=T, degree2=0, do.par=F, xflip=T, center=TRUE, clip=F, + grid.levels=list(sex="f"), ndiscrete=ndiscrete, + main="pclassn with sex=\"female\"", + smooth.col="lightblue", smooth.lwd=2, + pt.col=ifelse(et$survived, "black", "red"), + pt.pch=".", pt.cex=2.5) plotmo grid: pclassn sex 2 female > > set.seed(844) > plotmo(a1, degree1=1, all2=T, degree2=0, do.par=F, xflip=T, center=TRUE, clip=F, + grid.levels=list(sex="m"), ndiscrete=ndiscrete, + main="pclassn with sex=\"male\"", + smooth.col="lightblue", smooth.lwd=2, + pt.col=ifelse(et$survived, "black", "red"), + pt.pch=".", pt.cex=2.5) plotmo grid: pclassn sex 2 male > > #--- row 2 > > a2 <- lm(survived~pclassn*sex, data=et) > set.seed(844) > plotmo(a2, all2=T, do.par=F, degree2=1, degree1=0, center=TRUE, clip=F, + main="a2: survived~pclassn*sex\n(default ndiscrete)") > > set.seed(844) > plotmo(a2, degree1=1, all2=T, degree2=0, do.par=F, xflip=T, center=TRUE, clip=F, + grid.levels=list(sex="f"), ndiscrete=ndiscrete, + main="pclassn with sex=\"female\"", + smooth.col="lightblue", smooth.lwd=2, + pt.col=ifelse(et$survived, "black", "red"), + pt.pch=".", pt.cex=2.5) plotmo grid: pclassn sex 2 female > > set.seed(844) > plotmo(a2, degree1=1, all2=T, degree2=0, do.par=F, xflip=T, center=TRUE, clip=F, + grid.levels=list(sex="m"), ndiscrete=ndiscrete, + main="pclassn with sex=\"male\"", + smooth.col="lightblue", smooth.lwd=2, + pt.col=ifelse(et$survived, "black", "red"), + pt.pch=".", pt.cex=2.5) plotmo grid: pclassn sex 2 male > > #--- row 3 > > par(mfg=c(3,2)) > a3 <- lm(survived~pclassn, data=et) > set.seed(844) > plotmo(a3, do.par=F, xflip=T, center=TRUE, clip=F, ndiscrete=ndiscrete, + main="a3: survived~pclassn", degree1.col=1, + smooth.col="lightblue", smooth.lwd=2, + pt.col=ifelse(et$survived, "black", "red"), + pt.pch=".", pt.cex=2.5) > > plot(0, 0, type="n", axes=FALSE, xlab="", ylab="") > > #--- row 1 > > # note that this is an example of a model that gets generated differently > # with Scale.y=TRUE vs Scale.y=FALSE (although not shown here) > a4 <- earth(survived~pclassn+age, data=et, degree=2) > > set.seed(844) > plotmo(a4, do.par=F, center=TRUE, clip=F, ylim=c(-.6,.7), + main="earth: survived~pclassn+age\n(default ndiscrete)", degree1=0, all2=T) > > set.seed(844) > plotmo(a4, do.par=F, xflip=F, all1=T, center=TRUE, clip=F, ylim=c(-.6,.7), + main="a4, age with pclassn=1st", ndiscrete=ndiscrete, + degree2=0, degree1=2, + # grid.levels=list(pclassn="1st"), + grid.levels=list(pclassn=1), + smooth.col="lightblue", smooth.lwd=2, + pt.col=ifelse(et$survived, "black", "red"), + pt.pch=".", pt.cex=2.5) plotmo grid: pclassn age 1 29 > > set.seed(844) > plotmo(a4, do.par=F, xflip=F, all1=T, center=TRUE, clip=F, ylim=c(-.6,.7), + main="age with pclassn=3rd", ndiscrete=ndiscrete, + degree2=0, degree1=2, + grid.levels=list(pclassn=3), + smooth.col="lightblue", smooth.lwd=2, + pt.col=ifelse(et$survived, "black", "red"), + pt.pch=".", pt.cex=2.5) plotmo grid: pclassn age 3 29 > > #--- row 2 > > set.seed(844) > plotmo(a4, do.par=F, center=TRUE, clip=F, type2="im", + main="a4 earth: survived~pclassn+age\n(default ndiscrete)", degree1=0, all2=T, yflip=T, + pt.col=ifelse(et$survived, 1, "red"), + image.col=gray(seq(6, 10, length=10) / 10), xflip=T, + pt.pch=".", pt.cex=2) > > set.seed(844) > plotmo(a4, do.par=F, xflip=F, all1=T, center=TRUE, clip=F, + main="pclassn with age=10", ndiscrete=ndiscrete, + degree2=0, degree1=1, + grid.levels=list(age=10), + smooth.col="lightblue", smooth.lwd=2, + pt.col=ifelse(et$survived, "black", "red"), + pt.pch=".", pt.cex=2.5) plotmo grid: pclassn age 2 10 > > set.seed(844) > plotmo(a4, do.par=F, xflip=F, all1=T, center=TRUE, clip=F, + main="pclassn with age=40", ndiscrete=ndiscrete, + degree2=0, degree1=1, + grid.levels=list(age=40), + smooth.col="lightblue", smooth.lwd=2, + pt.col=ifelse(et$survived, "black", "red"), + pt.pch=".", pt.cex=2.5) plotmo grid: pclassn age 2 40 > > source("test.epilog.R") plotmo/inst/slowtests/test.printcall.bat0000755000176200001440000000077014563571565020276 0ustar liggesusers@rem test.printcall.R: test printcall @echo test.printcall.bat @"C:\PROGRA~1\R\R-4.3.2\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.printcall.R @if %errorlevel% equ 0 goto good1: @echo R returned errorlevel %errorlevel%, see test.printcall.Rout: @echo. @tail test.printcall.Rout @echo test.printcall.R @exit /B 1 :good1 mks.diff test.printcall.Rout test.printcall.Rout.save @if %errorlevel% equ 0 goto good3: @echo === Files are different === @exit /B 1 :good3 @rm -f test.printcall.Rout @exit /B 0 plotmo/inst/slowtests/test.epilog.R0000644000176200001440000000034013725307662017200 0ustar liggesusers# test.epilog.R if(!interactive()) { dev.off() # finish postscript plot q(runLast=FALSE) # needed else R prints the time on exit # (R2.5 and higher) which messes up the diffs } plotmo/inst/slowtests/test.dots.Rout.save0000644000176200001440000016256614563606220020373 0ustar liggesusers> # test.dots.R > > source("test.prolog.R") > > cat0("=== test dotindex\n") === test dotindex > > test.dotindex <- function(expected, ARGNAME, ..., EX=FALSE) + { + dotindex <- plotmo:::dotindex(ARGNAME=ARGNAME, EX=EX, ...) + stopifnot(all.equal(dotindex, expected)) + } > test.dotindex(NA, "x") # empty dots > test.dotindex(NA, "x", a=10, b=20) > test.dotindex(1, "a", a=10, b=20) > test.dotindex(2, "b", a=10, b=20) > test.dotindex(1, "a1", a=10, b=20) > test.dotindex(NA, "a", a1=10, a2=20) > expect.err(try(test.dotindex(1, nonesuch, a=10, a=20)), "object 'nonesuch' not found") Error : object 'nonesuch' not found Got expected error from try(test.dotindex(1, nonesuch, a = 10, a = 20)) > expect.err(try(test.dotindex(1, "a1", a=10, a=20)), "argument 'a' for test.dotindex() is duplicated") Error : argument 'a' for test.dotindex() is duplicated Got expected error from try(test.dotindex(1, "a1", a = 10, a = 20)) > expect.err(try(test.dotindex(1, "aa1", a=10, aa=20)), "arguments 'a' and 'aa' both match 'aa1' in test.dotindex") Error : arguments 'a' and 'aa' both match 'aa1' in test.dotindex Got expected error from try(test.dotindex(1, "aa1", a = 10, aa = 20)) > stopifnot(is.na(plotmo:::dotindex("a", EX=1, a1=10, a2=20))) > stopifnot(plotmo:::dotindex("a2", EX=1, a1=10, a2=20) == 2) > > # multiple argnames > test.dotindex(NA, c("a", "b")) # empty dots > test.dotindex(1, c("a", "b"), a=2, c=3) > test.dotindex(1, c("a", "b"), a=5, b=6) > test.dotindex(2, c("a", "b"), x=1, a=5, b=6) > test.dotindex(3, c("b,a"), x=1, a=5, b=6) > test.dotindex(1, c("a b"), b=3, c=4) > test.dotindex(2, c(" a b "), c=3, b=4) > test.dotindex(NA, c("a", "b"), c=3) > stopifnot(plotmo:::dotindex(c("x", "a1"), EX=1, a1=10, a2=20) == 1) > > test.dota <- function(expected, ARGNAME, ..., DEF=NA, EX=FALSE) + { + if(is.na(DEF)) + dot <- plotmo:::dota(ARGNAME, EX=EX, ...) + else + dot <- plotmo:::dota(ARGNAME, EX=EX, DEF=DEF, ...) + stopifnot(all.equal(dot, expected)) + } > cat0("=== test dot\n") === test dot > test.dota(NA, "x") # empty dots > test.dota(NA, "x", a=10, b=20) > test.dota(10, "a", a=10, b=20) > test.dota(20, "b", a=10, b=20) > test.dota(99, DEF=99, "nonesuch", a=10, b=20) > test.dota(NA, "a", a1=10, a2=20) > expect.err(try(test.dota(1, "a1", a=10, a=20)), "argument 'a' for test.dota() is duplicated") Error : argument 'a' for test.dota() is duplicated Got expected error from try(test.dota(1, "a1", a = 10, a = 20)) > expect.err(try(test.dota(1, 99, a=10, a=20)), "is.character(argname) is not TRUE") Error in process.argname(ARGNAME) : is.character(argname) is not TRUE Got expected error from try(test.dota(1, 99, a = 10, a = 20)) > expect.err(try(test.dota(1, test.dota, a=10, a=20)), "is.character(argname) is not TRUE") Error in process.argname(ARGNAME) : is.character(argname) is not TRUE Got expected error from try(test.dota(1, test.dota, a = 10, a = 20)) > expect.err(try(test.dota(1, "", a=10, a=20)), "empty string in ARGNAME") Error : empty string in ARGNAME Got expected error from try(test.dota(1, "", a = 10, a = 20)) > expect.err(try(test.dota(1, "x^x", a=10, a=20)), "illegal character \"^\" in ARGNAME") Error : illegal character "^" in ARGNAME = "x^x" Got expected error from try(test.dota(1, "x^x", a = 10, a = 20)) > > test.dota(10, "abc", EX=T, abc=10) > test.dota(NA, "a", EX=T, a1=10, a2=20) > expect.err(try(test.dota(1, "a1", a1=10, a1=20)), "argument 'a1' for test.dota() is duplicated") Error : argument 'a1' for test.dota() is duplicated Got expected error from try(test.dota(1, "a1", a1 = 10, a1 = 20)) > > stopifnot(is.na(plotmo:::dota("a", EX=1, a1=1, a2=2))) > stopifnot(plotmo:::dota("a2", EX=1, a1=10, a2=20, a3=30) == 20) > > foo <- function(func, x) func(x) > foo(mean, 33) [1] 33 > foo(function(...) plotmo:::dota("x", ...), 33) [1] NA > foo(function(...) plotmo:::dota("x99", ...), 33) [1] NA > foo(function(...) { plotmo:::dota("nonesuch", ...) }, 33) [1] NA > > test.dota(1, "a", EX=T, a=1) > test.dota(2, "b", EX=T, a=1, b=2, c=3) > test.dota(NA, "x", EX=T, a=1, b=2, c=3) > test.dota(2, "a", EX=T, ab=1, a=2) > test.dota(2, "a", EX=T, aa=1, a=2) > test.dota(NA, "a", EX=T, aa=1, ab=2) > expect.err(try(test.dota(2, "a", EX=T, aa=1, a=2, a=3)), "argument 'a' for test.dota() is duplicated") Error : argument 'a' for test.dota() is duplicated Got expected error from try(test.dota(2, "a", EX = T, aa = 1, a = 2, a = 3)) > > expect.err(try(test.dota(2, "a", EX=T, a=none.such)), "cannot evaluate 'a'") Error : object 'none.such' not found Error : cannot evaluate 'a' Got expected error from try(test.dota(2, "a", EX = T, a = none.such)) > > # multiple argnames > test.dota(2, c("a", "b"), a=2, c=3) > test.dota(5, c("a", "b"), a=5, b=6) > test.dota(5, c("a", "b"), x=1, a=5, b=6) > test.dota(3, c("a", "b"), b=3, c=4) > test.dota(4, c("a", "b"), c=3, b=4) > test.dota(NA, c("a", "b"), c=3) > expect.err(try(test.dota(1, c("b", "aa1"), a=10, aa=20)), "arguments 'a' and 'aa' both match 'aa1' in test.dota") Error : arguments 'a' and 'aa' both match 'aa1' in test.dota Got expected error from try(test.dota(1, c("b", "aa1"), a = 10, aa = 20)) > expect.err(try(test.dota(1, c("x", ""), a=10, b=20)), "empty string in ARGNAME") Error : empty string in ARGNAME Got expected error from try(test.dota(1, c("x", ""), a = 10, b = 20)) > stopifnot(plotmo:::dota(c("x", "a2", "y"), EX=1, a1=10, a2=20, a3=30) == 20) > > test.dota(NA, c("a", "b"), aa=2, cc=3, EX=T) > test.dota(2, c("aa", "b"), aa=2, cc=3, EX=T) > test.dota(3, c("bb", "b"), bb=3, cc=4, EX=T) > test.dota(NA, c("a", "b"), c=3, EX=T) > > foo.x <- function(...) { plotmo:::dota("x", ..., DEF="default", EX=FALSE) } > stopifnot(foo.x(x=3) == 3) > stopifnot(foo.x(y=3) == "default") > > foo2 <- function(funcarg, ...) funcarg(...) > stopifnot(is.na(foo2(function(...) plotmo:::dota("x", ...), 3))) # 3 is unnamed > stopifnot(foo2(function(...) plotmo:::dota("x", EX=0, ...), x=3) == 3) > stopifnot(foo2(function(...) plotmo:::dota("x99", EX=0, ...), x=3) == 3) > stopifnot(foo2(function(...) { plotmo:::dota("x", DEF="default", EX=FALSE, ...) }, x=3) == 3) > stopifnot(foo2(function(...) { plotmo:::dota("y", DEF="default", EX=FALSE, ...) }, x=3) == "default") > # expect.err(try(foo2(function(...) { plotmo:::dota("y", DEF="default", EX=FALSE, ...) }, 3)), "unnamed arguments in ... are not allowed for funcarg()") > > stopifnot(foo2(foo.x, x=3) == 3) > stopifnot(foo2(foo.x, y=3) == "default") > > test.is.dot <- function(expected, ARGNAME, ...) + { + present <- plotmo:::is.dot(ARGNAME, ...) + stopifnot(all.equal(present, expected)) + } > cat0("=== test is.dot\n") === test is.dot > test.is.dot(FALSE, "x") # empty dots > test.is.dot(FALSE, "x", EX=0, a=10, b=20) > test.is.dot(TRUE, "a", EX=0, a=10, b=20) > test.is.dot(TRUE, "b", EX=0, a=10, b=20) > test.is.dot(TRUE, "a1", EX=0, a=10, b=20) > test.is.dot(FALSE, "a", EX=0, a1=10, a2=20) > expect.err(try(test.is.dot(TRUE, "a1", EX=0, a=10, a=20)), "argument 'a' for test.is.dot() is duplicated") Error : argument 'a' for test.is.dot() is duplicated Got expected error from try(test.is.dot(TRUE, "a1", EX = 0, a = 10, a = 20)) > expect.err(try(test.is.dot(TRUE, "a", EX=0, a=10, a=20)), "argument 'a' for test.is.dot() is duplicated") Error : argument 'a' for test.is.dot() is duplicated Got expected error from try(test.is.dot(TRUE, "a", EX = 0, a = 10, a = 20)) > stopifnot(plotmo:::is.dot("a", EX=1, a1=10, a2=20, a3=30) == FALSE) > stopifnot(plotmo:::is.dot("x", EX=1, a1=10, a2=20, a3=30) == FALSE) > stopifnot(plotmo:::is.dot("a3", EX=1, a1=10, a2=20, a3=30) == TRUE) > > # multiple argnames > test.is.dot(TRUE, EX=0, c("a1", "b1"), a=2, c=3) > test.is.dot(TRUE, EX=0, c("a1", "b1"), b=3, c=4) > test.is.dot(TRUE, EX=0, c("a1", "b1"), c=3, b=4) > test.is.dot(FALSE, EX=0, c("a1", "b1"), c=3) > expect.err(try(test.is.dot(FALSE, c("aa1", "b"), EX=0, a=10, aa=20)), "arguments 'a' and 'aa' both match 'aa1' in test.is.dot") Error : arguments 'a' and 'aa' both match 'aa1' in test.is.dot Got expected error from try(test.is.dot(FALSE, c("aa1", "b"), EX = 0, a = 10, aa = 20)) > stopifnot(plotmo:::is.dot(c("x", "a", "y"), EX=1, a1=10, a2=20, a3=30) == FALSE) > stopifnot(plotmo:::is.dot(c("x", "a2", "y"), EX=1, a1=10, a2=20, a3=30) == TRUE) > > cat0("=== test expand.drop\n") === test expand.drop > > # nchar is used an example func, it has formals "x", "type", "allowNA" > > stopifnot(is.null(plotmo:::expand.drop(NULL, prefix="prefix.", func=nchar))) > > stopifnot(plotmo:::expand.drop("a", prefix="prefix.", func=nchar) == ">PREFIX|>EXPLICIT|^a") > > stopifnot(plotmo:::expand.drop("a", prefix="prefix.", func=nchar, include.standard.prefixes=TRUE) == ">STANDARDPREFIXES|^force\\.|^def\\.|^drop\\.|>PREFIX|^prefix\\.|>EXPLICIT|^a") > > stopifnot(plotmo:::expand.drop("FORMALS", prefix="prefix.", func=base::nchar) == ">FORMALS|^x|^type|^allowNA|^keepNA|>PREFIX|>EXPLICIT") > > stopifnot(plotmo:::expand.drop("FORMALS", prefix="prefix.", func=base::nchar, include.standard.prefixes=TRUE) == ">FORMALS|^x|^type|^allowNA|^keepNA|>STANDARDPREFIXES|^force\\.|^def\\.|^drop\\.|>PREFIX|^prefix\\.|>EXPLICIT") > > expect.err(try(plotmo:::expand.drop("FORMALS", prefix="prefix.", func=NULL)), "\"FORMALS\" specified in DROP, but FUNC is NULL") Error : "FORMALS" specified in DROP, but FUNC is NULL Got expected error from try(plotmo:::expand.drop("FORMALS", prefix = "prefix.", func = NULL)) > > expect.err(try(plotmo:::expand.drop("FORMALS", prefix="prefix.", func=base::c)), "\"FORMALS\" specified but formals(FUNC) returned no formal arguments") Error : "FORMALS" specified but formals(FUNC) returned no formal arguments Got expected error from try(plotmo:::expand.drop("FORMALS", prefix = "prefix.", func = base::c)) > > foo99 <- function(...) NULL > expect.err(try(plotmo:::expand.drop("FORMALS", prefix="prefix.", func=foo99)), "\"FORMALS\" specified but formals(FUNC) returned only \"...\"") Error : "FORMALS" specified but formals(FUNC) returned only "..." Got expected error from try(plotmo:::expand.drop("FORMALS", prefix = "prefix.", func = foo99)) > > stopifnot(plotmo:::expand.drop("a,FORMALS", prefix="prefix.", func=base::nchar) == ">FORMALS|^x|^type|^allowNA|^keepNA|>PREFIX|>EXPLICIT|^a") > > stopifnot(plotmo:::expand.drop("a,FORMALS", prefix="prefix.", func=base::nchar, include.standard.prefixes=TRUE) == ">FORMALS|^x|^type|^allowNA|^keepNA|>STANDARDPREFIXES|^force\\.|^def\\.|^drop\\.|>PREFIX|^prefix\\.|>EXPLICIT|^a") > > expect.err(try(plotmo:::expand.drop("", prefix="prefix.", func=base::nchar)), "DROP is an empty string") Error : DROP is an empty string Got expected error from try(plotmo:::expand.drop("", prefix = "prefix.", func = base::nchar)) > > stopifnot(plotmo:::expand.drop("a", prefix="lines.", func=base::nchar) == ">PREFIX|>EXPLICIT|^a") > > stopifnot(plotmo:::expand.drop("a", "lines.a", prefix="lines.", func=base::nchar, include.standard.prefixes=TRUE) == ">STANDARDPREFIXES|^force\\.|^def\\.|^drop\\.|>PREFIX|^lines\\.|>EXPLICIT|^a") > > stopifnot(plotmo:::expand.drop("a*", prefix="lines.", func=base::nchar) == ">PREFIX|>EXPLICIT|^a.*") > > stopifnot(plotmo:::expand.drop("a.*", prefix="lines.", func=base::nchar) == ">PREFIX|>EXPLICIT|^a\\..*") > > stopifnot(plotmo:::expand.drop("a$", prefix="lines.", func=base::nchar) == ">PREFIX|>EXPLICIT|^a$") > > stopifnot(plotmo:::expand.drop("a$,b*,c*$", prefix="lines.", func=base::nchar) == ">PREFIX|>EXPLICIT|^a$|^b.*|^c.*$") > > stopifnot(plotmo:::expand.drop(c("a", "b,c", " d e$ f ", "g h$, i"), prefix="lines.", func=base::nchar) == + ">PREFIX|>EXPLICIT|^a|^b|^c|^d|^e$|^f|^g|^h$|^i") > > stopifnot(plotmo:::expand.drop("PLOT.ARGS", prefix="lines.", func=base::nchar) == + ">PREFIX|>EXPLICIT|>PLOT_ARGS|^add$|^adj$|^bty$|^cex$|^cex\\.axis$|^cex\\.lab$|^cex\\.main$|^cex\\.sub$|^col$|^col\\.axis$|^col\\.lab$|^col\\.main$|^col\\.sub$|^crt$|^family$|^font$|^font$|^font\\.axis$|^font\\.lab$|^font\\.main$|^font\\.sub$|^lend$|^ljoin$|^lmitre$|^lty$|^lwd$|^main$|^pch$|^srt$|^xaxp$|^xaxs$|^xaxt$|^xlab$|^xlim$|^xlog$|^xpd$|^yaxp$|^yaxs$|^yaxt$|^ylab$|^ylim$|^ylog$") > > stopifnot(plotmo:::expand.drop("abc,PLOT.ARGS", prefix="lines.", func=base::nchar) == + ">PREFIX|>EXPLICIT|^abc|>PLOT_ARGS|^add$|^adj$|^bty$|^cex$|^cex\\.axis$|^cex\\.lab$|^cex\\.main$|^cex\\.sub$|^col$|^col\\.axis$|^col\\.lab$|^col\\.main$|^col\\.sub$|^crt$|^family$|^font$|^font$|^font\\.axis$|^font\\.lab$|^font\\.main$|^font\\.sub$|^lend$|^ljoin$|^lmitre$|^lty$|^lwd$|^main$|^pch$|^srt$|^xaxp$|^xaxs$|^xaxt$|^xlab$|^xlim$|^xlog$|^xpd$|^yaxp$|^yaxs$|^yaxt$|^ylab$|^ylim$|^ylog$") > > stopifnot(plotmo:::expand.drop("abc,FORMALS,PLOT.ARGS", prefix="lines.", func=base::nchar) == + ">FORMALS|^x|^type|^allowNA|^keepNA|>PREFIX|>EXPLICIT|^abc|>PLOT_ARGS|^add$|^adj$|^bty$|^cex$|^cex\\.axis$|^cex\\.lab$|^cex\\.main$|^cex\\.sub$|^col$|^col\\.axis$|^col\\.lab$|^col\\.main$|^col\\.sub$|^crt$|^family$|^font$|^font$|^font\\.axis$|^font\\.lab$|^font\\.main$|^font\\.sub$|^lend$|^ljoin$|^lmitre$|^lty$|^lwd$|^main$|^pch$|^srt$|^xaxp$|^xaxs$|^xaxt$|^xlab$|^xlim$|^xlog$|^xpd$|^yaxp$|^yaxs$|^yaxt$|^ylab$|^ylim$|^ylog$") > > stopifnot(plotmo:::expand.drop("abc,FORMALS,PAR.ARGS", prefix="lines.", func=base::nchar) == + ">FORMALS|^x|^type|^allowNA|^keepNA|>PREFIX|>EXPLICIT|^abc|>PAR_ARGS|^adj$|^ann$|^ask$|^bg$|^bty$|^cex$|^cex\\.axis$|^cex\\.lab$|^cex\\.main$|^cex\\.sub$|^col\\.axis$|^col\\.lab$|^col\\.main$|^col\\.sub$|^crt$|^err$|^family$|^fg$|^fig$|^fin$|^font$|^font\\.axis$|^font\\.lab$|^font\\.main$|^font\\.sub$|^lab$|^las$|^lend$|^lheight$|^ljoin$|^lmitre$|^lty$|^mai$|^mar$|^mex$|^mfcol$|^mfg$|^mfrow$|^mgp$|^mkh$|^new$|^oma$|^omd$|^omi$|^pch$|^pin$|^plt$|^ps$|^pty$|^srt$|^tck$|^tcl$|^usr$|^xaxp$|^xaxs$|^xaxt$|^xlog$|^xpd$|^yaxp$|^yaxs$|^yaxt$|^ylbias$|^ylog$") > > stopifnot(plotmo:::expand.drop("abc,FORMALS,PLOTMO.ARGS", prefix="lines.", func=base::nchar) == + ">FORMALS|^x|^type|^allowNA|^keepNA|>PREFIX|>EXPLICIT|^abc|>PLOTMO_ARGS|^caption\\.|^cex\\.|^col\\.|^contour\\.|^cum\\.|^degree1\\.|^degree2\\.|^density\\.|^filled\\.contour\\.|^font\\.|^func\\.|^grid\\.|^heatmap\\.|^image\\.|^jitter\\.|^legend\\.|^label\\.|^level\\.|^line\\.|^lines\\.|^lty\\.|^lty\\.|^lwd\\.|^main\\.|^mtext\\.|^nresiduals|^par\\.|^pch\\.|^persp\\.|^plot\\.|^plotmath\\.|^prednames\\.|^qq\\.|^qqline\\.|^pt\\.|^response\\.|^rug\\.|^smooth\\.|^text\\.|^title\\.|^vfont\\.") > > test.deprefix <- function(expected, ..., FNAME="test.deprefix", KEEP=NULL) + { + args <- plotmo:::deprefix(..., FNAME=FNAME, KEEP=KEEP, CALLARGS="") + # can't use all.equal because it complains about names + # cat("args:\n") + # print(args) + # cat("expected:\n") + # print(expected) + stopifnot(length(args) == length(expected)) + for(i in seq_len(length(expected))) { + stopifnot(names(args)[i] == names(expected)[i]) + stopifnot(args[[i]] == expected[[i]]) + } + } > cat0("=== test deprefix\n") === test deprefix > > test.deprefix( + expected=list(a=1, b=2), DROP="*", + PREFIX="predict.", def.a=1, predict.b=2, c=3) > > test.deprefix(TRACE=2, + expected=list(b="predict.b", d="def.d", c="predict.c", e="predict.e"), + PREFIX="predict.", DROP="*", + a="a", b="b", c="c", w1.xlab="xlab", + def.b="def.b", def.d="def.d", + predict.b="predict.b", predict.c="predict.c", predict.e="predict.e") TRACE higher.caller.to.deprefix called higher.caller.to.deprefix(test.deprefix, FNAME="test.deprefix", a="a", b="b", c="c", w1.xlab="xlab", def.b="def.b", def.d="def.d", predict.b="predict.b", predict.c="predict.c", predict.e="predict.e") PREFIX predict. DROP .* KEEP ^force.|^def.|^predict. input dotnames a b c w1.xlab def.b def.d predict.b predict.c predict.e after DROP and KEEP def.b def.d predict.b predict.c predict.e return dotnames b d c e > > test.deprefix(TRACE=2, + expected=list(b="predict.b", d="def.d", a="a", c="predict.c", e="predict.e"), + KEEP=NULL, PREFIX="predict.", DROP="w1.", + a="a", b="b", c="c", w1.xlab="xlab", + def.b="def.b", def.d="def.d", + predict.b="predict.b", predict.c="predict.c", predict.e="predict.e") TRACE higher.caller.to.deprefix called higher.caller.to.deprefix(test.deprefix, FNAME="test.deprefix", a="a", b="b", c="c", w1.xlab="xlab", def.b="def.b", def.d="def.d", predict.b="predict.b", predict.c="predict.c", predict.e="predict.e") PREFIX predict. DROP >PREFIX >EXPLICIT|^w1\. KEEP ^force.|^def.|^predict. input dotnames a b c w1.xlab def.b def.d predict.b predict.c predict.e after DROP and KEEP a b c def.b def.d predict.b predict.c predict.e return dotnames b d a c e > > test.deprefix( + expected=list(a="predict.a"), + KEEP=NULL, PREFIX="predict.", DROP="w1.", + a="plain.a", predict.a="predict.a") > > test.deprefix(expected=list(a="aa1"), + KEEP=NULL, PREFIX="predict.", a="aa1") > > test.deprefix(expected=list(a="aa2"), + KEEP=NULL, PREFIX="predict.", def.a="aa2") > > test.deprefix(expected=list(a="aa3", b="bb3"), + KEEP=NULL, PREFIX="predict.", def.a="aa3", b="bb3") > > test.deprefix(expected=list(10, 20), TRACE=2, + KEEP=NULL, DROP="w1.,persp.,xlab.", + PREFIX="predict.", + force.anon2=20, force.anon1=10) TRACE higher.caller.to.deprefix called higher.caller.to.deprefix(test.deprefix, FNAME="test.deprefix", force.anon2=20, force.anon1=10) PREFIX predict. DROP >PREFIX >EXPLICIT|^w1\.|^persp\.|^xlab\. KEEP ^force.|^def.|^predict. input dotnames force.anon2 force.anon1 after DROP and KEEP force.anon2 force.anon1 return dotnames anon1 anon2 > > test.deprefix(expected=list(10, 20, a=3), TRACE=2, + KEEP=NULL, DROP="w1.,persp.,xlab.", + PREFIX="predict.", + force.anon2=20, force.anon1=10, + a=3) TRACE higher.caller.to.deprefix called higher.caller.to.deprefix(test.deprefix, FNAME="test.deprefix", force.anon2=20, force.anon1=10, a=3) PREFIX predict. DROP >PREFIX >EXPLICIT|^w1\.|^persp\.|^xlab\. KEEP ^force.|^def.|^predict. input dotnames force.anon2 force.anon1 a after DROP and KEEP force.anon2 force.anon1 a return dotnames anon1 anon2 a > > expect.err(try(test.deprefix(expected=list(10, 20, a=4), + KEEP=NULL, DROP="w1.,persp.,xlab.", + PREFIX="predict.", + force.anon=10, force.anon=20, + a=3, predict.a=4)), + "argument 'force.anon' for test.deprefix() is duplicated") Error : argument 'force.anon' for test.deprefix() is duplicated Got expected error from try(test.deprefix(expected = list(10, 20, a = 4), KEEP = NULL, DROP = "w1.,persp.,xlab.", PREFIX = "predict.", force.anon = 10, force.anon = 20, a = 3, predict.a = 4)) > > expect.err(try(test.deprefix(expected=list(10, 20, a=4), + KEEP=NULL, DROP="w1.,persp.,xlab.", + PREFIX="predict.", FNAME="foobar", + force.anon=10, force.anon=20, + a=3, predict.a=4)), + "argument 'force.anon' for foobar() is duplicated") Error : argument 'force.anon' for foobar() is duplicated Got expected error from try(test.deprefix(expected = list(10, 20, a = 4), KEEP = NULL, DROP = "w1.,persp.,xlab.", PREFIX = "predict.", FNAME = "foobar", force.anon = 10, force.anon = 20, a = 3, predict.a = 4)) > > test.deprefix(expected=list(10, 20, a=4), + KEEP=NULL, DROP="w1.,persp.,xlab.", + PREFIX="predict.", + force.anon1=10, force.anon2=20, + a=3, predict.a=4) > > test.deprefix(expected=list(10, 20, b=3, a=4), + KEEP=NULL, DROP="w1.,persp.,xlab.", + PREFIX="predict.", + force.anon1=10, force.anon2=20, def.b=3, + a=3, predict.a=4) > > test.deprefix(expected=list(10, 20, b=5, a=3), + KEEP=NULL, DROP="w1.,persp.,xlab.", + PREFIX="predict.", + force.anon1=10, force.anon2=20, def.b=3, + a=3, predict.b=5) > > test.deprefix(expected=list(10, 20, b=6, a=3), + KEEP=NULL, DROP="w1.,persp.,xlab.", + PREFIX="predict.", + force.anon1=10, force.anon2=20, def.b=3, + a=3, b=6) > > expect.err(try(test.deprefix(expected=NULL, KEEP=NULL, PREFIX="predict.", DROP="w1\\.")), "illegal character \"\\\" in DROP = \"w1\\.\"") Error : illegal character "\" in DROP = "w1\." Got expected error from try(test.deprefix(expected = NULL, KEEP = NULL, PREFIX = "predict.", DROP = "w1\\.")) > > test.deprefix(expected=list(b="predict.b", d="def.d", a="a", c="predict.c", w1.xl="xlab2", e="predict.e"), + PREFIX="predict.", DROP="w1.xlab$", + a="a", b="b", c="c", + w1.xlab="xlab1", # will be dropped (exact match) + w1.xl="xlab2", # will be kept (not an exact match) + def.b="def.b", def.d="def.d", + predict.b="predict.b", predict.c="predict.c", predict.e="predict.e") > > # expect.err(try(plotmo:::deprefix(FNAME="test.deprefix", PREFIX="predict.", UPPER.CASE123=99, > # def.a=1, predict.b=2, c=3)), > # "uppercase argument names like \"UPPER.CASE123\" are not allowed for test.deprefix()") > > test.expand.dotnames <- function(expected, PREFIX, FUNC=NULL, + FNAME="test.expand.dotnames", FORMALS=NULL, ...) + { + dots <- as.list(match.call(expand.dots=FALSE)$...) + args <- plotmo:::expand.dotnames(dots, PREFIX, FUNC, FNAME, FORMALS) + # can't use all.equal because it complains about named list versus unnamed list + stopifnot(length(args) == length(expected)) + for(i in seq_len(length(expected))) { + stopifnot(names(args)[i] == names(expected)[i]) + stopifnot(eval(args[[i]]) == expected[[i]]) + } + } > cat0("=== test expand.dotnames\n") === test expand.dotnames > > test.expand.dotnames(expected=list(x=9, persp.shade=3), + "persp.", graphics:::persp.default, "persp.default", x=9, persp.sh=3) > > test.expand.dotnames(expected=list(x=9, persp.shade=3, persp.nonesuch=4), + "persp.", graphics:::persp.default, "persp.default", x=9, persp.sh=3, persp.nonesuch=4) > > test.expand.dotnames(expected=list(x=9, persp.col=3), + "persp.", graphics:::persp.default, "persp.default", x=9, persp.c=3) > > # TODO not sure why this works as it does > test.expand.dotnames(expected=list(x=9, persp.x=3), + "persp.", graphics:::persp.default, "persp.default", x=9, persp.x=3) > > expect.err(try(test.expand.dotnames(expected=NULL, + "persp.", graphics:::persp.default, "persp.default", x=9, persp.l=3)), + "'l' matches both the 'ltheta' and 'lphi' arguments of persp.default()") Error : 'l' matches both the 'ltheta' and 'lphi' arguments of persp.default() Got expected error from try(test.expand.dotnames(expected = NULL, "persp.", graphics:::persp.default, "persp.default", x = 9, persp.l = 3)) > > test.expand.dotnames(expected=list(x=9, plot.foo=3, plot.xlim=c(1,2)), + "plot.", graphics:::plot.default, "plot.default", x=9, plot.foo=3, plot.xlim=c(1,2)) > > test.expand.dotnames(expected=list(x=9, plot.foo=3, plot.xlim=c(1,2)), + "plot.", graphics:::plot.default, "plot.default", x=9, plot.foo=3, plot.xli=c(1,2)) > > expect.err(try(test.expand.dotnames(expected=NULL, + "plot.", graphics:::plot.default, "plot.default", x=9, plot.foo=3, plot.xl=c(1,2))), + "'xl' matches both the 'xlim' and 'xlab' arguments of plot.default()") Error : 'xl' matches both the 'xlim' and 'xlab' arguments of plot.default() Got expected error from try(test.expand.dotnames(expected = NULL, "plot.", graphics:::plot.default, "plot.default", x = 9, plot.foo = 3, plot.xl = c(1, 2))) > > foo3 <- function(aaa=1, aa=2, bb=3, bba=4, cca=5, ccb=6, def=7) + cat0("foo3: aaa=", aaa, " aa=", aa, ", bb=", bb, " bba=", bba, + " cca=", cca, " ccb=", ccb, " def=", def, "\n") > > # --- above tests again but using formals --- > > # formal args for graphics:::persp.default (R version 3.2.0) > formals <- c( "x", "y", "z", "xlim", "zlim", "xlab", "ylab", "zlab", + "main", "sub", "theta", "phi", "r", "d", "scale", "expand", "col", + "border", "ltheta", "lphi", "shade", "box", "axes", "nticks", + "ticktype") > > test.expand.dotnames(expected=list(x=9, persp.shade=3), + "persp.", graphics:::persp, "persp", FORMALS=formals, x=9, persp.sh=3) > > test.expand.dotnames(expected=list(x=9, persp.shade=3, persp.nonesuch=4), + "persp.", graphics:::persp, "persp", FORMALS=formals, x=9, persp.sh=3, persp.nonesuch=4) > > test.expand.dotnames(expected=list(x=9, persp.col=3), + "persp.", graphics:::persp, "persp", FORMALS=formals, x=9, persp.c=3) > > # TODO not sure why this works as it does > test.expand.dotnames(expected=list(x=9, persp.x=3), + "persp.", graphics:::persp, "persp", FORMALS=formals, x=9, persp.x=3) > > expect.err(try(test.expand.dotnames(expected=NULL, + "persp.", graphics:::persp, "persp", FORMALS=formals, x=9, persp.l=3)), + "'l' matches both the 'ltheta' and 'lphi' arguments of persp()") Error : 'l' matches both the 'ltheta' and 'lphi' arguments of persp() Got expected error from try(test.expand.dotnames(expected = NULL, "persp.", graphics:::persp, "persp", FORMALS = formals, x = 9, persp.l = 3)) > > # done formals tests > > test.expand.dotnames(expected=list(x=9, plot.foo=3, plot.xlim=c(1,2)), + "plot.", graphics:::plot.default, "plot.default", x=9, plot.foo=3, plot.xlim=c(1,2)) > > test.expand.dotnames(expected=list(x=9, plot.foo=3, plot.xlim=c(1,2)), + "plot.", graphics:::plot.default, "plot.default", x=9, plot.foo=3, plot.xli=c(1,2)) > > expect.err(try(test.expand.dotnames(expected=NULL, + "plot.", graphics:::plot.default, "plot.default", x=9, plot.foo=3, plot.xl=c(1,2))), + "'xl' matches both the 'xlim' and 'xlab' arguments of plot.default()") Error : 'xl' matches both the 'xlim' and 'xlab' arguments of plot.default() Got expected error from try(test.expand.dotnames(expected = NULL, "plot.", graphics:::plot.default, "plot.default", x = 9, plot.foo = 3, plot.xl = c(1, 2))) > > test.expand.dotnames(expected=list(foo3.aa=99), + "foo3.", foo3, "foo3", foo3.aa=99) > expect.err(try(plotmo:::call.plot(foo3, "foo3.", foo3.aa=99)), "Unnamed arguments are not allowed here\n The argument's value is \"foo3.\"") Error : Unnamed arguments are not allowed here The argument's value is "foo3." plotmo:::call.plot via try called call.dots(FUNC=foo3, PREFIX=PREFIX, ..., DROP="*", KEEP="PREFIX,PLOT.ARGS", TRACE=TRACE, FNAME=fname, FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=function.object, CALLER=caller, foo3.aa=99) Got expected error from try(plotmo:::call.plot(foo3, "foo3.", foo3.aa = 99)) > expect.err(try(plotmo:::call.plot(foo3, foo, foo3.aa=99)), + "Unnamed arguments are not allowed here\n The argument's value is function.object") Error : Unnamed arguments are not allowed here The argument's value is function.object plotmo:::call.plot via try called call.dots(FUNC=foo3, PREFIX=PREFIX, ..., DROP="*", KEEP="PREFIX,PLOT.ARGS", TRACE=TRACE, FNAME=fname, FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=function.object, CALLER=caller, foo3.aa=99) Got expected error from try(plotmo:::call.plot(foo3, foo, foo3.aa = 99)) > expect.err(try(plotmo:::call.plot(foo3, NULL, foo3.aa=99)), "Unnamed arguments are not allowed here\n The argument's value is NULL") Error : Unnamed arguments are not allowed here The argument's value is NULL plotmo:::call.plot via try called call.dots(FUNC=foo3, PREFIX=PREFIX, ..., DROP="*", KEEP="PREFIX,PLOT.ARGS", TRACE=TRACE, FNAME=fname, FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=function.object, CALLER=caller, foo3.aa=99) Got expected error from try(plotmo:::call.plot(foo3, NULL, foo3.aa = 99)) > expect.err(try(plotmo:::call.plot(foo3, stop("stop was called"), foo3.aa=99)), "Unnamed arguments are not allowed here (argument ..1 is unnamed)") Error : Unnamed arguments are not allowed here (argument ..1 is unnamed) plotmo:::call.plot via try called call.dots(FUNC=foo3, PREFIX=PREFIX, ..., DROP="*", KEEP="PREFIX,PLOT.ARGS", TRACE=TRACE, FNAME=fname, FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=function.object, CALLER=caller, foo3.aa=99) Got expected error from try(plotmo:::call.plot(foo3, stop("stop was called"), foo3.aa = 99)) > expect.err(try(plotmo:::call.plot(foo3, cat("side effect\n"), foo3.aa=99)), "Unnamed arguments are not allowed here\n The argument's value is NULL") side effect Error : Unnamed arguments are not allowed here The argument's value is NULL plotmo:::call.plot via try called call.dots(FUNC=foo3, PREFIX=PREFIX, ..., DROP="*", KEEP="PREFIX,PLOT.ARGS", TRACE=TRACE, FNAME=fname, FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=function.object, CALLER=caller, foo3.aa=99) Got expected error from try(plotmo:::call.plot(foo3, cat("side effect\n"), foo3.aa = 99)) > expect.err(try(plotmo:::call.plot(foo3, nonesuch1=1, nonesuch2, foo3.aa=99)), "Unnamed arguments are not allowed here (argument ..2 is unnamed)") Error : Unnamed arguments are not allowed here (argument ..2 is unnamed) plotmo:::call.plot via try called call.dots(FUNC=foo3, PREFIX=PREFIX, ..., DROP="*", KEEP="PREFIX,PLOT.ARGS", TRACE=TRACE, FNAME=fname, FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=function.object, CALLER=caller, nonesuch1=1, foo3.aa=99) Got expected error from try(plotmo:::call.plot(foo3, nonesuch1 = 1, nonesuch2, foo3.aa = 99)) > plotmo:::call.plot(foo3, PREFIX="foo3.", foo3.aa=99) foo3: aaa=1 aa=99, bb=3 bba=4 cca=5 ccb=6 def=7 > > test.expand.dotnames(expected=list(foo3.aaa=99), + "foo3.", foo3, "foo3", foo3.aaa=99) > plotmo:::call.plot(foo3, foo3.aaa=99) foo3: aaa=99 aa=2, bb=3 bba=4 cca=5 ccb=6 def=7 > > expect.err(try(test.expand.dotnames(expected=list(foo3.aaa=99), + "foo3.", foo3, "foo3", foo3.aa=88, foo3.aa=99)), + "'foo3.aa' for foo3() is duplicated") Error : argument 'foo3.aa' for foo3() is duplicated Got expected error from try(test.expand.dotnames(expected = list(foo3.aaa = 99), "foo3.", foo3, "foo3", foo3.aa = 88, foo3.aa = 99)) > > expect.err(try(test.expand.dotnames(expected=list(foo3.aaa=99), + "foo3.", foo3, "foo3", foo3.a=88, foo3.aa=99)), + "'a' matches both the 'aaa' and 'aa' arguments of foo3()") Error : 'a' matches both the 'aaa' and 'aa' arguments of foo3() Got expected error from try(test.expand.dotnames(expected = list(foo3.aaa = 99), "foo3.", foo3, "foo3", foo3.a = 88, foo3.aa = 99)) > > expect.err(try(test.expand.dotnames(expected=list(foo3.aaa=99), + "foo3.", foo3, "foo3", foo3.aaa=88, foo3.aaa=99)), + "'foo3.aaa' for foo3() is duplicated") Error : argument 'foo3.aaa' for foo3() is duplicated Got expected error from try(test.expand.dotnames(expected = list(foo3.aaa = 99), "foo3.", foo3, "foo3", foo3.aaa = 88, foo3.aaa = 99)) > > test.expand.dotnames(expected=list(foo3.bbb=88, foo3.bba=99), + "foo3.", foo3, "foo3", foo3.bbb=88, foo3.bba=99) > expect.err(try(plotmo:::call.plot(foo3, foo3.bbb=88, foo3.bba=99)), + "unused argument (bbb = 88)") foo3(bbb=88, bba=99) Error in (function (aaa = 1, aa = 2, bb = 3, bba = 4, cca = 5, ccb = 6, : unused argument (bbb = 88) Got expected error from try(plotmo:::call.plot(foo3, foo3.bbb = 88, foo3.bba = 99)) > > # same as above but with TRACE (so don't use try in call.dots) > expect.err(try(plotmo:::call.plot(foo3, foo3.bbb=88, foo3.bba=99, TRACE=T)), + "unused argument (bbb = 88)") foo3(bbb=88, bba=99) Error in (function (aaa = 1, aa = 2, bb = 3, bba = 4, cca = 5, ccb = 6, : unused argument (bbb = 88) Got expected error from try(plotmo:::call.plot(foo3, foo3.bbb = 88, foo3.bba = 99, TRACE = T)) > > test.expand.dotnames(expected=list(foo3.bb=88), + "foo3.", foo3, "foo3", foo3.bb=88) > plotmo:::call.plot(foo3, foo3.bb=88) foo3: aaa=1 aa=2, bb=88 bba=4 cca=5 ccb=6 def=7 > > # test with FUNC=NULL > > test.expand.dotnames(expected=list(foo3.aa=99), + "foo3.", NULL, "foo3", foo3.aa=99) > plotmo:::call.plot(foo3, foo3.aa=99) foo3: aaa=1 aa=99, bb=3 bba=4 cca=5 ccb=6 def=7 > > test.expand.dotnames(expected=list(foo3.aaa=99), + "foo3.", NULL, "foo3", foo3.aaa=99) > plotmo:::call.plot(foo3, foo3.aaa=99) foo3: aaa=99 aa=2, bb=3 bba=4 cca=5 ccb=6 def=7 > > expect.err(try(test.expand.dotnames(expected=list(foo3.aaa=99), + "foo3.", NULL, "foo3", foo3.aa=88, foo3.aa=99)), + "argument 'foo3.aa' for foo3() is duplicated") Error : argument 'foo3.aa' for foo3() is duplicated Got expected error from try(test.expand.dotnames(expected = list(foo3.aaa = 99), "foo3.", NULL, "foo3", foo3.aa = 88, foo3.aa = 99)) > > test.expand.dotnames(expected=list(foo3.a=88, foo3.aa=99), + "foo3.", NULL, "foo3", foo3.a=88, foo3.aa=99) > expect.err(try(plotmo:::call.plot(foo3, foo3.a=88, foo3.aa=99)), + "'a' matches both the 'aaa' and 'aa' arguments of foo3()") Error : 'a' matches both the 'aaa' and 'aa' arguments of foo3() Got expected error from try(plotmo:::call.plot(foo3, foo3.a = 88, foo3.aa = 99)) > > expect.err(try(test.expand.dotnames(expected=list(foo3.aaa=99), + "foo3.", NULL, "foo3", foo3.aaa=88, foo3.aaa=99)), + "argument 'foo3.aaa' for foo3() is duplicated") Error : argument 'foo3.aaa' for foo3() is duplicated Got expected error from try(test.expand.dotnames(expected = list(foo3.aaa = 99), "foo3.", NULL, "foo3", foo3.aaa = 88, foo3.aaa = 99)) > > test.expand.dotnames(expected=list(foo3.bbb=88, foo3.bba=99), + "foo3.", NULL, "foo3", foo3.bbb=88, foo3.bba=99) > expect.err(try(plotmo:::call.plot(foo3, PREFIX="foo3.", foo3.bbb=88, foo3.bba=99)), + "unused argument (bbb = 88)") foo3(bbb=88, bba=99) Error in (function (aaa = 1, aa = 2, bb = 3, bba = 4, cca = 5, ccb = 6, : unused argument (bbb = 88) Got expected error from try(plotmo:::call.plot(foo3, PREFIX = "foo3.", foo3.bbb = 88, foo3.bba = 99)) > > test.expand.dotnames(expected=list(foo3.bb=88), + "foo3.", NULL, "foo3", foo3.bb=88) > plotmo:::call.plot(foo3, foo3.bb=88) foo3: aaa=1 aa=2, bb=88 bba=4 cca=5 ccb=6 def=7 > > test.expand.dotnames(expected=list(foo3.bbx=88), + "foo3.", NULL, "foo3", foo3.bbx=88) > expect.err(try(plotmo:::call.plot(foo3, foo3.bbx=88)), + "unused argument (bbx = 88)") foo3(bbx=88) Error in (function (aaa = 1, aa = 2, bb = 3, bba = 4, cca = 5, ccb = 6, : unused argument (bbx = 88) Got expected error from try(plotmo:::call.plot(foo3, foo3.bbx = 88)) > > test.expand.dotnames(expected=list(foo3.cc=77), + "foo3.", NULL, "foo3", foo3.cc=77) > expect.err(try(plotmo:::call.plot(foo3, foo3.cc=77)), + "'cc' matches both the 'cca' and 'ccb' arguments of foo3()") Error : 'cc' matches both the 'cca' and 'ccb' arguments of foo3() Got expected error from try(plotmo:::call.plot(foo3, foo3.cc = 77)) > > # following two directly compare FUNC=NULL to FUNC=foo3 > test.expand.dotnames(expected=list(foo3.cc=77), + "foo3.", FUNC=NULL, "foo3", foo3.cc=77) > expect.err(try(test.expand.dotnames(expected=NULL, + "foo3.", FUNC=foo3, "foo3", foo3.cc=77)), + "'cc' matches both the 'cca' and 'ccb' arguments of foo3()") Error : 'cc' matches both the 'cca' and 'ccb' arguments of foo3() Got expected error from try(test.expand.dotnames(expected = NULL, "foo3.", FUNC = foo3, "foo3", foo3.cc = 77)) > > test.expand.dotnames(expected=list(), "foo3.", foo3, "foo3", d=88, de=99) > > expect.err(try(plotmo:::call.plot(graphics::plot, x=1:3, y=1:3, 99)), + "Unnamed arguments are not allowed here\n The argument's value is 99\n plotmo:::call.plot via try called call.dots(FUNC=plot, PREFIX=PREFIX, ...") Error : Unnamed arguments are not allowed here The argument's value is 99 plotmo:::call.plot via try called call.dots(FUNC=plot, PREFIX=PREFIX, ..., DROP="*", KEEP="PREFIX,PLOT.ARGS", TRACE=TRACE, FNAME=fname, FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=function.object, CALLER=caller, x=c(1,2,3), y=c(1,2,3)) Got expected error from try(plotmo:::call.plot(graphics::plot, x = 1:3, y = 1:3, 99)) > > # test TRACE > print(plotmo:::deprefix(FUNC=nchar, PREFIX="foo3.", TRACE=TRUE, FNAME="nchar", allowN=1, b=2, foo3.c=3)) $allowNA [1] 1 $b [1] 2 $c [1] 3 > print(plotmo:::deprefix(FUNC=nchar, PREFIX="foo3.", TRACE=2, allowN=1, b=2, foo3.c=3)) TRACE higher.caller.to.deprefix called higher.caller.to.deprefix(nchar, FNAME="nchar", allowN=1, b=2, foo3.c=3) PREFIX foo3. DROP NULL KEEP ^force.|^def.|^foo3. input dotnames allowN b foo3.c after DROP and KEEP allowN b foo3.c return dotnames allowNA b c $allowNA [1] 1 $b [1] 2 $c [1] 3 > print(plotmo:::deprefix(FUNC=nchar, PREFIX="foo3.", TRACE=3, allowN=1, b=2, foo3.c=3)) TRACE higher.caller.to.deprefix called higher.caller.to.deprefix(nchar, FNAME="nchar", allowN=1, b=2, foo3.c=3) PREFIX foo3. DROP NULL KEEP ^force.|^def.|^foo3. input dotnames allowN b foo3.c after DROP and KEEP allowN b foo3.c return dotnames allowNA b c $allowNA [1] 1 $b [1] 2 $c [1] 3 > > expect.err(try(plotmo:::call.plot(foo3, foo3.d=88, foo3.de=99)), + "'foo3.d' and 'foo3.de' both match the 'def' argument of foo3()") Error : 'foo3.d' and 'foo3.de' both match the 'def' argument of foo3() Got expected error from try(plotmo:::call.plot(foo3, foo3.d = 88, foo3.de = 99)) > > cat0("=== test stop.if.dots\n") === test stop.if.dots > > foo3 <- function(x=1, ...) plotmo:::stop.if.dots(...) > foo3(1) # ok > expect.err(try(foo3(10, y=2)), "foo3: unrecognized argument 'y'") Error : foo3: unrecognized argument 'y' Got expected error from try(foo3(10, y = 2)) > expect.err(try(foo3(10, 99)), "foo3: unrecognized unnamed argument\n The call was foo3(x=10, 99)") Error : foo3: unrecognized unnamed argument The call was foo3(x=10, 99) Got expected error from try(foo3(10, 99)) > expect.err(try(foo3(10, y=plot)), "foo3: unrecognized argument 'y'") Error : foo3: unrecognized argument 'y' Got expected error from try(foo3(10, y = plot)) > expect.err(try(foo3(10, plot)), + "foo3: unrecognized unnamed argument\n The call was foo3(x=10, plot)") Error : foo3: unrecognized unnamed argument The call was foo3(x=10, plot) Got expected error from try(foo3(10, plot)) > > expect.err(try(foo3(20, c(1,2,3), plot)), + "foo3: unrecognized unnamed argument\n The call was foo3(x=20, c(1,2,3), plot)") Error : foo3: unrecognized unnamed argument The call was foo3(x=20, c(1,2,3), plot) Got expected error from try(foo3(20, c(1, 2, 3), plot)) > > expect.err(try(foo3(20, c(1,2,3,4,5,6,7,8,9,10,11,12), plot)), + "foo3: unrecognized unnamed argument\n The call was foo3(x=20, c(1,2,3,4,5,6,7,8,9,10,11,12), plot)") Error : foo3: unrecognized unnamed argument The call was foo3(x=20, c(1,2,3,4,5,6,7,8,9,10,11,12), plot) Got expected error from try(foo3(20, c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12), plot)) > > # test that we don't crash because we eval the argument > expect.err(try(foo3(20, y=stop("stop was called"))), "foo3: unrecognized argument 'y'") Error : foo3: unrecognized argument 'y' Got expected error from try(foo3(20, y = stop("stop was called"))) > expect.err(try(foo3(20, stop("stop was called"))), "foo3: unrecognized unnamed argument") Error : foo3: unrecognized unnamed argument The call was foo3(x=20, stop("stopwascalled")) Got expected error from try(foo3(20, stop("stop was called"))) > expect.err(try(foo3(20, cat("side effect\n"))), + "foo3: unrecognized unnamed argument\n The call was foo3(x=20, cat(") Error : foo3: unrecognized unnamed argument The call was foo3(x=20, cat("sideeffect\n")) Got expected error from try(foo3(20, cat("side effect\n"))) > foo2 <- function(...) plotmo:::stop.if.dots(...) > foo2() # ok > expect.err(try(foo2(y=2)), "foo2: unrecognized argument 'y'") Error : foo2: unrecognized argument 'y' Got expected error from try(foo2(y = 2)) > expect.err(try(foo2(2)), "foo2: unrecognized unnamed argument\n The call was foo2(2)") Error : foo2: unrecognized unnamed argument The call was foo2(2) Got expected error from try(foo2(2)) > expect.err(try(foo2(y=plot)), "foo2: unrecognized argument 'y'") Error : foo2: unrecognized argument 'y' Got expected error from try(foo2(y = plot)) > expect.err(try(foo2(plot)), + "foo2: unrecognized unnamed argument\n The call was foo2(plot)") Error : foo2: unrecognized unnamed argument The call was foo2(plot) Got expected error from try(foo2(plot)) > > foo2a <- function(funcarg, ...) funcarg(...) > expect.err(try(foo2a(function(x=1, ...) plotmo:::stop.if.dots(...), x=1, y=2)), "funcarg: unrecognized argument 'y'") Error : funcarg: unrecognized argument 'y' Got expected error from try(foo2a(function(x = 1, ...) plotmo:::stop.if.dots(...), x = 1, y = 2)) > > cat0("=== test warn.if.dots\n") === test warn.if.dots > > options(warn=2) # treat warnings as errors > > foo3 <- function(x=1, ...) plotmo:::warn.if.dots(...) > foo3(1) # ok > expect.err(try(foo3(1, y=2)), "foo3 ignored argument 'y'") Error : (converted from warning) foo3 ignored argument 'y' Got expected error from try(foo3(1, y = 2)) > expect.err(try(foo3(1, 2)), "foo3 ignored unnamed argument\n The call was foo3(x=1, 2)") Error : (converted from warning) foo3 ignored unnamed argument The call was foo3(x=1, 2) Got expected error from try(foo3(1, 2)) > expect.err(try(foo3(1, y=plot)), "foo3 ignored argument 'y'") Error : (converted from warning) foo3 ignored argument 'y' Got expected error from try(foo3(1, y = plot)) > # TODO would like to improve this error messsage > expect.err(try(foo3(1, plot)), + "(converted from warning) foo3 ignored unnamed argument\n The call was foo3(x=1, plot)") Error : (converted from warning) foo3 ignored unnamed argument The call was foo3(x=1, plot) Got expected error from try(foo3(1, plot)) > foo4 <- function(...) plotmo:::warn.if.dots(...) > foo4() # ok > expect.err(try(foo4(y=2)), "foo4 ignored argument 'y'") Error : (converted from warning) foo4 ignored argument 'y' Got expected error from try(foo4(y = 2)) > expect.err(try(foo4(2)), "foo4 ignored unnamed argument\n The call was foo4(2)") Error : (converted from warning) foo4 ignored unnamed argument The call was foo4(2) Got expected error from try(foo4(2)) > expect.err(try(foo4(y=plot)), "foo4 ignored argument 'y'") Error : (converted from warning) foo4 ignored argument 'y' Got expected error from try(foo4(y = plot)) > expect.err(try(foo4(plot)), + "(converted from warning) foo4 ignored unnamed argument\n The call was foo4(plot)") Error : (converted from warning) foo4 ignored unnamed argument The call was foo4(plot) Got expected error from try(foo4(plot)) > > options(warn=1) > > foo3(1, nonesuch=12, nonesuch2=12, 999) # expect three warnings Warning: foo3 ignored argument 'nonesuch' Warning: foo3 ignored argument 'nonesuch2' Warning: foo3 ignored unnamed argument The call was foo3(x=1, nonesuch=12, nonesuch2=12, 999) > > cat0("=== test using sample functions that invoke call.dots\n") === test using sample functions that invoke call.dots > > x <- 1:10 > y <- x * x > lmfit <- lm(y~x) > par(mfrow=c(3, 2)) > par(oma=c(0, 0, 3, 0)) > > # plot1: simple example > # we choose to use predict() here rather than fitted() because nearly all > # models have a fitted() method, but many don't have a fitted() method. > > plot1 <- function(object, ...) + { + residuals <- residuals(object, ...) + + fitted <- predict(object, ...) + + plot(fitted, residuals, ...) + } > plot1(lmfit) > mtext("example plot functions using prefixed dots", outer=TRUE, font=2, line=1, cex=1) > > # Following causes error in predict.lm(). The type argument meant for > # residuals() is also sent to predict.lm(), where it is rejected. > > expect.err(try(plot1(lmfit, type="pearson")), "'arg' should be one of \"response\", \"terms\"") Error in match.arg(type) : 'arg' should be one of "response", "terms" Got expected error from try(plot1(lmfit, type = "pearson")) > > # plot2: use prefixed args > > plot2 <- function(object, ..., TRACE=2) + { + resids <- plotmo:::call.dots(residuals, object=object, ..., TRACE=TRACE) + + fitted <- plotmo:::call.dots(predict, object=object, ..., TRACE=TRACE) + + plotmo:::call.plot(plot, x=fitted, y=resids, ..., TRACE=TRACE) + } > # we can now direct args using the prefixes "residuals.", "predict.", or "plot.") > > plot2(lmfit, residuals.type="pearson") plot2 invoked call.dots TRACE plotmo:::call.dots called deprefix(FUNC=residuals, PREFIX=PREFIX, ..., DROP=DROP, KEEP=KEEP, TRACE=TRACE, FNAME="residuals", FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=CALLARGS, object=lm.object, residuals.type="pearson") PREFIX residuals. DROP .* KEEP >STANDARDPREFIXES|^force\.|^def\.|^drop\. >PREFIX|^residuals\. >CALLARGS|^object$ >EXPLICIT input dotnames object residuals.type after DROP and KEEP object residuals.type return dotnames object type residuals(object=lm.object, type="pearson") plot2 invoked call.dots TRACE plotmo:::call.dots called deprefix(FUNC=predict, PREFIX=PREFIX, ..., DROP=DROP, KEEP=KEEP, TRACE=TRACE, FNAME="predict", FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=CALLARGS, object=lm.object, residuals.type="pearson") PREFIX predict. DROP .* KEEP >STANDARDPREFIXES|^force\.|^def\.|^drop\. >PREFIX|^predict\. >CALLARGS|^object$ >EXPLICIT input dotnames object residuals.type after DROP and KEEP object return dotnames object predict(object=lm.object) plot2 invoked call.dots TRACE plotmo:::call.plot called call.dots(FUNC=plot, PREFIX=PREFIX, ..., DROP="*", KEEP="PREFIX,PLOT.ARGS", TRACE=TRACE, FNAME=fname, FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=function.object, CALLER=caller, x=c(-11,0,11,22,3...), y=c(12,4,-2,-6,-8...), residuals.type="pearson") PREFIX plot. DROP .* KEEP >STANDARDPREFIXES|^force\.|^def\.|^drop\. >PREFIX|^plot\. >CALLARGS|^x$|^y$ >EXPLICIT >PLOT_ARGS|^add$|^adj$|^bty$|^cex$|^cex\.axis$|^cex\.lab$|^cex\.main$|^cex\.sub$|^col$|^col\.axis$|^col\.lab$|^col\.main$|^col\.sub$|^crt$|^family$|^font$|^font$|^font\.axis$|^font\.lab$|^font\.main$|^font\.sub$|^lend$|^ljoin$|^lmitre$|^lty$|^lwd$|^main$|^pch$|^srt$|^xaxp$|^xaxs$|^xaxt$|^xlab$|^xlim$|^xlog$|^xpd$|^yaxp$|^yaxs$|^yaxt$|^ylab$|^ylim$|^ylog$ input dotnames x y residuals.type after DROP and KEEP x y return dotnames x y plot(x=c(-11,0,11,22,3...), y=c(12,4,-2,-6,-8...)) > > # We can also use the usual plot arguments like ylab: call.dots drops > # them; call.plot recognizes them and passes them to lines(). > > plot2(lmfit, residuals.type="pearson", ylab="pearson residuals", main="plot2") plot2 invoked call.dots TRACE plotmo:::call.dots called deprefix(FUNC=residuals, PREFIX=PREFIX, ..., DROP=DROP, KEEP=KEEP, TRACE=TRACE, FNAME="residuals", FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=CALLARGS, object=lm.object, residuals.type="pearson", ylab="pearson residuals", main="plot2") PREFIX residuals. DROP .* KEEP >STANDARDPREFIXES|^force\.|^def\.|^drop\. >PREFIX|^residuals\. >CALLARGS|^object$ >EXPLICIT input dotnames object residuals.type ylab main after DROP and KEEP object residuals.type return dotnames object type residuals(object=lm.object, type="pearson") plot2 invoked call.dots TRACE plotmo:::call.dots called deprefix(FUNC=predict, PREFIX=PREFIX, ..., DROP=DROP, KEEP=KEEP, TRACE=TRACE, FNAME="predict", FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=CALLARGS, object=lm.object, residuals.type="pearson", ylab="pearson residuals", main="plot2") PREFIX predict. DROP .* KEEP >STANDARDPREFIXES|^force\.|^def\.|^drop\. >PREFIX|^predict\. >CALLARGS|^object$ >EXPLICIT input dotnames object residuals.type ylab main after DROP and KEEP object return dotnames object predict(object=lm.object) plot2 invoked call.dots TRACE plotmo:::call.plot called call.dots(FUNC=plot, PREFIX=PREFIX, ..., DROP="*", KEEP="PREFIX,PLOT.ARGS", TRACE=TRACE, FNAME=fname, FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=function.object, CALLER=caller, x=c(-11,0,11,22,3...), y=c(12,4,-2,-6,-8...), residuals.type="pearson", ylab="pearson residuals", main="plot2") PREFIX plot. DROP .* KEEP >STANDARDPREFIXES|^force\.|^def\.|^drop\. >PREFIX|^plot\. >CALLARGS|^x$|^y$ >EXPLICIT >PLOT_ARGS|^add$|^adj$|^bty$|^cex$|^cex\.axis$|^cex\.lab$|^cex\.main$|^cex\.sub$|^col$|^col\.axis$|^col\.lab$|^col\.main$|^col\.sub$|^crt$|^family$|^font$|^font$|^font\.axis$|^font\.lab$|^font\.main$|^font\.sub$|^lend$|^ljoin$|^lmitre$|^lty$|^lwd$|^main$|^pch$|^srt$|^xaxp$|^xaxs$|^xaxt$|^xlab$|^xlim$|^xlog$|^xpd$|^yaxp$|^yaxs$|^yaxt$|^ylab$|^ylim$|^ylog$ input dotnames x y residuals.type ylab main after DROP and KEEP x y ylab main return dotnames x y main ylab plot(x=c(-11,0,11,22,3...), y=c(12,4,-2,-6,-8...), main="plot2", ylab="pearson residuals") > > # plot3: further refinements > # o namespace added to FUNC arg > # o full name for plot.default > # o force. and def. prefixes > # o explicit xlab and ylab for call.plot > # o unprefixed args are passed to residuals() > > plot3 <- function(object, ..., TRACE=2) + { + resids <- plotmo:::call.dots(stats::residuals, + DROP="plotmo:::PLOTARGS,predict.,plot.", + TRACE=TRACE, force.object=object, ...) + + fitted <- plotmo:::call.dots(stats::predict, + force.object=object, TRACE=TRACE, ...) + + plotmo:::call.plot(graphics::plot.default, force.x=fitted, force.y=resids, + def.xlab="fitted", def.ylab="residuals", + TRACE=TRACE, ...) + } > plot3(lmfit, type="pearson", main="plot3a") # type goes only to pearson, no prefix needed plot3 invoked call.dots TRACE plotmo:::call.dots called deprefix(FUNC=residuals, PREFIX=PREFIX, ..., DROP=DROP, KEEP=KEEP, TRACE=TRACE, FNAME="residuals", FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=CALLARGS, force.object=lm.object, type="pearson", main="plot3a") PREFIX residuals. DROP >PREFIX >EXPLICIT|^plotmo:::PLOTARGS|^predict\.|^plot\. KEEP >STANDARDPREFIXES|^force\.|^def\.|^drop\. >PREFIX|^residuals\. >CALLARGS|^force\.object$ >EXPLICIT input dotnames force.object type main after DROP and KEEP force.object type main return dotnames object type main stats::residuals(object=lm.object, type="pearson", main="plot3a") plot3 invoked call.dots TRACE plotmo:::call.dots called deprefix(FUNC=predict, PREFIX=PREFIX, ..., DROP=DROP, KEEP=KEEP, TRACE=TRACE, FNAME="predict", FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=CALLARGS, force.object=lm.object, type="pearson", main="plot3a") PREFIX predict. DROP .* KEEP >STANDARDPREFIXES|^force\.|^def\.|^drop\. >PREFIX|^predict\. >CALLARGS|^force\.object$ >EXPLICIT input dotnames force.object type main after DROP and KEEP force.object return dotnames object stats::predict(object=lm.object) plot3 invoked call.dots TRACE plotmo:::call.plot called call.dots(FUNC=plot.default, PREFIX=PREFIX, ..., DROP="*", KEEP="PREFIX,PLOT.ARGS", TRACE=TRACE, FNAME=fname, FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=function.object, CALLER=caller, force.x=c(-11,0,11,22,3...), force.y=c(12,4,-2,-6,-8...), def.xlab="fitted", def.ylab="residuals", type="pearson", main="plot3a") PREFIX plot. DROP .* KEEP >STANDARDPREFIXES|^force\.|^def\.|^drop\. >PREFIX|^plot\. >CALLARGS|^force\.x$|^force\.y$|^def\.xlab$|^def\.ylab$ >EXPLICIT >PLOT_ARGS|^add$|^adj$|^bty$|^cex$|^cex\.axis$|^cex\.lab$|^cex\.main$|^cex\.sub$|^col$|^col\.axis$|^col\.lab$|^col\.main$|^col\.sub$|^crt$|^family$|^font$|^font$|^font\.axis$|^font\.lab$|^font\.main$|^font\.sub$|^lend$|^ljoin$|^lmitre$|^lty$|^lwd$|^main$|^pch$|^srt$|^xaxp$|^xaxs$|^xaxt$|^xlab$|^xlim$|^xlog$|^xpd$|^yaxp$|^yaxs$|^yaxt$|^ylab$|^ylim$|^ylog$ input dotnames force.x force.y def.xlab def.ylab type main after DROP and KEEP force.x force.y def.xlab def.ylab main return dotnames x y main xlab ylab graphics::plot.default(x=c(-11,0,11,22,3...), y=c(12,4,-2,-6,-8...), main="plot3a", xlab="fitted", ylab="residuals") > plot3(lmfit, type="pearson", predict.type="response", main="plot3b") plot3 invoked call.dots TRACE plotmo:::call.dots called deprefix(FUNC=residuals, PREFIX=PREFIX, ..., DROP=DROP, KEEP=KEEP, TRACE=TRACE, FNAME="residuals", FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=CALLARGS, force.object=lm.object, type="pearson", predict.type="response", main="plot3b") PREFIX residuals. DROP >PREFIX >EXPLICIT|^plotmo:::PLOTARGS|^predict\.|^plot\. KEEP >STANDARDPREFIXES|^force\.|^def\.|^drop\. >PREFIX|^residuals\. >CALLARGS|^force\.object$ >EXPLICIT input dotnames force.object type predict.type main after DROP and KEEP force.object type main return dotnames object type main stats::residuals(object=lm.object, type="pearson", main="plot3b") plot3 invoked call.dots TRACE plotmo:::call.dots called deprefix(FUNC=predict, PREFIX=PREFIX, ..., DROP=DROP, KEEP=KEEP, TRACE=TRACE, FNAME="predict", FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=CALLARGS, force.object=lm.object, type="pearson", predict.type="response", main="plot3b") PREFIX predict. DROP .* KEEP >STANDARDPREFIXES|^force\.|^def\.|^drop\. >PREFIX|^predict\. >CALLARGS|^force\.object$ >EXPLICIT input dotnames force.object type predict.type main after DROP and KEEP force.object predict.type return dotnames object type stats::predict(object=lm.object, type="response") plot3 invoked call.dots TRACE plotmo:::call.plot called call.dots(FUNC=plot.default, PREFIX=PREFIX, ..., DROP="*", KEEP="PREFIX,PLOT.ARGS", TRACE=TRACE, FNAME=fname, FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=function.object, CALLER=caller, force.x=c(-11,0,11,22,3...), force.y=c(12,4,-2,-6,-8...), def.xlab="fitted", def.ylab="residuals", type="pearson", predict.type="response", main="plot3b") PREFIX plot. DROP .* KEEP >STANDARDPREFIXES|^force\.|^def\.|^drop\. >PREFIX|^plot\. >CALLARGS|^force\.x$|^force\.y$|^def\.xlab$|^def\.ylab$ >EXPLICIT >PLOT_ARGS|^add$|^adj$|^bty$|^cex$|^cex\.axis$|^cex\.lab$|^cex\.main$|^cex\.sub$|^col$|^col\.axis$|^col\.lab$|^col\.main$|^col\.sub$|^crt$|^family$|^font$|^font$|^font\.axis$|^font\.lab$|^font\.main$|^font\.sub$|^lend$|^ljoin$|^lmitre$|^lty$|^lwd$|^main$|^pch$|^srt$|^xaxp$|^xaxs$|^xaxt$|^xlab$|^xlim$|^xlog$|^xpd$|^yaxp$|^yaxs$|^yaxt$|^ylab$|^ylim$|^ylog$ input dotnames force.x force.y def.xlab def.ylab type predict.type main after DROP and KEEP force.x force.y def.xlab def.ylab main return dotnames x y main xlab ylab graphics::plot.default(x=c(-11,0,11,22,3...), y=c(12,4,-2,-6,-8...), main="plot3b", xlab="fitted", ylab="residuals") > > cat0("=== test callers.name\n") === test callers.name > > test.callers.name <- function(x) { + caller0 <- plotmo:::callers.name(0) # test.callers.name + caller1 <- plotmo:::callers.name(1) # caller of test.callers.name + caller99 <- plotmo:::callers.name(99) # sys.call(-n) : not that many frames on the stack + s <- sprint("0 %s 1 %s 99 %s", caller0, caller1, caller99) + cat(s, "\n", sep="") + s + } > print(plotmo:::callers.name()) # "eval" [1] "NULL" > myfunc <- function(func) func() > stopifnot(myfunc(function(x) test.callers.name(99)) == "0 test.callers.name 1 func 99 unknown") 0 test.callers.name 1 func 99 unknown > stopifnot(test.callers.name() == "0 test.callers.name 1 stopifnot 99 unknown") 0 test.callers.name 1 stopifnot 99 unknown > > source("test.epilog.R") plotmo/inst/slowtests/test.parsnip.Rout.save0000644000176200001440000010665414567065443021104 0ustar liggesusers> # test.parsnip.R: test the parsnip package with earth and other models > # Stephen Milborrow Sep 2020 Petaluma > > source("test.prolog.R") > options(warn=1) # print warnings as they occur > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix > cat("loading parsnip libraries\n") # these libraries take several seconds to load loading parsnip libraries > library(tidymodels, quietly=TRUE, verbose=FALSE) ── Attaching packages ────────────────────────────────────── tidymodels 1.1.1 ── ✔ broom 1.0.5 ✔ recipes 1.0.9 ✔ dials 1.2.0 ✔ rsample 1.2.0 ✔ dplyr 1.1.4 ✔ tibble 3.2.1 ✔ ggplot2 3.4.4 ✔ tidyr 1.3.1 ✔ infer 1.0.6 ✔ tune 1.1.2 ✔ modeldata 1.3.0 ✔ workflows 1.1.3 ✔ parsnip 1.1.1 ✔ workflowsets 1.0.1 ✔ purrr 1.0.2 ✔ yardstick 1.3.0 ── Conflicts ───────────────────────────────────────── tidymodels_conflicts() ── ✖ purrr::discard() masks scales::discard() ✖ dplyr::filter() masks stats::filter() ✖ dplyr::lag() masks stats::lag() ✖ recipes::step() masks stats::step() > library(timetk) > library(lubridate) Attaching package: 'lubridate' The following objects are masked from 'package:base': date, intersect, setdiff, union > cat("loaded parsnip libraries\n") loaded parsnip libraries > cat("parsnip version:", as.character(packageVersion("parsnip")[[1]]), "\n") parsnip version: 1.1.1 > > vdata <- data.frame( + resp = 1:23, + bool = c(F, F, F, F, F, T, T, T, T, T, T, T, T, F, F, T, T, T, T, T, T, T, T), + ord = ordered(c("ORD1", "ORD1", "ORD1", + "ORD1", "ORD1", "ORD1", + "ORD1", "ORD3", "ORD1", + "ORD2", "ORD2", "ORD2", "ORD2", + "ORD2", "ORD2", "ORD2", + "ORD3", "ORD3", "ORD3", + "ORD2", "ORD2", "ORD2", "ORD2"), + levels=c("ORD1", "ORD3", "ORD2")), + fac = as.factor(c("FAC1", "FAC1", "FAC1", + "FAC2", "FAC2", "FAC2", + "FAC3", "FAC1", "FAC1", + "FAC1", "FAC2", "FAC2", "FAC2", + "FAC2", "FAC2", "FAC2", + "FAC3", "FAC3", "FAC3", + "FAC1", "FAC3", "FAC3", "FAC3")), + str = c("STR1", "STR1", "STR1", # WILL BE TREATED LIKE A FACTOR + "STR1", "STR1", "STR1", + "STR2", "STR2", "STR2", + "STR3", "STR3", "STR2", "STR3", + "STR2", "STR3", "STR2", + "STR3", "STR3", "STR3", + "STR3", "STR3", "STR3", "STR3"), + num = c(1, 9, 2, 3, 14, 5, 6, 4, 5, 6.5, 3, 6, 5, + 3, 4, 5, 6, 4, 5, 16.5, 3, 16, 15), + sqrt_num = sqrt( + c(1, 9, 2, 3, 14, 5, 6, 4, 5, 6.5, 3, 6, 5, + 3, 4, 5, 6, 4, 5, 16.5, 3, 16, 15)), + int = c(1L, 1L, 3L, 3L, 4L, 4L, 3L, 5L, 3L, 6L, 7L, 8L, 10L, + 13L, 14L, 3L, 13L, 5L, 13L, 16L, 17L, 18L, 11L), + date = as.Date( + c("2018-08-01", "2018-08-02", "2018-08-03", + "2018-08-04", "2018-08-05", "2018-08-06", + "2018-08-07", "2018-08-08", "2018-08-08", + "2018-08-10", "2018-08-10", "2018-08-11", "2018-08-11", + "2018-08-11", "2018-08-12", "2018-08-13", + "2018-08-10", "2018-08-15", "2018-08-17", + "2018-08-04", "2018-08-19", "2018-08-03", "2018-08-18")), + date_num = as.numeric(as.Date( + c("2018-08-01", "2018-08-02", "2018-08-03", + "2018-08-04", "2018-08-05", "2018-08-06", + "2018-08-07", "2018-08-08", "2018-08-08", + "2018-08-10", "2018-08-10", "2018-08-11", "2018-08-11", + "2018-08-11", "2018-08-12", "2018-08-13", + "2018-08-10", "2018-08-15", "2018-08-17", + "2018-08-04", "2018-08-19", "2018-08-03", "2018-08-18")))) > > set.seed(2020) > splits <- initial_time_split(vdata, prop=.9) > > #--- lm ---------------------------------------------------------------------- > > lm1 <- lm(resp~num+fac:int+date+ord+str, data=training(splits)) > cat("lm1:\n") lm1: > print(summary(lm1)) Call: lm(formula = resp ~ num + fac:int + date + ord + str, data = training(splits)) Residuals: Min 1Q Median 3Q Max -3.9119 -0.6559 -0.0438 0.7549 3.1946 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) -1.396e+04 5.559e+03 -2.511 0.0309 * num 1.818e-01 1.883e-01 0.966 0.3571 date 7.867e-01 3.132e-01 2.512 0.0308 * ord.L 1.254e+00 2.009e+00 0.624 0.5465 ord.Q 3.783e-01 1.910e+00 0.198 0.8470 strSTR2 5.801e-01 2.381e+00 0.244 0.8124 strSTR3 3.341e-01 3.136e+00 0.107 0.9173 facFAC1:int 6.908e-01 3.066e-01 2.253 0.0479 * facFAC2:int 2.891e-01 2.116e-01 1.366 0.2018 facFAC3:int 5.818e-01 2.621e-01 2.220 0.0507 . --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 2.341 on 10 degrees of freedom Multiple R-squared: 0.9176, Adjusted R-squared: 0.8435 F-statistic: 12.38 on 9 and 10 DF, p-value: 0.0002531 > set.seed(2020) > lmpar <- linear_reg(mode = "regression") %>% + set_engine("lm") %>% + fit(resp~num+fac:int+date+ord+str, data = training(splits)) > stopifnot(identical(lm1$coeff, lmpar$fit$coeff)) > > predict.lm1 <- predict(lm1, testing(splits)) > predict.lmpar <- lmpar %>% predict(testing(splits)) > stopifnot(all(predict.lm1 == predict.lmpar)) > > par(mfrow = c(3, 3), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) > plotmo(lm1, do.par=2, SHOWCALL=TRUE) plotmo grid: num fac int date ord str 5 FAC2 5 2018-08-09 ORD1 STR3 > plotres(lm1, which=c(3,1), do.par=FALSE) > plotmo(lmpar, do.par=2, SHOWCALL=TRUE) plotmo grid: num fac int date ord str 5 FAC2 5 2018-08-09 ORD1 STR3 > plotres(lmpar, which=c(3,1), do.par=FALSE) > plotmo(lmpar$fit, do.par=2, SHOWCALL=TRUE) plotmo grid: num fac int date ord str 5 FAC2 5 2018-08-09 ORD1 STR3 > plotres(lmpar$fit, which=c(3,1), do.par=FALSE) > par(org.par) > > lmpar.sqrtnum <- linear_reg(mode = "regression") %>% + set_engine("lm") %>% + fit(resp~sqrt(num), data = training(splits)) > #$$ TODO > # expect.err(try(plotmo(lmpar.sqrtnum)), > # "cannot get the original model predictors") > > #--- earth ------------------------------------------------------------------- > > # note that sqrt(num) is ok, unlike parsnip models for lm and rpart > earth1 <- earth(resp~sqrt(num)+int+ord:bool+fac+str+date, degree=2, + data=training(splits), pmethod="none") > cat("earth1:\n") earth1: > print(summary(earth1)) Call: earth(formula=resp~sqrt(num)+int+ord:bool+fac+str+date, data=training(splits), pmethod="none", degree=2) coefficients (Intercept) 7.86702 ordORD2:boolTRUE -0.81733 h(5-int) 0.46965 h(int-5) 2587.95933 h(17751-date) -1.23206 h(date-17751) 1.48020 h(int-5) * facFAC2 -0.35097 h(int-5) * date -0.14573 Selected 8 of 8 terms, and 4 of 13 predictors (pmethod="none") Termination condition: GRSq -Inf at 8 terms Importance: int, date, facFAC2, ordORD2:boolTRUE, sqrt(num)-unused, ... Number of terms at each degree of interaction: 1 5 2 GCV 19.29495 RSS 2.170681 GRSq 0.47628 RSq 0.9967358 > set.seed(2020) > earthpar <- mars(mode = "regression", prune_method="none", prod_degree=2) %>% + set_engine("earth") %>% + fit(resp~sqrt(num)+int+ord:bool+fac+str+date, data = training(splits)) > cat("earthpar:\n") earthpar: > print(earthpar) parsnip model object Selected 8 of 8 terms, and 4 of 13 predictors (pmethod="none") Termination condition: GRSq -Inf at 8 terms Importance: int, date, facFAC2, ordORD2:boolTRUE, sqrt(num)-unused, ... Number of terms at each degree of interaction: 1 5 2 GCV 19.29495 RSS 2.170681 GRSq 0.47628 RSq 0.9967358 > cat("summary(earthpar$fit)\n") summary(earthpar$fit) > print(summary(earthpar$fit)) Call: earth(formula=resp~sqrt(num)+int+ord:bool+fac+str+date, data=data, pmethod=~"none", keepxy=TRUE, degree=~2) coefficients (Intercept) 7.86702 ordORD2:boolTRUE -0.81733 h(5-int) 0.46965 h(int-5) 2587.95933 h(17751-date) -1.23206 h(date-17751) 1.48020 h(int-5) * facFAC2 -0.35097 h(int-5) * date -0.14573 Selected 8 of 8 terms, and 4 of 13 predictors (pmethod="none") Termination condition: GRSq -Inf at 8 terms Importance: int, date, facFAC2, ordORD2:boolTRUE, sqrt(num)-unused, ... Number of terms at each degree of interaction: 1 5 2 GCV 19.29495 RSS 2.170681 GRSq 0.47628 RSq 0.9967358 > stopifnot(identical(earth1$coeff, earthpar$fit$coeff)) > > predict.earth1 <- predict(earth1, testing(splits)) > predict.earthpar <- earthpar %>% predict(testing(splits)) > stopifnot(all(predict.earth1 == predict.earthpar)) > > par(mfrow = c(3, 3), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) > plotmo(earth1, do.par=2, pt.col=3, SHOWCALL=TRUE) plotmo grid: num int ord bool fac str date 5 5 ORD1 TRUE FAC2 STR3 2018-08-09 > set.seed(2020) > plotres(earth1, which=c(1,3), do.par=FALSE, pt.col=3, legend.pos="topleft") > par(org.par) > > par(mfrow = c(3, 3), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) > plotmo(earthpar, do.par=2, pt.col=3, SHOWCALL=TRUE) plotmo grid: num int ord bool fac str date 5 5 ORD1 TRUE FAC2 STR3 2018-08-09 > set.seed(2020) > plotres(earthpar, which=c(1,3), do.par=FALSE, pt.col=3, legend.pos="topleft") > par(org.par) > > par(mfrow = c(3, 3), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) > plotmo(earthpar$fit, do.par=2, pt.col=3, SHOWCALL=TRUE) plotmo grid: num int ord bool fac str date 5 5 ORD1 TRUE FAC2 STR3 2018-08-09 > set.seed(2020) > plotres(earthpar$fit, which=c(1,3), do.par=FALSE, pt.col=3, legend.pos="topleft") > par(org.par) > > #--- rpart ------------------------------------------------------------------- > > library(rpart) Attaching package: 'rpart' The following object is masked from 'package:dials': prune > library(rpart.plot) > rpart1 <- rpart(resp~num+fac+int+date+ord+str, data=training(splits), + control=rpart.control(minsplit=1, cp=.0001)) > cat("\nrpart.rules(rpart1)\n") rpart.rules(rpart1) > print(rpart.rules(rpart1)) resp 1 when ord is ORD1 & date < 17748 & num < 5.0 & int < 2 2 when ord is ORD1 & date < 17748 & num >= 5.0 & int < 2 3 when ord is ORD1 & date < 17748 & num < 2.5 & int >= 2 4 when ord is ORD1 & date < 17748 & num >= 2.5 & int >= 2 5 when ord is ORD1 & date >= 17748 & num >= 10.0 & fac is FAC2 or FAC3 6 when ord is ORD1 & date >= 17748 & num < 5.5 & fac is FAC2 or FAC3 7 when ord is ORD1 & date >= 17748 & num is 5.5 to 10.0 & fac is FAC2 or FAC3 9 when ord is ORD1 & date >= 17748 & fac is FAC1 14 when ord is ORD3 or ORD2 > > set.seed(2020) > # TODO note need of model=TRUE below (needed only for further processing with e.g. plotmo) > rpartpar <- decision_tree(mode = "regression", min_n=1, cost_complexity=.0001) %>% + set_engine("rpart", model=TRUE) %>% + fit(resp~num+fac+int+date+ord+str, data = training(splits)) > cat("\nrpart.rules(rpartpar$fit)\n") rpart.rules(rpartpar$fit) > print(rpart.rules(rpartpar$fit)) resp 1 when ord is ORD1 & date < 17748 & num < 5.0 & int < 2 2 when ord is ORD1 & date < 17748 & num >= 5.0 & int < 2 3 when ord is ORD1 & date < 17748 & num < 2.5 & int >= 2 4 when ord is ORD1 & date < 17748 & num >= 2.5 & int >= 2 5 when ord is ORD1 & date >= 17748 & num >= 10.0 & fac is FAC2 or FAC3 6 when ord is ORD1 & date >= 17748 & num < 5.5 & fac is FAC2 or FAC3 7 when ord is ORD1 & date >= 17748 & num is 5.5 to 10.0 & fac is FAC2 or FAC3 9 when ord is ORD1 & date >= 17748 & fac is FAC1 14 when ord is ORD3 or ORD2 > > predict.rpart1 <- predict(rpart1, testing(splits)) > predict.rpartpar <- rpartpar %>% predict(testing(splits)) > stopifnot(all(predict.rpart1 == predict.rpartpar)) > > par(mfrow = c(3, 3), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) > plotmo(rpart1, do.par=2, SHOWCALL=TRUE, trace=0) plotmo grid: num fac int date ord str 5 FAC2 5 2018-08-09 ORD1 STR3 > plotres(rpart1, which=c(3,1), do.par=FALSE) > plotmo(rpartpar, do.par=2, SHOWCALL=TRUE, trace=0) plotmo grid: num fac int date ord str 5 FAC2 5 2018-08-09 ORD1 STR3 > plotres(rpartpar, which=c(3,1), do.par=FALSE) > plotmo(rpartpar$fit, do.par=2, SHOWCALL=TRUE) plotmo grid: num fac int date ord str 5 FAC2 5 2018-08-09 ORD1 STR3 > plotres(rpartpar$fit, which=c(3,1), do.par=FALSE) > par(org.par) > > # TODO note that this differs from the above rpart model in that we don't use model=TRUE > rpartpar.nosavemodel <- decision_tree(mode = "regression", min_n=1, cost_complexity=.0001) %>% + set_engine("rpart") %>% + fit(resp~num+fac+int+date+str, data = training(splits)) > > cat("\nrpart.rules(rpartpar.nosavemodel$fit)\n") rpart.rules(rpartpar.nosavemodel$fit) > options(warn=2) > expect.err(try(rpart.rules(rpartpar.nosavemodel$fit)), + "Cannot retrieve the data used to build the model") Error : (converted from warning) Cannot retrieve the data used to build the model (so cannot determine roundint and is.binary for the variables). To silence this warning: Call rpart.rules with roundint=FALSE, or rebuild the rpart model with model=TRUE. Got expected error from try(rpart.rules(rpartpar.nosavemodel$fit)) > options(warn=1) > expect.err(try(plotmo(rpartpar.nosavemodel)), + "Cannot plot parsnip rpart model: need model=TRUE in call to rpart") Error : Cannot plot parsnip rpart model: need model=TRUE in call to rpart Do it like this: set_engine("rpart", model=TRUE) Got expected error from try(plotmo(rpartpar.nosavemodel)) > > rpart.sqrtnum <- decision_tree(mode = "regression", min_n=1, cost_complexity=.0001) %>% + set_engine("rpart", model=TRUE) %>% + fit(resp~sqrt(num)+fac+int+date+ord+str, data = training(splits)) > cat("\nrpart.rules(rpart.sqrtnum$fit)\n") rpart.rules(rpart.sqrtnum$fit) > print(rpart.rules(rpart.sqrtnum$fit)) # ok resp 1 when ord is ORD1 & date < 17748 & sqrt(num) < 2.0 & int < 2 2 when ord is ORD1 & date < 17748 & sqrt(num) >= 2.0 & int < 2 3 when ord is ORD1 & date < 17748 & sqrt(num) < 1.6 & int >= 2 4 when ord is ORD1 & date < 17748 & sqrt(num) >= 1.6 & int >= 2 5 when ord is ORD1 & date >= 17748 & sqrt(num) >= 3.1 & fac is FAC2 or FAC3 6 when ord is ORD1 & date >= 17748 & sqrt(num) < 2.3 & fac is FAC2 or FAC3 7 when ord is ORD1 & date >= 17748 & sqrt(num) is 2.3 to 3.1 & fac is FAC2 or FAC3 9 when ord is ORD1 & date >= 17748 & fac is FAC1 14 when ord is ORD3 or ORD2 > #$$ TODO > # expect.err(try(plotmo(rpart.sqrtnum)), > # "cannot get the original model predictors") > > #----------------------------------------------------------------------------------- > # Test fix for github bug report https://github.com/tidymodels/parsnip/issues/341 > # (fixed Sep 2020) > > cat("===m750a first example===\n") ===m750a first example=== > set.seed(2020) > m750a <- m4_monthly %>% + filter(id == "M750") %>% + select(-id) > print(m750a) # a tibble # A tibble: 306 × 2 date value 1 1990-01-01 6370 2 1990-02-01 6430 3 1990-03-01 6520 4 1990-04-01 6580 5 1990-05-01 6620 6 1990-06-01 6690 7 1990-07-01 6000 8 1990-08-01 5450 9 1990-09-01 6480 10 1990-10-01 6820 # ℹ 296 more rows > set.seed(2020) > splits_a <- initial_time_split(m750a, prop = 0.9) > earth_m750a <- earth(log(value) ~ as.numeric(date) + month(date, label = TRUE), data = training(splits_a), degree=2) > print(summary(earth_m750a)) Call: earth(formula=log(value)~as.numeric(date)+month(date,label=TRUE), data=training(splits_a), degree=2) coefficients (Intercept) 1.000000e+01 h(as.numeric(date)-7639) 0.000000e+00 h(as.numeric(date)-9100) 0.000000e+00 h(12022-as.numeric(date)) 0.000000e+00 h(as.numeric(date)-13483) 0.000000e+00 h(as.numeric(date)-14579) 0.000000e+00 h(0.370142-month(date, label = TRUE)^7) 0.000000e+00 h(month(date, label = TRUE)^7-0.370142) 0.000000e+00 h(month(date, label = TRUE)^10-0.491049) -3.077492e+12 h(as.numeric(date)-9100) * h(-0.254544-month(date, label = TRUE)^8) 0.000000e+00 h(as.numeric(date)-13483) * h(month(date, label = TRUE)^11- -0.392904) 0.000000e+00 h(as.numeric(date)-13483) * h(-0.392904-month(date, label = TRUE)^11) 0.000000e+00 h(0.491049-month(date, label = TRUE)^10) * h(month(date, label = TRUE)^11-0.065484) 0.000000e+00 h(0.491049-month(date, label = TRUE)^10) * h(0.065484-month(date, label = TRUE)^11) 0.000000e+00 Selected 14 of 17 terms, and 5 of 12 predictors Termination condition: RSq changed by less than 0.001 at 17 terms Importance: as.numeric(date), month(date, label = TRUE)^10, ... Number of terms at each degree of interaction: 1 8 5 GCV 0.0004725457 RSS 0.1002179 GRSq 0.9834104 RSq 0.9871125 > set.seed(2020) > model_m750a <- mars(mode = "regression", prod_degree=2) %>% + set_engine("earth") %>% + fit(log(value) ~ as.numeric(date) + month(date, label = TRUE), data = training(splits_a)) > print(summary(model_m750a$fit)) Call: earth(formula=log(value)~as.numeric(date)+month(date,label=TRUE), data=data, keepxy=TRUE, degree=~2) coefficients (Intercept) 1.000000e+01 h(as.numeric(date)-7639) 0.000000e+00 h(as.numeric(date)-9100) 0.000000e+00 h(12022-as.numeric(date)) 0.000000e+00 h(as.numeric(date)-13483) 0.000000e+00 h(as.numeric(date)-14579) 0.000000e+00 h(0.370142-month(date, label = TRUE)^7) 0.000000e+00 h(month(date, label = TRUE)^7-0.370142) 0.000000e+00 h(month(date, label = TRUE)^10-0.491049) -3.077492e+12 h(as.numeric(date)-9100) * h(-0.254544-month(date, label = TRUE)^8) 0.000000e+00 h(as.numeric(date)-13483) * h(month(date, label = TRUE)^11- -0.392904) 0.000000e+00 h(as.numeric(date)-13483) * h(-0.392904-month(date, label = TRUE)^11) 0.000000e+00 h(0.491049-month(date, label = TRUE)^10) * h(month(date, label = TRUE)^11-0.065484) 0.000000e+00 h(0.491049-month(date, label = TRUE)^10) * h(0.065484-month(date, label = TRUE)^11) 0.000000e+00 Selected 14 of 17 terms, and 5 of 12 predictors Termination condition: RSq changed by less than 0.001 at 17 terms Importance: as.numeric(date), month(date, label = TRUE)^10, ... Number of terms at each degree of interaction: 1 8 5 GCV 0.0004725457 RSS 0.1002179 GRSq 0.9834104 RSq 0.9871125 > stopifnot(identical(earth_m750a$coeff, model_m750a$fit$coeff)) > predict_earth_m750a <- predict(earth_m750a, newdata=testing(splits_a)[1:3,]) > predict_m750a <- model_m750a %>% predict(testing(splits_a)[1:3,]) > stopifnot(max(c(9.238049628, 9.240535151, 9.232361834) - predict_m750a) < 1e-8) > stopifnot(max(predict_earth_m750a - predict_m750a) < 1e-20) > > par(mfrow = c(2, 2), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) > set.seed(2020) > plotmo(model_m750a, trace=2, do.par=FALSE, pt.col="green", main="model_m750a", SHOWCALL=TRUE) plotmo trace 2: plotmo(object=model_m750a, pt.col="green", do.par=FALSE, trace=2, main="model_m750a", SHOWCALL=TRUE) --get.model.env for object with class _earth plotmo parsnip model: will plot model_m750a$fit, not 'model_m750a' itself object call is earth(formula=log(value)~as.numeric(date)+month(date, label=TRUE), data=data, keepxy=TRUE, degree=~2) using the environment saved in $terms of the earth model: env(data, weights) --plotmo_prolog for _earth object 'model_m750a' --plotmo_x for earth object get.object.x: object$x is NULL (and it has no colnames) object call is earth(formula=log(value)~as.numeric(date)+month(date, label=TRUE), data=data,... get.x.from.model.frame: formula(object) is log(value) ~ as.numeric(date) + month(date, label = TRUE) naked formula is log(value) ~ date formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) object$data is usable and has column names date value na.action(object) is "na.fail" stats::model.frame(log(value) ~ date, data=object$data, na.action="na.fail") x=model.frame[,-1] is usable and has column name date plotmo_x returned[275,1]: date 1 1990-01-01 2 1990-02-01 3 1990-03-01 ... 1990-04-01 275 2012-11-01 ----Metadata: plotmo_predict with nresponse=NULL and newdata=NULL calling predict.earth with NULL newdata stats::predict(earth.object, NULL, type="response") predict returned[275,1]: log(value) 1 8.779940 2 8.777069 3 8.795003 ... 8.799953 275 9.244442 predict after processing with nresponse=NULL is [275,1]: log(value) 1 8.779940 2 8.777069 3 8.795003 ... 8.799953 275 9.244442 ----Metadata: plotmo_fitted with nresponse=NULL stats::fitted(object=earth.object) fitted(object) returned[275,1]: log(value) 1 8.779940 2 8.777069 3 8.795003 ... 8.799953 275 9.244442 fitted(object) after processing with nresponse=NULL is [275,1]: log(value) 1 8.779940 2 8.777069 3 8.795003 ... 8.799953 275 9.244442 ----Metadata: plotmo_y with nresponse=NULL --plotmo_y with nresponse=NULL for earth object get.object.y: object$y is usable and has column name log(value) plotmo_y returned[275,1]: log(value) 1 8.759355 2 8.768730 3 8.782630 ... 8.791790 275 9.271435 plotmo_y after processing with nresponse=NULL is [275,1]: log(value) 1 8.759355 2 8.768730 3 8.782630 ... 8.791790 275 9.271435 converted nresponse=NA to nresponse=1 nresponse=1 (was NA) ncol(fitted) 1 ncol(predict) 1 ncol(y) 1 ----Metadata: plotmo_y with nresponse=1 --plotmo_y with nresponse=1 for earth object get.object.y: object$y is usable and has column name log(value) got model response from object$y plotmo_y returned[275,1]: log(value) 1 8.759355 2 8.768730 3 8.782630 ... 8.791790 275 9.271435 plotmo_y after processing with nresponse=1 is [275,1]: log(value) 1 8.759355 2 8.768730 3 8.782630 ... 8.791790 275 9.271435 got response name "log(value)" from yhat resp.levs is NULL ----Metadata: done number of x values: date 275 ----plotmo_singles for earth object singles: 1 date ----plotmo_pairs for earth object no pairs ----Figuring out ylim --get.ylim.by.dummy.plots --plot.degree1(draw.plot=FALSE) degree1 plot1 (pmethod "plotmo") variable date newdata[50,1]: date 1 1990-01-01 2 1990-06-20 3 1990-12-07 ... 1991-05-26 50 2012-11-01 stats::predict(earth.object, data.frame[50,1], type="response") predict returned[50,1]: log(value) 1 8.779940 2 8.797283 3 8.835027 ... 8.843453 50 9.244442 predict after processing with nresponse=1 is [50,1]: log(value) 1 8.779940 2 8.797283 3 8.835027 ... 8.843453 50 9.244442 --done get.ylim.by.dummy.plots ylim c(8.603, 9.289) clip TRUE --plot.degree1(draw.plot=TRUE) graphics::plot.default(x=Date:1990-01-01 1990-06-20 1990-12..., y=c(8.78,8.797,8...), type="n", main="model_m750a", xlab="", ylab="", xaxt="s", yaxt="s", xlim=Date:1990-01-01 2012-11-01, ylim=c(8.603,9.289)) > set.seed(2020) > plotmo(model_m750a$fit, trace=1, do.par=FALSE, pt.col="green", main="model_m750a$fit", SHOWCALL=TRUE) stats::predict(earth.object, NULL, type="response") stats::fitted(object=earth.object) got model response from object$y > set.seed(2020) > plotmo(earth_m750a, trace=1, do.par=FALSE, pt.col="green", main="earth_m750a", SHOWCALL=TRUE) stats::predict(earth.object, NULL, type="response") stats::fitted(object=earth.object) got model response from model.frame(log(value) ~ as.numeric(date) + month..., data=call$data, na.action="na.fail") > par(org.par) > > cat("===m750a second example===\n") ===m750a second example=== > set.seed(2020) > m750b <- m4_monthly %>% + filter(id == "M750") %>% + select(-id) %>% + rename(date2 = date) > print(m750b) # tibble # A tibble: 306 × 2 date2 value 1 1990-01-01 6370 2 1990-02-01 6430 3 1990-03-01 6520 4 1990-04-01 6580 5 1990-05-01 6620 6 1990-06-01 6690 7 1990-07-01 6000 8 1990-08-01 5450 9 1990-09-01 6480 10 1990-10-01 6820 # ℹ 296 more rows > set.seed(2020) > splits_b <- initial_time_split(m750b, prop = 0.9) > set.seed(2020) > model_m750b <- mars(mode = "regression") %>% + set_engine("earth") %>% + fit(log(value) ~ as.numeric(date2) + month(date2, label = TRUE), data = training(splits_b)) > # new data that only contains the feature "date" as a predictor > future_data <- m750b %>% future_frame(date2, .length_out = "3 years") > print(future_data) # a tibble with a single column of class "Date" # A tibble: 36 × 1 date2 1 2015-07-01 2 2015-08-01 3 2015-09-01 4 2015-10-01 5 2015-11-01 6 2015-12-01 7 2016-01-01 8 2016-02-01 9 2016-03-01 10 2016-04-01 # ℹ 26 more rows > stopifnot(class(future_data[,1,drop=TRUE]) == "Date") > predict_m750a <- model_m750b %>% predict(new_data = future_data) > > par(mfrow = c(2, 2), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) > set.seed(2020) > plotmo(model_m750b, trace=2, do.par=FALSE, pt.col="green", main="model_m750b", SHOWCALL=TRUE) plotmo trace 2: plotmo(object=model_m750b, pt.col="green", do.par=FALSE, trace=2, main="model_m750b", SHOWCALL=TRUE) --get.model.env for object with class _earth plotmo parsnip model: will plot model_m750b$fit, not 'model_m750b' itself object call is earth(formula=log(value)~as.numeric(date2)+month(date2, label=TRUE), data=data, keepxy=TRUE) using the environment saved in $terms of the earth model: env(data, weights) --plotmo_prolog for _earth object 'model_m750b' --plotmo_x for earth object get.object.x: object$x is NULL (and it has no colnames) object call is earth(formula=log(value)~as.numeric(date2)+month(date2, label=TRUE), data=dat... get.x.from.model.frame: formula(object) is log(value) ~ as.numeric(date2) + month(date2, label = TRUE) naked formula is log(value) ~ date2 formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) object$data is usable and has column names date2 value na.action(object) is "na.fail" stats::model.frame(log(value) ~ date2, data=object$data, na.action="na.fail") x=model.frame[,-1] is usable and has column name date2 plotmo_x returned[275,1]: date2 1 1990-01-01 2 1990-02-01 3 1990-03-01 ... 1990-04-01 275 2012-11-01 ----Metadata: plotmo_predict with nresponse=NULL and newdata=NULL calling predict.earth with NULL newdata stats::predict(earth.object, NULL, type="response") predict returned[275,1]: log(value) 1 8.773349 2 8.779320 3 8.797022 ... 8.803553 275 9.243245 predict after processing with nresponse=NULL is [275,1]: log(value) 1 8.773349 2 8.779320 3 8.797022 ... 8.803553 275 9.243245 ----Metadata: plotmo_fitted with nresponse=NULL stats::fitted(object=earth.object) fitted(object) returned[275,1]: log(value) 1 8.773349 2 8.779320 3 8.797022 ... 8.803553 275 9.243245 fitted(object) after processing with nresponse=NULL is [275,1]: log(value) 1 8.773349 2 8.779320 3 8.797022 ... 8.803553 275 9.243245 ----Metadata: plotmo_y with nresponse=NULL --plotmo_y with nresponse=NULL for earth object get.object.y: object$y is usable and has column name log(value) plotmo_y returned[275,1]: log(value) 1 8.759355 2 8.768730 3 8.782630 ... 8.791790 275 9.271435 plotmo_y after processing with nresponse=NULL is [275,1]: log(value) 1 8.759355 2 8.768730 3 8.782630 ... 8.791790 275 9.271435 converted nresponse=NA to nresponse=1 nresponse=1 (was NA) ncol(fitted) 1 ncol(predict) 1 ncol(y) 1 ----Metadata: plotmo_y with nresponse=1 --plotmo_y with nresponse=1 for earth object get.object.y: object$y is usable and has column name log(value) got model response from object$y plotmo_y returned[275,1]: log(value) 1 8.759355 2 8.768730 3 8.782630 ... 8.791790 275 9.271435 plotmo_y after processing with nresponse=1 is [275,1]: log(value) 1 8.759355 2 8.768730 3 8.782630 ... 8.791790 275 9.271435 got response name "log(value)" from yhat resp.levs is NULL ----Metadata: done number of x values: date2 275 ----plotmo_singles for earth object singles: 1 date2 ----plotmo_pairs for earth object no pairs ----Figuring out ylim --get.ylim.by.dummy.plots --plot.degree1(draw.plot=FALSE) degree1 plot1 (pmethod "plotmo") variable date2 newdata[50,1]: date2 1 1990-01-01 2 1990-06-20 3 1990-12-07 ... 1991-05-26 50 2012-11-01 stats::predict(earth.object, data.frame[50,1], type="response") predict returned[50,1]: log(value) 1 8.773349 2 8.797894 3 8.831375 ... 8.848941 50 9.243245 predict after processing with nresponse=1 is [50,1]: log(value) 1 8.773349 2 8.797894 3 8.831375 ... 8.848941 50 9.243245 --done get.ylim.by.dummy.plots ylim c(8.603, 9.289) clip TRUE --plot.degree1(draw.plot=TRUE) graphics::plot.default(x=Date:1990-01-01 1990-06-20 1990-12..., y=c(8.773,8.798,8...), type="n", main="model_m750b", xlab="", ylab="", xaxt="s", yaxt="s", xlim=Date:1990-01-01 2012-11-01, ylim=c(8.603,9.289)) > set.seed(2020) > plotmo(model_m750b$fit, trace=1, do.par=FALSE, pt.col="green", main="model_m750b$fit", SHOWCALL=TRUE) stats::predict(earth.object, NULL, type="response") stats::fitted(object=earth.object) got model response from object$y > par(org.par) > > #----------------------------------------------------------------------------------- > # multiple response earth model > > data(etitanic) > > etit <- etitanic > etit$survived <- factor(ifelse(etitanic$survived == 1, "yes", "no"), + levels = c("yes", "no")) > etit$notsurvived <- factor(ifelse(etitanic$survived == 0, "notsurvived", "survived"), + levels = c("notsurvived", "survived")) > set.seed(2020) > earth_tworesp <- earth(survived + notsurvived ~ ., data=etit, degree=2) > print(summary(earth_tworesp)) Call: earth(formula=survived+notsurvived~., data=etit, degree=2) survived notsurvived (Intercept) 0.03829050 0.96170950 pclass3rd 0.81545352 -0.81545352 sexmale 0.57003496 -0.57003496 h(age-32) 0.00471938 -0.00471938 pclass2nd * sexmale 0.26568920 -0.26568920 pclass3rd * sexmale -0.19310203 0.19310203 pclass3rd * h(4-sibsp) -0.10222181 0.10222181 sexmale * h(16-age) -0.04505232 0.04505232 Selected 8 of 17 terms, and 5 of 6 predictors Termination condition: Reached nk 21 Importance: sexmale, pclass3rd, pclass2nd, age, sibsp, parch-unused Number of terms at each degree of interaction: 1 3 4 GCV RSS GRSq RSq survived 0.1404529 141.7629 0.4197106 0.4389834 notsurvived 0.1404529 141.7629 0.4197106 0.4389834 All 0.2809057 283.5258 0.4197106 0.4389834 > > # TODO following commented out because parsnip (version 0.1.5) says "'+' not meaningful for factors" > # set.seed(2020) > # mars_tworesp <- mars(mode = "regression", prod_degree=2) %>% > # set_engine("earth") %>% > # fit(survived + notsurvived~., data=etit) > # print(summary(mars_tworesp)) > # print(summary(mars_tworesp$fit)) > # > # stopifnot(identical(earth_tworesp$coeff, mars_tworesp$fit$coeff)) > # > # predict.earth_tworesp <- predict(earth_tworesp, etit[3:6,]) > # predict.mars_tworesp <- mars_tworesp %>% predict(etit[3:6,]) > # stopifnot(all(predict.earth_tworesp == predict.mars_tworesp)) > # > # plotmo(earth_tworesp, trace=0, nresponse=1, SHOWCALL=TRUE) > # plotmo(mars_tworesp, trace=0, nresponse=1, SHOWCALL=TRUE) > # plotmo(mars_tworesp, trace=0, nresponse=2, SHOWCALL=TRUE) > > source("test.epilog.R") plotmo/inst/slowtests/test.plotmo.x.Rout.save0000644000176200001440000007232614563614021021172 0ustar liggesusers> # test.plotmo.x.R: test plotmo_x and related functions > > source("test.prolog.R") > library(plotmo) Loading required package: Formula Loading required package: plotrix > library(earth) > options(warn=1) # print warnings as they occur > data(ozone1) > data(etitanic) > get.tit <- function() + { + tit <- etitanic + pclass <- as.character(tit$pclass) + # change the order of the factors so not alphabetical + pclass[pclass == "1st"] <- "first" + pclass[pclass == "2nd"] <- "class2" + pclass[pclass == "3rd"] <- "classthird" + tit$pclass <- factor(pclass, levels=c("class2", "classthird", "first")) + # log age is so we have a continuous predictor even when model is age~. + set.seed(2015) + tit$logage <- log(tit$age) + rnorm(nrow(tit)) + tit$parch <- NULL + # by=12 gives us a small fast model with an additive and a interaction term + tit <- tit[seq(1, nrow(etitanic), by=12), ] + } > X <- X1 <- X2 <- Y <- DF <- NULL > get.data <- function() + { + X <<- matrix(c(1,2,3,4,5,6,7,8,9, + 2,3,3,5,6,7,8,9,9), ncol=2) + colnames(X) <- c("xx1", "xx2") + X1 <<- X[,1] + X2 <<- X[,2] + Y <<- c(1,2,7,4,5,6,6,6,6) + DF <<- data.frame(Y=Y, X1=X1, X2=X2) + } > stopifnot1 <- function(x, y){ + xname <- deparse(substitute(x)) + yname <- deparse(substitute(y)) + if(!all(x == y)) + stop(sprint("%s == %s failed\n", xname, yname, call.=FALSE)) + printf("%s == %s passed\n", xname, yname) + } > printf("====== standard earth.formula model with a data frame\n") ====== standard earth.formula model with a data frame > > get.data() > earth.form.df.dot <- earth(Y~., data=DF) > plotmo(earth.form.df.dot, caption="test basic use of DF") plotmo grid: X1 X2 5 6 > printf("-- test basic use of DF\n") -- test basic use of DF > rv <- plotmo(earth.form.df.dot, trace=100) plotmo trace 100: plotmo(object=earth.form.df.dot, trace=100) --get.model.env for object with class earth object call is earth(formula=Y~., data=DF) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.form.df.dot' > stopifnot1(rv, X) rv == X passed > > printf("-- test use same DF even when other variables change\n") -- test use same DF even when other variables change > get.data() > earth.form.df.dot <- earth(Y~., data=DF) > X1 <- "rubbish" > rv <- plotmo(earth.form.df.dot, trace=100) plotmo trace 100: plotmo(object=earth.form.df.dot, trace=100) --get.model.env for object with class earth object call is earth(formula=Y~., data=DF) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.form.df.dot' > stopifnot1(rv, X) rv == X passed > > printf("-- test detect that DF is now trashed\n") -- test detect that DF is now trashed > get.data() > earth.form.df.dot <- earth(Y~., data=DF) > DF <- "rubbish" > X1 <- "rubbish" # DF is corrupt and will treated as NULL by plotmo, so make sure plotmo doesn't find the global X1 > # invalid 'envir' argument of type 'character' > expect.err(try(plotmo(earth.form.df.dot, trace=100)), "cannot get the original model predictors") plotmo trace 100: plotmo(object=earth.form.df.dot, trace=100) --get.model.env for object with class earth object call is earth(formula=Y~., data=DF) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.form.df.dot' Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: variable lengths differ (found for 'X1') (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(plotmo(earth.form.df.dot, trace = 100)) > > # Removed this test because this no longer fails, because we get the formula using formula(object) > # printf("-- DF is NULL so will get '.' in formula and no 'data' argument\n") > # get.data() > # earth.form.df.dot <- earth(Y~., data=DF) > # DF <- NULL > # # '.' in formula and no 'data' argument > # expect.err(try(plotmo(earth.form.df.dot, trace=100)), "cannot get the original model predictors") > > printf("-- DF is NULL so will pick up X1 with same values from global environment\n") -- DF is NULL so will pick up X1 with same values from global environment > get.data() > earth.form.df <- earth(Y~X1+X2, data=DF) > DF <- NULL > rv <- plotmo(earth.form.df, trace=100) plotmo trace 100: plotmo(object=earth.form.df, trace=100) --get.model.env for object with class earth object call is earth(formula=Y~X1+X2, data=DF) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.form.df' > stopifnot1(rv, X) rv == X passed > > printf("-- DF is NULL so will will pick up trashed X1 from global environment\n") -- DF is NULL so will will pick up trashed X1 from global environment > earth.form.df <- earth(Y~X1+X2, data=DF) > DF <- NULL > X1 <- "rubbish" > # variable lengths differ (found for 'X1') > expect.err(try(plotmo(earth.form.df, trace=100)), "cannot get the original model predictors") plotmo trace 100: plotmo(object=earth.form.df, trace=100) --get.model.env for object with class earth object call is earth(formula=Y~X1+X2, data=DF) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.form.df' Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: variable lengths differ (found for 'X1') (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(plotmo(earth.form.df, trace = 100)) > > printf("-- DF has only one column, so will pick up X1 from it and X2 from global environment\n") -- DF has only one column, so will pick up X1 from it and X2 from global environment > get.data() > earth.form.df <- earth(Y~X1+X2, data=DF) > DF <- data.frame(Y=Y, X1=X1) > DF[1,2] <- 99 > X2[1] <- 98 > rv <- plotmo(earth.form.df, trace=100) plotmo trace 100: plotmo(object=earth.form.df, trace=100) --get.model.env for object with class earth object call is earth(formula=Y~X1+X2, data=DF) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.form.df' > stopifnot1(rv[1,1], 99) rv[1, 1] == 99 passed > stopifnot1(rv[1,2], 98) rv[1, 2] == 98 passed > > printf("-- sanity check, make sure we are back to normal\n") -- sanity check, make sure we are back to normal > get.data() > earth.form.df <- earth(Y~X1+X2, data=DF) > rv <- plotmo(earth.form.df, trace=100) plotmo trace 100: plotmo(object=earth.form.df, trace=100) --get.model.env for object with class earth object call is earth(formula=Y~X1+X2, data=DF) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.form.df' > stopifnot1(rv, X) rv == X passed > > printf("-- change the data frame, make sure we pick up the changed value\n") -- change the data frame, make sure we pick up the changed value > get.data() > earth.form.df <- earth(Y~X1+X2, data=DF) > DF[1,2] <- 99 > rv <- plotmo(earth.form.df, trace=100) plotmo trace 100: plotmo(object=earth.form.df, trace=100) --get.model.env for object with class earth object call is earth(formula=Y~X1+X2, data=DF) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.form.df' > stopifnot1(rv[1,1], 99) rv[1, 1] == 99 passed > > printf("-- change order of columns in the data frame, should be ok\n") -- change order of columns in the data frame, should be ok > get.data() > earth.form.df <- earth(Y~X1+X2, data=DF) > DF <- data.frame(X2=X2, X1=X1) > rv <- plotmo(earth.form.df, trace=100) plotmo trace 100: plotmo(object=earth.form.df, trace=100) --get.model.env for object with class earth object call is earth(formula=Y~X1+X2, data=DF) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.form.df' > stopifnot1(rv, X) rv == X passed > > printf("======= standard earth.formula model with a data frame and keepxy\n") ======= standard earth.formula model with a data frame and keepxy > > get.data() > earth.form.df.keepxy <- earth(Y~., data=DF, keepxy=TRUE) > printf("-- test basic use of DF\n") -- test basic use of DF > rv <- plotmo(earth.form.df.keepxy, trace=100) plotmo trace 100: plotmo(object=earth.form.df.keepxy, trace=100) --get.model.env for object with class earth object call is earth(formula=Y~., data=DF, keepxy=TRUE) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.form.df.keepxy' > stopifnot1(rv, X) rv == X passed > > printf("-- test use same DF even when other variables change\n") -- test use same DF even when other variables change > earth.form.df.keepxy <- earth(Y~., data=DF, keepxy=TRUE) > X1 <- "rubbish" > rv <- plotmo(earth.form.df.keepxy, trace=100) plotmo trace 100: plotmo(object=earth.form.df.keepxy, trace=100) --get.model.env for object with class earth object call is earth(formula=Y~., data=DF, keepxy=TRUE) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.form.df.keepxy' > stopifnot1(rv, X) rv == X passed > > printf("-- DF is now trashed but it doesn't matter because keepxy=T\n") -- DF is now trashed but it doesn't matter because keepxy=T > DF <- "rubbish" > rv <- plotmo(earth.form.df.keepxy, trace=100) plotmo trace 100: plotmo(object=earth.form.df.keepxy, trace=100) --get.model.env for object with class earth object call is earth(formula=Y~., data=DF, keepxy=TRUE) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.form.df.keepxy' > stopifnot1(rv, X) rv == X passed > > printf("-- DF is NULL but it doesn't matter because keepxy=T\n") -- DF is NULL but it doesn't matter because keepxy=T > get.data() > earth.form.df.keepxy <- earth(Y~., data=DF, keepxy=TRUE) > DF <- NULL > rv <- plotmo(earth.form.df.keepxy, trace=100) plotmo trace 100: plotmo(object=earth.form.df.keepxy, trace=100) --get.model.env for object with class earth object call is earth(formula=Y~., data=DF, keepxy=TRUE) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.form.df.keepxy' > stopifnot1(rv, X) rv == X passed > > printf("-- DF and X1 are NULL but it doesn't matter because keepxy=T\n") -- DF and X1 are NULL but it doesn't matter because keepxy=T > DF <- NULL > X1 <- "rubbish" > rv <- plotmo(earth.form.df.keepxy, trace=100) plotmo trace 100: plotmo(object=earth.form.df.keepxy, trace=100) --get.model.env for object with class earth object call is earth(formula=Y~., data=DF, keepxy=TRUE) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.form.df.keepxy' > stopifnot1(rv, X) rv == X passed > > printf("-- sanity check, make sure we are back to normal\n") -- sanity check, make sure we are back to normal > get.data() > earth.form.df.keepxy <- earth(Y~., data=DF, keepxy=TRUE) > rv <- plotmo(earth.form.df.keepxy, trace=100) plotmo trace 100: plotmo(object=earth.form.df.keepxy, trace=100) --get.model.env for object with class earth object call is earth(formula=Y~., data=DF, keepxy=TRUE) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.form.df.keepxy' > stopifnot1(rv, X) rv == X passed > > printf("-- change the data frame, but it doesn't matter because keepxy=T\n") -- change the data frame, but it doesn't matter because keepxy=T > get.data() > earth.form.df.keepxy <- earth(Y~., data=DF, keepxy=TRUE) > DF[1,2] <- 99 > rv <- plotmo(earth.form.df.keepxy, trace=100) plotmo trace 100: plotmo(object=earth.form.df.keepxy, trace=100) --get.model.env for object with class earth object call is earth(formula=Y~., data=DF, keepxy=TRUE) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.form.df.keepxy' > stopifnot1(rv, X) rv == X passed > > printf("-- change order of columns in the data frame, should be ok\n") -- change order of columns in the data frame, should be ok > get.data() > earth.form.df.keepxy <- earth(Y~., data=DF, keepxy=TRUE) > DF <- data.frame(X2=X2, X1=X1) > rv <- plotmo(earth.form.df.keepxy, trace=100) plotmo trace 100: plotmo(object=earth.form.df.keepxy, trace=100) --get.model.env for object with class earth object call is earth(formula=Y~., data=DF, keepxy=TRUE) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.form.df.keepxy' > stopifnot1(rv, X) rv == X passed > > printf("======= standard lm model with a data frame but with model=FALSE\n") ======= standard lm model with a data frame but with model=FALSE > > get.data() > lm.form.df.model.false.with.dot <- lm(Y~., data=DF, model=FALSE) > printf("-- test basic use of DF\n") -- test basic use of DF > rv <- plotmo(lm.form.df.model.false.with.dot, trace=100) plotmo trace 100: plotmo(object=lm.form.df.model.false.with.dot, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~., data=DF, model=FALSE) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.model.false.with.dot' > stopifnot1(rv, X) rv == X passed > > printf("-- test use same DF even when other variables change\n") -- test use same DF even when other variables change > get.data() > lm.form.df.model.false.with.dot <- lm(Y~., data=DF, model=FALSE) > X1 <- "rubbish" > rv <- plotmo(lm.form.df.model.false.with.dot, trace=100) plotmo trace 100: plotmo(object=lm.form.df.model.false.with.dot, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~., data=DF, model=FALSE) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.model.false.with.dot' > stopifnot1(rv, X) rv == X passed > > printf("-- test detect that DF is now trashed\n") -- test detect that DF is now trashed > DF <- "rubbish" > # invalid 'envir' argument of type 'character' > expect.err(try(plotmo(lm.form.df.model.false.with.dot, trace=100)), "cannot get the original model predictors") plotmo trace 100: plotmo(object=lm.form.df.model.false.with.dot, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~., data=DF, model=FALSE) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.model.false.with.dot' Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: variable lengths differ (found for 'X1') (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(plotmo(lm.form.df.model.false.with.dot, trace = 100)) > > printf("-- DF is NULL so will pick up X1 with same values from global environment\n") -- DF is NULL so will pick up X1 with same values from global environment > get.data() > lm.form.df.model.false <- lm(Y~X1+X2, data=DF, model=FALSE) > DF <- NULL > rv <- plotmo(earth.form.df, trace=100) plotmo trace 100: plotmo(object=earth.form.df, trace=100) --get.model.env for object with class earth object call is earth(formula=Y~X1+X2, data=DF) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.form.df' > stopifnot1(rv, X) rv == X passed > > printf("-- DF is NULL so will will pick up trashed X1 from global environment\n") -- DF is NULL so will will pick up trashed X1 from global environment > get.data() > lm.form.df.model.false <- lm(Y~X1+X2, data=DF, model=FALSE) > DF <- NULL > X1 <- "rubbish" > # variable lengths differ (found for 'X1') > expect.err(try(plotmo(lm.form.df.model.false, trace=100)), "cannot get the original model predictors") plotmo trace 100: plotmo(object=lm.form.df.model.false, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~X1+X2, data=DF, model=FALSE) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.model.false' Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: variable lengths differ (found for 'X1') (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(plotmo(lm.form.df.model.false, trace = 100)) > > printf("-- sanity check, make sure we are back to normal\n") -- sanity check, make sure we are back to normal > get.data() > lm.form.df.model.false <- lm(Y~X1+X2, data=DF, model=FALSE) > rv <- plotmo(lm.form.df.model.false, trace=100) plotmo trace 100: plotmo(object=lm.form.df.model.false, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~X1+X2, data=DF, model=FALSE) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.model.false' > stopifnot1(rv, X) rv == X passed > > printf("-- change the data frame, make sure we pick up the changed value\n") -- change the data frame, make sure we pick up the changed value > get.data() > lm.form.df.model.false <- lm(Y~X1+X2, data=DF, model=FALSE) > DF[1,2] <- 99 > rv <- plotmo(lm.form.df.model.false, trace=100) plotmo trace 100: plotmo(object=lm.form.df.model.false, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~X1+X2, data=DF, model=FALSE) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.model.false' > stopifnot1(rv[1,1], 99) rv[1, 1] == 99 passed > > printf("-- change order of columns in the data frame, should be ok\n") -- change order of columns in the data frame, should be ok > get.data() > lm.form.df.model.false <- lm(Y~X1+X2, data=DF, model=FALSE) > DF <- data.frame(X2=X2, X1=X1) > rv <- plotmo(lm.form.df.model.false, trace=100) plotmo trace 100: plotmo(object=lm.form.df.model.false, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~X1+X2, data=DF, model=FALSE) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.model.false' > stopifnot1(rv, X) rv == X passed > > printf("======= standard lm with a data frame and model=TRUE (the default)\n") ======= standard lm with a data frame and model=TRUE (the default) > > get.data() > lm.form.df.with.dot <- lm(Y~., data=DF) > printf("-- test basic use of DF\n") -- test basic use of DF > rv <- plotmo(lm.form.df.with.dot, trace=100) plotmo trace 100: plotmo(object=lm.form.df.with.dot, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~., data=DF) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.with.dot' > stopifnot1(rv, X) rv == X passed > > printf("-- test use same DF even when other variables change\n") -- test use same DF even when other variables change > get.data() > lm.form.df.with.dot <- lm(Y~., data=DF) > X1 <- "rubbish" > rv <- plotmo(lm.form.df.with.dot, trace=100) plotmo trace 100: plotmo(object=lm.form.df.with.dot, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~., data=DF) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.with.dot' > stopifnot1(rv, X) rv == X passed > > printf("-- DF is now trashed but it doesn't matter because keepxy=T\n") -- DF is now trashed but it doesn't matter because keepxy=T > DF <- "rubbish" > rv <- plotmo(lm.form.df.with.dot, trace=100) plotmo trace 100: plotmo(object=lm.form.df.with.dot, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~., data=DF) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.with.dot' > stopifnot1(rv, X) rv == X passed > > printf("-- DF is NULL but it doesn't matter because keepxy=T\n") -- DF is NULL but it doesn't matter because keepxy=T > get.data() > lm.form.df.with.dot <- lm(Y~., data=DF) > DF <- NULL > rv <- plotmo(lm.form.df.with.dot, trace=100) plotmo trace 100: plotmo(object=lm.form.df.with.dot, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~., data=DF) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.with.dot' > stopifnot1(rv, X) rv == X passed > > printf("-- DF and X1 are NULL but it doesn't matter because keepxy=T\n") -- DF and X1 are NULL but it doesn't matter because keepxy=T > DF <- NULL > X1 <- "rubbish" > rv <- plotmo(lm.form.df.with.dot, trace=100) plotmo trace 100: plotmo(object=lm.form.df.with.dot, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~., data=DF) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.with.dot' > stopifnot1(rv, X) rv == X passed > > printf("-- sanity check, make sure we are back to normal\n") -- sanity check, make sure we are back to normal > get.data() > lm.form.df.with.dot <- lm(Y~., data=DF) > rv <- plotmo(lm.form.df.with.dot, trace=100) plotmo trace 100: plotmo(object=lm.form.df.with.dot, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~., data=DF) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.with.dot' > stopifnot1(rv, X) rv == X passed > > printf("-- change the data frame, but it doesn't matter because keepxy=T\n") -- change the data frame, but it doesn't matter because keepxy=T > get.data() > lm.form.df.with.dot <- lm(Y~., data=DF) > DF[1,2] <- 99 > rv <- plotmo(lm.form.df.with.dot, trace=100) plotmo trace 100: plotmo(object=lm.form.df.with.dot, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~., data=DF) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.with.dot' > stopifnot1(rv, X) rv == X passed > > printf("-- change order of columns in the data frame, should be ok\n") -- change order of columns in the data frame, should be ok > get.data() > lm.form.df.with.dot <- lm(Y~., data=DF) > DF <- data.frame(X2=X2, X1=X1) > rv <- plotmo(lm.form.df.with.dot, trace=100) plotmo trace 100: plotmo(object=lm.form.df.with.dot, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~., data=DF) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.with.dot' > stopifnot1(rv, X) rv == X passed > > printf("======= standard lm with a data frame and model=FALSE but x=TRUE\n") ======= standard lm with a data frame and model=FALSE but x=TRUE > > get.data() > lm.form.df.model.false.x.true <- lm(Y~., data=DF, model=FALSE, x=TRUE) > printf("-- test basic use of DF\n") -- test basic use of DF > rv <- plotmo(lm.form.df.model.false.x.true, trace=100) plotmo trace 100: plotmo(object=lm.form.df.model.false.x.true, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~., data=DF, model=FALSE, x=TRUE) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.model.false.x.true' > stopifnot1(rv, X) rv == X passed > > printf("-- test DF not available (shouldn't matter)\n") -- test DF not available (shouldn't matter) > DF <- "rubbish" > rv <- plotmo(lm.form.df.model.false.x.true, trace=100) plotmo trace 100: plotmo(object=lm.form.df.model.false.x.true, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~., data=DF, model=FALSE, x=TRUE) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.model.false.x.true' > stopifnot1(rv, X) rv == X passed > > printf("-- test $x trashed causes failure\n") -- test $x trashed causes failure > get.data() > lm.form.df.model.false.x.true <- lm(Y~., data=DF, model=FALSE, x=TRUE) > DF <- "rubbish" > X2 <- "rubbish1" > lm.form.df.model.false.x.true[["x"]] <- "nonesuch" > expect.err(try(plotmo(lm.form.df.model.false.x.true, trace=100)), "cannot get the original model predictors") plotmo trace 100: plotmo(object=lm.form.df.model.false.x.true, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~., data=DF, model=FALSE, x=TRUE) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.model.false.x.true' Warning: object$x may be corrupt Looked unsuccessfully for the original predictors in the following places: (1) object$x: nonesuch (2) model.frame: variable lengths differ (found for 'X2') (3) getCall(object)$x: less than three rows Error : cannot get the original model predictors Got expected error from try(plotmo(lm.form.df.model.false.x.true, trace = 100)) > > printf("-- test ok with $x trashed but DF ok\n") # although with trace!=100 will get downstream failures in predict.lm, that's ok -- test ok with $x trashed but DF ok > get.data() > lm.form.df.model.false.x.true[["x"]] <- "nonesuch" > # Warning: object$x may be corrupt > rv <- plotmo(lm.form.df.model.false.x.true, trace=100) plotmo trace 100: plotmo(object=lm.form.df.model.false.x.true, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~., data=DF, model=FALSE, x=TRUE) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.model.false.x.true' Warning: object$x may be corrupt > stopifnot1(rv, X) rv == X passed > > printf("-- test \"warning: object$x may be corrupt\", same as above but set options(warn=2)\n") -- test "warning: object$x may be corrupt", same as above but set options(warn=2) > options(warn=2) > get.data() > lm.form.df.model.false.x.true[["x"]] <- "nonesuch" > # Warning: object$x may be corrupt > expect.err(try(plotmo(lm.form.df.model.false.x.true, trace=100)), "x may be corrupt") plotmo trace 100: plotmo(object=lm.form.df.model.false.x.true, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~., data=DF, model=FALSE, x=TRUE) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.model.false.x.true' Error : (converted from warning) object$x may be corrupt Got expected error from try(plotmo(lm.form.df.model.false.x.true, trace = 100)) > options(warn=1) > stopifnot1(rv, X) rv == X passed > > printf("====== strings in the data.frame\n") ====== strings in the data.frame > > tit1 <- get.tit() > > tit1$char.pclass <- as.character(tit1$pclass) > > earth.survived.vs.pclass <- earth(survived~pclass, data=tit1, linpreds=TRUE) > x.earth.survived.vs.pclass <- plotmo(earth.survived.vs.pclass, trace=100, linpreds=TRUE) plotmo trace 100: plotmo(object=earth.survived.vs.pclass, trace=100, linpreds=TRUE) --get.model.env for object with class earth object call is earth(formula=survived~pclass, data=tit1, linpreds=TRUE) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.survived.vs.pclass' > stopifnot(is.factor(x.earth.survived.vs.pclass[[1]])) > > earth.survived.vs.char.pclass <- earth(survived~char.pclass, data=tit1) > x.earth.survived.vs.char.pclass <- plotmo(earth.survived.vs.char.pclass, trace=100) plotmo trace 100: plotmo(object=earth.survived.vs.char.pclass, trace=100) --get.model.env for object with class earth object call is earth(formula=survived~char.pclass, data=tit1) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.survived.vs.char.pclass' > stopifnot(is.factor(x.earth.survived.vs.char.pclass[[1]])) > > stopifnot(x.earth.survived.vs.pclass == x.earth.survived.vs.char.pclass) > > lm.survived.vs.pclass <- earth(survived~pclass, data=tit1, linpreds=TRUE) > x.lm.survived.vs.pclass <- plotmo(lm.survived.vs.pclass, trace=100, linpreds=TRUE) plotmo trace 100: plotmo(object=lm.survived.vs.pclass, trace=100, linpreds=TRUE) --get.model.env for object with class earth object call is earth(formula=survived~pclass, data=tit1, linpreds=TRUE) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'lm.survived.vs.pclass' > stopifnot(is.factor(x.lm.survived.vs.pclass[[1]])) > > lm.survived.vs.char.pclass <- earth(survived~char.pclass, data=tit1) > x.lm.survived.vs.char.pclass <- plotmo(lm.survived.vs.char.pclass, trace=100) plotmo trace 100: plotmo(object=lm.survived.vs.char.pclass, trace=100) --get.model.env for object with class earth object call is earth(formula=survived~char.pclass, data=tit1) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'lm.survived.vs.char.pclass' > stopifnot(is.factor(x.lm.survived.vs.char.pclass[[1]])) > > stopifnot(x.lm.survived.vs.pclass == x.lm.survived.vs.char.pclass) > > stopifnot(x.lm.survived.vs.pclass == x.earth.survived.vs.pclass) > > printf("-- test.plotmo.x done\n") -- test.plotmo.x done > > source("test.epilog.R") plotmo/inst/slowtests/test.glmnet.bat0000755000176200001440000000147214563571565017574 0ustar liggesusers@rem test.glmnet.bat: glmnet tests for plotmo and plotres @echo test.glmnet.bat @"C:\PROGRA~1\R\R-4.3.2\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.glmnet.R @if %errorlevel% equ 0 goto good1: @echo R returned errorlevel %errorlevel%, see test.glmnet.Rout: @echo. @tail test.glmnet.Rout @echo test.glmnet.R @exit /B 1 :good1 mks.diff test.glmnet.Rout test.glmnet.Rout.save @if %errorlevel% equ 0 goto good2: @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.glmnet.save.ps @exit /B 1 :good2 @rem test.glmnet.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.glmnet.save.ps @if %errorlevel% equ 0 goto good3: @echo === Files are different === @exit /B 1 :good3 @rm -f test.glmnet.Rout @rm -f Rplots.ps @exit /B 0 plotmo/inst/slowtests/test.plotres.bat0000755000176200001440000000145714563571565020001 0ustar liggesusers@rem test.plotres.bat: test plotres @echo test.plotres.bat @"C:\PROGRA~1\R\R-4.3.2\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.plotres.R @if %errorlevel% equ 0 goto good1: @echo R returned errorlevel %errorlevel%, see test.plotres.Rout: @echo. @tail test.plotres.Rout @echo test.plotres.R @exit /B 1 :good1 mks.diff test.plotres.Rout test.plotres.Rout.save @if %errorlevel% equ 0 goto good2: @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.plotres.save.ps @exit /B 1 :good2 @rem test.plotres.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.plotres.save.ps @if %errorlevel% equ 0 goto good3: @echo === Files are different === @exit /B 1 :good3 @rm -f test.plotres.Rout @rm -f Rplots.ps @exit /B 0 plotmo/inst/slowtests/test.printcall.R0000644000176200001440000000751113725307664017722 0ustar liggesusers# test.printcall.R # # TODO we don't test use of printcall in a namespace source("test.prolog.R") options(warnPartialMatchArgs=FALSE) library(plotmo) for(all in c(FALSE, TRUE)) { for(EVAL in c(FALSE, TRUE)) { printf("=== Test printcall with all=%s EVAL=%s ===\n", all, EVAL) foo30 <- function() { plotmo:::printcall(all=all) } foo30() foo32 <- function(...) { plotmo:::printcall(all=all); plotmo:::printdots(..., EVAL=EVAL) } foo32() foo32(a=31) foo34 <- function(aa=1, ...) { plotmo:::printcall(all=all); plotmo:::printdots(..., EVAL=EVAL) } foo34() foo34(a=31) # argname a will be expanded to aa foo34(a=31, x=1:10, y=NULL) foo34(a=31, y=NULL) foo34(x=stopifnot(TRUE), y=NULL) foo36 <- function(aa=NULL, ...) { plotmo:::printcall(all=all); plotmo:::printdots(..., EVAL=EVAL) } foo36() foo36(a=NULL) foo36(a=1) foo36(a=1:3) foo36(a=1:3, x=NULL) # check formatting of various argument types # note that we correctly don't call stopifnot(FALSE) (which would call stop) foo38 <- function(aa=1:3, bb=4:6, cc=print.default, dd=stopifnot(FALSE), ee=function(m=1) cat(m), ff=7, ...) { plotmo:::printcall(all=all); plotmo:::printdots(..., EVAL=EVAL) } foo38(x=matrix(ncol=1, nrow=3)) list1 <- list(aa=1:3, bb=4:6, cc=print.default, dd=stopifnot(TRUE), ee=function(m=1) cat(m), ff=7) cat("list1 ", plotmo:::list.as.char(list1), "\n", sep="") list2 <- list(lmmod=lm(Volume~Girth, data=trees), boolean=c(TRUE, FALSE, TRUE, TRUE, FALSE, TRUE), env=parent.frame(), chars=c("a", "b", "c", "a", "b", "c"), trees=trees, l=list(x=1, y="2", z=foo38)) cat("list2 ", plotmo:::list.as.char(list2), "\n", sep="") # test unnamed arguments foo40 <- function(aa, ...) { plotmo:::printcall(all=all); plotmo:::printdots(..., EVAL=EVAL) } foo40() foo40(aa=b, c) foo40(b, c) # test printcall when called in an S3 method foo.s3 <- function(a=NULL, ...) { UseMethod("foo.s3") } foo.s3.list <- function(a=NULL, ...) { cat("in foo.s3.list: "); plotmo:::printcall(all=all) plotmo:::printdots(..., EVAL=EVAL) } foo.s3.default <- function(a=NULL, ...) { cat("in foo.s3.default: "); plotmo:::printcall(all=all) plotmo:::printdots(..., EVAL=EVAL) } foo.s3(a=list(m=1, n=2)) foo.s3(a=NULL) foo.s3(a=list(m=1, n=2, o=3, p=4, q=5, r=6, s=7, t=8, u=9), b=30) # test formatting with long argument list foo46 <- function(mmmmmmmmmmm=1000, nnnnnnnnnnn=2000, ooooooooooo=3000, ppppppppppp=4000, qqqqqqqqqqq=5000, rrrrrrrrrrr=6000, sssssssssss=7000, ttttttttttt=8000, uuuuuuuuuuu=9000, vvvvvvvvvvv=1000, wwwwwwwwwww=2000, xxxxxxxxxxx=3000, ...) { plotmo:::printcall(all=all); plotmo:::printdots(..., EVAL=EVAL) } foo46(a=30) # test call.as.char foo47 <- function(aa=1, ...) { s <- plotmo:::call.as.char(all=all); cat(s, "\n", sep="") } foo47(b=30) # create a variable named foo48 in foo48 foo48 <- function(aa=1, ...) { foo48 <- 99; s <- plotmo:::call.as.char(all=all); cat(s, "\n", sep="") } foo48(b=30) # Note that the following doesn't do what you might expect. # The calling function is print(), not foo50() as you may expecty. foo50 <- function(...) { print(plotmo:::call.as.char(all=all)) } foo50(a=1) } } source("test.epilog.R") plotmo/inst/slowtests/test.plotmo3.Rout.save0000644000176200001440000012560114563614021021002 0ustar liggesusers> # test.plotmo3.R: extra tests for plotmo version 3 and higher > > source("test.prolog.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix > data(ozone1) > data(etitanic) > options(warn=1) # print warnings as they occur > > # check check.numeric.scalar > > xtest <- NA > expect.err(try(plotmo:::check.numeric.scalar(xtest)), "'xtest' is NA") Error : 'xtest' is NA Got expected error from try(plotmo:::check.numeric.scalar(xtest)) > xtest <- NULL > expect.err(try(plotmo:::check.numeric.scalar(xtest)), "'xtest' is NULL") Error : 'xtest' is NULL Got expected error from try(plotmo:::check.numeric.scalar(xtest)) > expect.err(try(plotmo:::check.numeric.scalar(NA)), "argument is NA") Error : argument is NA Got expected error from try(plotmo:::check.numeric.scalar(NA)) > expect.err(try(plotmo:::check.numeric.scalar(NULL)), "argument is NULL") Error : argument is NULL Got expected error from try(plotmo:::check.numeric.scalar(NULL)) > expect.err(try(plotmo:::check.numeric.scalar(try)), "'try' must be numeric (whereas its current class is \"function\")") Error : 'try' must be numeric (whereas its current class is "function") Got expected error from try(plotmo:::check.numeric.scalar(try)) > expect.err(try(plotmo:::check.numeric.scalar('try')), "\"try\" must be numeric (whereas its current class is \"character\")") Error : "try" must be numeric (whereas its current class is "character") Got expected error from try(plotmo:::check.numeric.scalar("try")) > expect.err(try(plotmo:::check.numeric.scalar(NULL)), "argument is NULL") Error : argument is NULL Got expected error from try(plotmo:::check.numeric.scalar(NULL)) > expect.err(try(plotmo:::check.numeric.scalar(1234, min=2, max=3)), "argument=1234 but it should be between 2 and 3") Error : argument=1234 but it should be between 2 and 3 Got expected error from try(plotmo:::check.numeric.scalar(1234, min = 2, max = 3)) > expect.err(try(plotmo:::check.numeric.scalar(0.1234, min=2, max=3)), "argument=0.1234 but it should be between 2 and 3") Error : argument=0.1234 but it should be between 2 and 3 Got expected error from try(plotmo:::check.numeric.scalar(0.1234, min = 2, max = 3)) > > expect.err(try(plotmo:::check.numeric.scalar(.1234, min=2, max=3)), "argument=0.1234 but it should be between 2 and 3") Error : argument=0.1234 but it should be between 2 and 3 Got expected error from try(plotmo:::check.numeric.scalar(0.1234, min = 2, max = 3)) > expect.err(try(plotmo:::check.numeric.scalar(+1234, min=2, max=3)), "argument=1234 but it should be between 2 and 3") Error : argument=1234 but it should be between 2 and 3 Got expected error from try(plotmo:::check.numeric.scalar(+1234, min = 2, max = 3)) > expect.err(try(plotmo:::check.numeric.scalar(-1234, min=2, max=3)), "argument=-1234 but it should be between 2 and 3") Error : argument=-1234 but it should be between 2 and 3 Got expected error from try(plotmo:::check.numeric.scalar(-1234, min = 2, max = 3)) > expect.err(try(plotmo:::check.numeric.scalar(+.1234, min=2, max=3)), "argument=0.1234 but it should be between 2 and 3") Error : argument=0.1234 but it should be between 2 and 3 Got expected error from try(plotmo:::check.numeric.scalar(+0.1234, min = 2, max = 3)) > expect.err(try(plotmo:::check.numeric.scalar(-.1234, min=2, max=3)), "argument=-0.1234 but it should be between 2 and 3") Error : argument=-0.1234 but it should be between 2 and 3 Got expected error from try(plotmo:::check.numeric.scalar(-0.1234, min = 2, max = 3)) > expect.err(try(plotmo:::check.numeric.scalar("", min=0, max=3)), "\"\" must be numeric (whereas its current class is \"character\"") Error : "" must be numeric (whereas its current class is "character") Got expected error from try(plotmo:::check.numeric.scalar("", min = 0, max = 3)) > > x.numeric.scalar <- 1234 > expect.err(try(plotmo:::check.numeric.scalar(x.numeric.scalar, min=0, max=3)), "x.numeric.scalar=1234 but it should be between 0 and 3") Error : x.numeric.scalar=1234 but it should be between 0 and 3 Got expected error from try(plotmo:::check.numeric.scalar(x.numeric.scalar, min = 0, max = 3)) > stopifnot(identical(plotmo:::check.numeric.scalar(x.numeric.scalar, min=2, max=1235), 1234)) > stopifnot(identical(plotmo:::check.numeric.scalar(1234, min=2, max=1235), 1234)) > > # check check.integer.scalar > > xtest <- NA > expect.err(try(plotmo:::check.integer.scalar(xtest)), "'xtest' is NA") Error : 'xtest' is NA Got expected error from try(plotmo:::check.integer.scalar(xtest)) > xtest <- NULL > expect.err(try(plotmo:::check.integer.scalar(xtest)), "'xtest' is NULL") Error : 'xtest' is NULL Got expected error from try(plotmo:::check.integer.scalar(xtest)) > expect.err(try(plotmo:::check.integer.scalar(NA)), "argument is NA") Error : argument is NA Got expected error from try(plotmo:::check.integer.scalar(NA)) > expect.err(try(plotmo:::check.integer.scalar(NA, null.ok=TRUE)), "argument is NA") Error : argument is NA Got expected error from try(plotmo:::check.integer.scalar(NA, null.ok = TRUE)) > expect.err(try(plotmo:::check.integer.scalar(NULL)), "argument is NULL") Error : argument is NULL Got expected error from try(plotmo:::check.integer.scalar(NULL)) > expect.err(try(plotmo:::check.integer.scalar(xtest, na.ok=TRUE)), "'xtest' is NULL") Error : 'xtest' is NULL Got expected error from try(plotmo:::check.integer.scalar(xtest, na.ok = TRUE)) > expect.err(try(plotmo:::check.integer.scalar("xyz", na.ok=TRUE)), "\"xyz\" is a string but it should be an integer, or NA, or TRUE or FALSE") Error : "xyz" is a string but it should be an integer, or NA, or TRUE or FALSE Got expected error from try(plotmo:::check.integer.scalar("xyz", na.ok = TRUE)) > expect.err(try(plotmo:::check.integer.scalar("TRUE", na.ok=TRUE)), "\"TRUE\" is a string but it should be an integer, or NA, or TRUE or FALSE") Error : "TRUE" is a string but it should be an integer, or NA, or TRUE or FALSE Got expected error from try(plotmo:::check.integer.scalar("TRUE", na.ok = TRUE)) > stopifnot(identical(plotmo:::check.integer.scalar(TRUE), TRUE)) > stopifnot(identical(plotmo:::check.integer.scalar(NA, na.ok=TRUE), NA)) > x.integer.scalar <- 1234L > expect.err(try(plotmo:::check.integer.scalar(x.integer.scalar, min=0, max=3)), "x.integer.scalar=1234 but it should be between 0 and 3") Error : x.integer.scalar=1234 but it should be between 0 and 3 Got expected error from try(plotmo:::check.integer.scalar(x.integer.scalar, min = 0, max = 3)) > stopifnot(identical(plotmo:::check.integer.scalar(x.integer.scalar, min=2, max=1235), 1234L)) > stopifnot(identical(plotmo:::check.integer.scalar(1234, min=2, max=1235), 1234)) > stopifnot(identical(plotmo:::check.integer.scalar(x.integer.scalar, min=2, max=1235), 1234L)) > stopifnot(identical(plotmo:::check.integer.scalar(1234, min=2, max=1235), 1234)) > xtest <- 1.234 > expect.err(try(plotmo:::check.integer.scalar(xtest, min=0, max=3)), "xtest=1.234 but it should be an integer, or TRUE or FALSE") Error : xtest=1.234 but it should be an integer, or TRUE or FALSE Got expected error from try(plotmo:::check.integer.scalar(xtest, min = 0, max = 3)) > > # check check.vec > xtest <- "x" > expect.err(try(plotmo:::check.vec(xtest, "xtest", na.ok=TRUE)), "'xtest' is not numeric") Error : 'xtest' is not numeric Got expected error from try(plotmo:::check.vec(xtest, "xtest", na.ok = TRUE)) > xtest <- as.double(NA) > print(plotmo:::check.vec(xtest, "xtest", na.ok=TRUE)) NULL > xtest <- as.double(1:3) > print(plotmo:::check.vec(xtest, "xtest", na.ok=TRUE)) NULL > xtest <- c(1,2,3,1/0,5,6,7) > expect.err(try(plotmo:::check.vec(xtest, "xtest", na.ok=TRUE)), "non-finite value in xtest") Error : non-finite value in xtest xtest[4] is Inf Got expected error from try(plotmo:::check.vec(xtest, "xtest", na.ok = TRUE)) > xtest <- c(1,2,3,NA,5,6,7) > expect.err(try(plotmo:::check.vec(xtest, "xtest")), "NA in xtest") Error : NA in xtest xtest[4] is NA Got expected error from try(plotmo:::check.vec(xtest, "xtest")) > xtest <- c(1,2,3) > expect.err(try(plotmo:::check.vec(xtest, "xtest", expected.len=2)), "'xtest' has the wrong length 3, expected 2") Error : 'xtest' has the wrong length 3, expected 2 Got expected error from try(plotmo:::check.vec(xtest, "xtest", expected.len = 2)) > print(plotmo:::check.vec(c(TRUE, FALSE), "c(TRUE, FALSE)")) NULL > > plotmo1 <- function(object, ..., trace=0, SHOWCALL=TRUE, caption=NULL) { + if(is.null(caption)) + caption <- paste(deparse(substitute(object)), collapse=" ") + call <- match.call(expand.dots=TRUE) + call <- strip.space(paste(deparse(substitute(call)), collapse=" ")) + printf("%s\n", call) + plotmo(object, trace=trace, SHOWCALL=SHOWCALL, caption=caption, ...) + } > plotres1 <- function(object, ..., trace=0, SHOWCALL=TRUE, caption=NULL) { + if(is.null(caption)) + caption <- paste(deparse(substitute(object)), collapse=" ") + call <- match.call(expand.dots=TRUE) + call <- strip.space(paste(deparse(substitute(call)), collapse=" ")) + printf("%s\n", call) + plotres(object, trace=trace, SHOWCALL=SHOWCALL, caption=caption, ...) + } > # basic tests of plotmo on abbreviated titanic data > > get.tita <- function() + { + tita <- etitanic + pclass <- as.character(tita$pclass) + # change the order of the factors so not alphabetical + pclass[pclass == "1st"] <- "first" + pclass[pclass == "2nd"] <- "class2" + pclass[pclass == "3rd"] <- "classthird" + tita$pclass <- factor(pclass, levels=c("class2", "classthird", "first")) + # log age is so we have a continuous predictor even when model is age~. + set.seed(2015) + tita$logage <- log(tita$age) + rnorm(nrow(tita)) + tita$parch <- NULL + # by=12 gives us a small fast model with an additive and a interaction term + tita[seq(1, nrow(etitanic), by=12), ] + } > tita <- get.tita() > > mod.lm.age <- lm(age~., data=tita) > plotmo1(mod.lm.age) plotmo1(object=mod.lm.age) plotmo grid: pclass survived sex sibsp logage classthird 0 male 0 3.06991 > plotmo1(mod.lm.age, level=.95) plotmo1(object=mod.lm.age,level=0.95) plotmo grid: pclass survived sex sibsp logage classthird 0 male 0 3.06991 > plotmo1(mod.lm.age, level=.95, col.resp=3) plotmo1(object=mod.lm.age,level=0.95,col.resp=3) plotmo grid: pclass survived sex sibsp logage classthird 0 male 0 3.06991 > > sexn <- as.numeric(tita$sex) > mod.lm.sexn <- lm(sexn~.-sex, data=tita) > plotmo1(mod.lm.sexn) plotmo1(object=mod.lm.sexn) plotmo grid: pclass survived sex age sibsp logage classthird 0 male 30 0 3.06991 > plotmo1(mod.lm.sexn, level=.95) plotmo1(object=mod.lm.sexn,level=0.95) plotmo grid: pclass survived sex age sibsp logage classthird 0 male 30 0 3.06991 > > set.seed(2020) > mod.earth.age <- earth(age~., data=tita, degree=2, nfold=3, ncross=3, varmod.method="lm") > plotmo1(mod.earth.age) plotmo1(object=mod.earth.age) plotmo grid: pclass survived sex sibsp logage classthird 0 male 0 3.06991 > plotmo1(mod.earth.age, level=.9, degree2=0) plotmo1(object=mod.earth.age,level=0.9,degree2=0) plotmo grid: pclass survived sex sibsp logage classthird 0 male 0 3.06991 > > # tita[,4] is age > set.seed(2020) > mod.earth.tita.age <- earth(tita[,-4], tita[,4], degree=2, nfold=3, ncross=3, trace=.5, varmod.method="lm") Model with pmethod="backward": GRSq 0.335 RSq 0.512 nterms 6 CV fold 1.1 CVRSq -0.047 n.oof 58 34% n.infold.nz 58 100% n.oof.nz 30 100% CV fold 1.2 CVRSq -0.022 n.oof 59 33% n.infold.nz 59 100% n.oof.nz 29 100% CV fold 1.3 CVRSq -0.045 n.oof 59 33% n.infold.nz 59 100% n.oof.nz 29 100% CV fold 2.1 CVRSq 0.133 n.oof 58 34% n.infold.nz 58 100% n.oof.nz 30 100% CV fold 2.2 CVRSq 0.338 n.oof 59 33% n.infold.nz 59 100% n.oof.nz 29 100% CV fold 2.3 CVRSq 0.149 n.oof 59 33% n.infold.nz 59 100% n.oof.nz 29 100% CV fold 3.1 CVRSq 0.419 n.oof 58 34% n.infold.nz 58 100% n.oof.nz 30 100% CV fold 3.2 CVRSq 0.107 n.oof 59 33% n.infold.nz 59 100% n.oof.nz 29 100% CV fold 3.3 CVRSq 0.307 n.oof 59 33% n.infold.nz 59 100% n.oof.nz 29 100% CV all CVRSq 0.149 n.infold.nz 88 100% varmod method="lm" rmethod="hc12" lambda=1 exponent=1 conv=1 clamp=0.1 minspan=-3: iter weight.ratio coefchange% (Intercept) tita[, 4] 1 1.4 0.0 13 -0.032 2 1.2 7.1 12 -0.018 3 1.3 3.0 13 -0.024 4 1.3 1.2 13 -0.022 5 1.3 0.5 13 -0.023 > cat("\nsummary(mod.earth.tita.age)\n") summary(mod.earth.tita.age) > print(summary(mod.earth.tita.age)) Call: earth(x=tita[,-4], y=tita[,4], trace=0.5, degree=2, nfold=3, ncross=3, varmod.method="lm") coefficients (Intercept) 25.664968 pclassfirst 9.028974 h(sibsp-1) -12.096706 h(1.68119-logage) -7.502937 sexmale * h(logage-2.48137) 5.062358 sibsp * h(logage-1.68119) 3.280947 Selected 6 of 14 terms, and 4 of 6 predictors Termination condition: Reached nk 21 Importance: logage, sexmale, pclassclassthird-unused, sibsp, pclassfirst, ... Number of terms at each degree of interaction: 1 3 2 GCV 174.7603 RSS 11022.31 GRSq 0.335155 RSq 0.5124778 CVRSq 0.1487371 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 3.89 sd 1.05 nvars 3.22 sd 0.97 CVRSq sd MaxErr sd 0.149 0.174 -39.1 32.3 varmod: method "lm" min.sd 1.49 iter.rsq 0.001 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) 15.7287403 2.77398 18 tita[, 4] -0.0283536 0.0837154 295 mean smallest largest ratio 95% prediction interval 58.24711 55.23254 62.56685 1.13279 68% 80% 90% 95% response values in prediction interval 84 90 97 99 > plotmo1(mod.earth.tita.age) plotmo1(object=mod.earth.tita.age) plotmo grid: pclass survived sex sibsp logage classthird 0 male 0 3.06991 > plotmo1(mod.earth.tita.age, level=.9, degree2=0) plotmo1(object=mod.earth.tita.age,level=0.9,degree2=0) plotmo grid: pclass survived sex sibsp logage classthird 0 male 0 3.06991 > > set.seed(2020) > a.earth.sex <- earth(sex~., data=tita, degree=2, nfold=3, ncross=3, varmod.method="lm") > plotmo1(a.earth.sex) plotmo1(object=a.earth.sex) plotmo grid: pclass survived age sibsp logage classthird 0 30 0 3.06991 > plotmo1(a.earth.sex, level=.9) plotmo1(object=a.earth.sex,level=0.9) plotmo grid: pclass survived age sibsp logage classthird 0 30 0 3.06991 > plotmo1(a.earth.sex, type="class") plotmo1(object=a.earth.sex,type="class") plotmo grid: pclass survived age sibsp logage classthird 0 30 0 3.06991 > expect.err(try(plotmo1(a.earth.sex, level=.9, degree2=0, type="class")), "predicted values are strings") plotmo1(object=a.earth.sex,level=0.9,degree2=0,type="class") Error : the level argument is not allowed when the predicted values are strings Got expected error from try(plotmo1(a.earth.sex, level = 0.9, degree2 = 0, type = "class")) > > # tita[,3] is sex > set.seed(2020) > mod.earth.tita <- earth(tita[,-3], tita[,3], degree=2, nfold=3, ncross=3, varmod.method="lm") > plotmo1(mod.earth.tita) plotmo1(object=mod.earth.tita) plotmo grid: pclass survived age sibsp logage classthird 0 30 0 3.06991 > plotmo1(mod.earth.tita, level=.9, degree2=0) plotmo1(object=mod.earth.tita,level=0.9,degree2=0) plotmo grid: pclass survived age sibsp logage classthird 0 30 0 3.06991 > plotmo1(mod.earth.tita, type="class") plotmo1(object=mod.earth.tita,type="class") plotmo grid: pclass survived age sibsp logage classthird 0 30 0 3.06991 > expect.err(try(plotmo1(mod.earth.tita, level=.9, degree2=0, type="class")), "predicted values are strings") plotmo1(object=mod.earth.tita,level=0.9,degree2=0,type="class") Error : the level argument is not allowed when the predicted values are strings Got expected error from try(plotmo1(mod.earth.tita, level = 0.9, degree2 = 0, type = "class")) > > set.seed(2020) > mod.earth.sex <- earth(sex~., data=tita, degree=2, nfold=3, ncross=3, varmod.method="earth", glm=list(family=binomial)) Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred > plotmo1(mod.earth.sex) plotmo1(object=mod.earth.sex) plotmo grid: pclass survived age sibsp logage classthird 0 30 0 3.06991 > plotmo1(mod.earth.sex, type="link") plotmo1(object=mod.earth.sex,type="link") plotmo grid: pclass survived age sibsp logage classthird 0 30 0 3.06991 > plotmo1(mod.earth.sex, type="class") plotmo1(object=mod.earth.sex,type="class") plotmo grid: pclass survived age sibsp logage classthird 0 30 0 3.06991 > plotmo1(mod.earth.sex, level=.9, type="earth") plotmo1(object=mod.earth.sex,level=0.9,type="earth") plotmo grid: pclass survived age sibsp logage classthird 0 30 0 3.06991 > > # tita[,3] is sex > set.seed(2020) > mod.earth.tita <- earth(tita[,-3], tita[,3], degree=2, nfold=3, ncross=3, varmod.method="earth", glm=list(family=binomial)) Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred > plotmo1(mod.earth.tita) plotmo1(object=mod.earth.tita) plotmo grid: pclass survived age sibsp logage classthird 0 30 0 3.06991 > plotmo1(mod.earth.tita, type="link") plotmo1(object=mod.earth.tita,type="link") plotmo grid: pclass survived age sibsp logage classthird 0 30 0 3.06991 > plotmo1(mod.earth.tita, type="class") plotmo1(object=mod.earth.tita,type="class") plotmo grid: pclass survived age sibsp logage classthird 0 30 0 3.06991 > plotmo1(mod.earth.tita, level=.9, type="earth") plotmo1(object=mod.earth.tita,level=0.9,type="earth") plotmo grid: pclass survived age sibsp logage classthird 0 30 0 3.06991 > > # check factor handling when factors are not ordered alphabetically > tita.orgpclass <- etitanic[seq(1, nrow(etitanic), by=12), ] > tita <- get.tita() > tita$logage <- NULL > tita.orgpclass$parch <- NULL > stopifnot(names(tita.orgpclass) == names(tita)) > a.tita.orgpclass <- earth(pclass~., degree=2, data=tita.orgpclass) > a.tita <- earth(pclass~., degree=2, data=tita) > options(warn=2) # treat warnings as errors > expect.err(try(plotmo(a.tita)), "Defaulting to nresponse=1, see above messages") predict.earth[88,3]: class2 classthird first 1 0.3179514 0.3141272 0.36792134 2 0.3179514 0.3141272 0.36792134 3 0.2400614 0.6754849 0.08445368 ... 0.2180022 0.5645160 0.21748179 88 0.2400614 0.6754849 0.08445368 predict.earth returned multiple columns (see above) but nresponse is not specified Use the nresponse argument to specify a column. Example: nresponse=2 Example: nresponse="classthird" Error : (converted from warning) Defaulting to nresponse=1, see above messages Got expected error from try(plotmo(a.tita)) > options(warn=1) > # following two graphs should be identical > plotmo1(a.tita.orgpclass, nresponse="1st", all1=T, col.resp=3, type2="im") plotmo1(object=a.tita.orgpclass,nresponse="1st",all1=T,col.resp=3,type2="im") plotmo grid: survived sex age sibsp 0 male 30 0 > plotmo1(a.tita, nresponse="first", all1=T, col.resp=3, type2="im") plotmo1(object=a.tita,nresponse="first",all1=T,col.resp=3,type2="im") plotmo grid: survived sex age sibsp 0 male 30 0 > # following two graphs should be identical > plotmo1(a.tita.orgpclass, nresponse="2nd", all1=T) plotmo1(object=a.tita.orgpclass,nresponse="2nd",all1=T) plotmo grid: survived sex age sibsp 0 male 30 0 > plotmo1(a.tita, nresponse="class2", all1=T) plotmo1(object=a.tita,nresponse="class2",all1=T) plotmo grid: survived sex age sibsp 0 male 30 0 > > tita <- get.tita() > mod.earth.pclass <- earth(pclass~., data=tita, degree=2) > options(warn=2) # treat warnings as errors > expect.err(try(plotmo1(mod.earth.pclass)), "Defaulting to nresponse=1, see above messages") plotmo1(object=mod.earth.pclass) predict.earth[88,3]: class2 classthird first 1 0.3197580 0.2991394 0.3811026 2 0.3197580 0.2991394 0.3811026 3 0.2490258 0.6472095 0.1037648 ... 0.1984114 0.5220475 0.2795411 88 0.2490258 0.6472095 0.1037648 predict.earth returned multiple columns (see above) but nresponse is not specified Use the nresponse argument to specify a column. Example: nresponse=2 Example: nresponse="classthird" Error : (converted from warning) Defaulting to nresponse=1, see above messages Got expected error from try(plotmo1(mod.earth.pclass)) > options(warn=1) > plotmo1(mod.earth.pclass, nresponse="fi") plotmo1(object=mod.earth.pclass,nresponse="fi") plotmo grid: survived sex age sibsp logage 0 male 30 0 3.06991 > plotmo1(mod.earth.pclass, nresponse="first") plotmo1(object=mod.earth.pclass,nresponse="first") plotmo grid: survived sex age sibsp logage 0 male 30 0 3.06991 > plotmo1(mod.earth.pclass, nresponse=3) plotmo1(object=mod.earth.pclass,nresponse=3) plotmo grid: survived sex age sibsp logage 0 male 30 0 3.06991 > plotmo1(mod.earth.pclass, type="class") plotmo1(object=mod.earth.pclass,type="class") plotmo grid: survived sex age sibsp logage 0 male 30 0 3.06991 > plotmo1(mod.earth.pclass, nresponse=1, + type="class", grid.levels=list(sex="fem"), + smooth.col="indianred", smooth.lwd=2, + pt.col=as.numeric(tita$pclass)+1, + pt.pch=1) plotmo1(object=mod.earth.pclass,nresponse=1,type="class",grid.levels=list(sex="fem"),smooth.col="indianred",smooth.lwd=2,pt.col=as.numeric(tita$pclass)+1,pt.pch=1) plotmo grid: survived sex age sibsp logage 0 female 30 0 3.06991 > > # tita[,1] is pclass > mod.earth.tita <- earth(tita[,-1], tita[,1], degree=2) > options(warn=2) # treat warnings as errors > expect.err(try(plotmo1(mod.earth.tita)), "Defaulting to nresponse=1, see above messages") plotmo1(object=mod.earth.tita) predict.earth[88,3]: class2 classthird first 1 0.3197580 0.2991394 0.3811026 2 0.3197580 0.2991394 0.3811026 3 0.2490258 0.6472095 0.1037648 ... 0.1984114 0.5220475 0.2795411 88 0.2490258 0.6472095 0.1037648 predict.earth returned multiple columns (see above) but nresponse is not specified Use the nresponse argument to specify a column. Example: nresponse=2 Example: nresponse="classthird" Error : (converted from warning) Defaulting to nresponse=1, see above messages Got expected error from try(plotmo1(mod.earth.tita)) > options(warn=1) > plotmo1(mod.earth.tita, nresponse="first") plotmo1(object=mod.earth.tita,nresponse="first") plotmo grid: survived sex age sibsp logage 0 male 30 0 3.06991 > plotmo1(mod.earth.tita, type="class") plotmo1(object=mod.earth.tita,type="class") plotmo grid: survived sex age sibsp logage 0 male 30 0 3.06991 > > mod.earth.pclass2 <- earth(pclass~., data=tita, degree=2, glm=list(family=binomial)) > # expect.err(try(plotmo1(mod.earth.pclass2)), "nresponse is not specified") > plotmo1(mod.earth.pclass2, nresponse=3) plotmo1(object=mod.earth.pclass2,nresponse=3) plotmo grid: survived sex age sibsp logage 0 male 30 0 3.06991 > plotmo1(mod.earth.pclass2, type="link", nresponse=3) plotmo1(object=mod.earth.pclass2,type="link",nresponse=3) plotmo grid: survived sex age sibsp logage 0 male 30 0 3.06991 > plotmo1(mod.earth.pclass2, type="class") plotmo1(object=mod.earth.pclass2,type="class") plotmo grid: survived sex age sibsp logage 0 male 30 0 3.06991 > > # tita[,1] is pclass > mod.earth.tita <- earth(tita[,-1], tita[,1], degree=2, glm=list(family=binomial)) > plotmo1(mod.earth.tita, nresponse=3) plotmo1(object=mod.earth.tita,nresponse=3) plotmo grid: survived sex age sibsp logage 0 male 30 0 3.06991 > plotmo1(mod.earth.tita, type="link", nresponse=3) plotmo1(object=mod.earth.tita,type="link",nresponse=3) plotmo grid: survived sex age sibsp logage 0 male 30 0 3.06991 > plotmo1(mod.earth.tita, type="class") plotmo1(object=mod.earth.tita,type="class") plotmo grid: survived sex age sibsp logage 0 male 30 0 3.06991 > > # plotmo vignette examples > > # use a small set of variables for illustration > printf("library(earth)\n") library(earth) > library(earth) # for ozone1 data > data(ozone1) > oz <- ozone1[, c("O3", "humidity", "temp", "ibt")] > > lm.model.vignette <- lm(O3 ~ humidity + temp*ibt, data=oz) # linear model > plotmo1(lm.model.vignette, pt.col="gray", nrug=-1) plotmo1(object=lm.model.vignette,pt.col="gray",nrug=-1) plotmo grid: humidity temp ibt 64 62 167.5 > plotmo1(lm.model.vignette, level=.9) plotmo1(object=lm.model.vignette,level=0.9) plotmo grid: humidity temp ibt 64 62 167.5 > > printf("library(mda)\n") library(mda) > library(mda) Loading required package: class Loaded mda 0.5-4 > mars.model.vignette1 <- mars(oz[,-1], oz[,1], degree=2) > plotmo1(mars.model.vignette1) plotmo1(object=mars.model.vignette1) plotmo grid: humidity temp ibt 64 62 167.5 > plotres1(mars.model.vignette1) plotres1(object=mars.model.vignette1) > mars.model.vignette2 <- mars(oz[,-1,drop=FALSE], oz[,1,drop=FALSE], degree=2) > plotmo1(mars.model.vignette2) plotmo1(object=mars.model.vignette2) plotmo grid: humidity temp ibt 64 62 167.5 > # TODO causes Error in lm.fit(object$x, y, singular.ok = FALSE) : (list) object cannot be coerced to type 'double' > # although still works > # the error is mars.to.earth try(hatvalues.lm.fit(lm.fit(object$x, y, singular.ok=FALSE))) > plotres1(mars.model.vignette2, trace=1) plotres1(object=mars.model.vignette2,trace=1) stats::residuals(object=mars.object, type="response") stats::fitted(object=mars.object) got model response from getCall(object)$y calling mars.to.earth (needed for the model selection plot) training rsq 0.76 > > printf("library(rpart)\n") library(rpart) > library(rpart) # rpart > rpart.model.vignette <- rpart(O3 ~ ., data=oz) > plotmo1(rpart.model.vignette, all2=TRUE) plotmo1(object=rpart.model.vignette,all2=TRUE) plotmo grid: humidity temp ibt 64 62 167.5 > expect.err(try(plotmo1(rpart.model.vignette, level=.9)), "the level argument is not supported for \"rpart\" objects") plotmo1(object=rpart.model.vignette,level=0.9) Error : the level argument is not supported for "rpart" objects Got expected error from try(plotmo1(rpart.model.vignette, level = 0.9)) > > # commented out because is slow and already tested in test.non.earth.R > # printf("library(randomForest)\n") > # library(randomForest) # randomForest > # rf.model.vignette <- randomForest(O3~., data=oz) > # plotmo1(rf.model.vignette) > # partialPlot(rf.model.vignette, oz, temp) # compare to partial-dependence plot > > printf("library(gbm)\n") library(gbm) > library(gbm) # gbm Loaded gbm 2.1.9 This version of gbm is no longer under development. Consider transitioning to gbm3, https://github.com/gbm-developers/gbm3 > set.seed(2016) > gbm.model.vignette <- gbm(O3~., data=oz, dist="gaussian", inter=2, n.trees=100) > # commented out following because they always take the whole page > # plot(gbm.model.vignette, i.var=2) # compare to partial-dependence plots > # plot(gbm.model.vignette, i.var=c(2,3)) > set.seed(2016) > plotmo1(gbm.model.vignette, caption="gbm.model.vignette") plotmo1(object=gbm.model.vignette,caption="gbm.model.vignette") plotmo grid: humidity temp ibt 64 62 167.5 > > # commented out because is slow and already tested elsewhere > # printf("library(mgcv)\n") > # library(mgcv) # gam > # gam.model.vignette <- gam(O3 ~ s(humidity)+s(temp)+s(ibt)+s(temp,ibt), data=oz) > # plotmo1(gam.model.vignette, level=.95, all2=TRUE) > > printf("library(nnet)\n") library(nnet) > library(nnet) # nnet > set.seed(4) > nnet.model.vignette <- nnet(O3~., data=scale(oz), size=2, decay=0.01, trace=FALSE) > plotmo1(nnet.model.vignette, type="raw", all2=T) plotmo1(object=nnet.model.vignette,type="raw",all2=T) plotmo grid: humidity temp ibt 0.2954793 0.01697621 0.08267399 > > printf("library(MASS)\n") library(MASS) > library(MASS) # qda > lcush <- data.frame(Type=as.numeric(Cushings$Type),log(Cushings[,1:2])) > lcush <- lcush[1:21,] > qda.model.vignette <- qda(Type~., data=lcush) > plotmo1(qda.model.vignette, type="class", all2=TRUE, + type2="contour", ngrid2=100, contour.nlevels=2, contour.drawlabels=FALSE, + pt.col=as.numeric(lcush$Type)+1, + pt.pch=as.character(lcush$Type)) plotmo1(object=qda.model.vignette,type="class",all2=TRUE,type2="contour",ngrid2=100,contour.nlevels=2,contour.drawlabels=FALSE,pt.col=as.numeric(lcush$Type)+1,pt.pch=as.character(lcush$Type)) plotmo grid: Tetrahydrocortisone Pregnanetriol 2.04122 0.1823216 > > # miscellaneous other examples > > tita <- get.tita() > > mod.glm.sex <- glm(sex~., data=tita, family=binomial) > plotmo1(mod.glm.sex, pt.col=as.numeric(tita$pclass)+1) plotmo1(object=mod.glm.sex,pt.col=as.numeric(tita$pclass)+1) plotmo grid: pclass survived age sibsp logage classthird 0 30 0 3.06991 > > # tita[,4] is age, tita[,1] is pclass > printf("library(lars)\n") library(lars) > library(lars) Loaded lars 1.3 > set.seed(2015) > xmat <- as.matrix(tita[,c(2,5,6)]) > mod.lars.xmat <- lars(xmat, tita[,4]) > par(mfrow=c(2,2)) > plot(mod.lars.xmat) > plotmo1(mod.lars.xmat, nresponse=4, do.par=F) plotmo1(object=mod.lars.xmat,nresponse=4,do.par=F) plotmo grid: survived sibsp logage 0 0 3.06991 > plotres(mod.lars.xmat, trace=0, nresponse=4) > > if(0) { # TODO fails with R-3.4.2: object '.QP_qpgen2' not found + printf("library(cosso)\n") + library(cosso) + set.seed(2016) + cosso <- cosso(xmat,tita[,4],family="Gaussian") + # TODO tell maintainer of cosso that you have to do this + class(cosso) <- "cosso" + set.seed(2016) + plotmo1(cosso) + set.seed(2016) + plotres(cosso) + } > # examples from James, Witten, et al. ISLR book > # I tested all models in their scripts manually. > # All worked except for exceptions below. > > printf("library(pls)\n") library(pls) > library(pls) Attaching package: 'pls' The following object is masked from 'package:stats': loadings > printf("library(ISLR)\n") library(ISLR) > library(ISLR) > Hitters=na.omit(Hitters) > > set.seed(1) > x <- model.matrix(Salary~.,Hitters)[,-1] > y <- Hitters$Salary > train=sample(1:nrow(x), nrow(x)/2) > pcr.fit1=pcr(Salary~., data=Hitters,subset=train,scale=TRUE, validation="CV") > plotmo1(pcr.fit1, nresponse=10) plotmo1(object=pcr.fit1,nresponse=10) plotmo grid: AtBat Hits HmRun Runs RBI Walks Years CAtBat CHits CHmRun 394 102 8 50 44 36 6 1931 510 36 CRuns CRBI CWalks League Division PutOuts Assists Errors NewLeague 246 219 172 A W 211 56 7 A > > # set.seed(1) > # x <- model.matrix(Salary~.,Hitters)[,-1] > # y <- Hitters$Salary > # train=sample(1:nrow(x), nrow(x)/2) > # pcr.fit2=pcr(y~x,scale=TRUE,ncomp=7) > # # TODO following gives Error: predictions returned the wrong length (got 263 but expected 50) > # plotmo1(pcr.fit2, nresponse=5) > > library(splines) > fit.lm2=lm(wage~bs(age,knots=c(25,40,60)),data=Wage) > par(mfrow=c(1,2),mar=c(4.5,4.5,1,1),oma=c(0,0,4,0)) > agelims=range(Wage$age) > age.grid=seq(from=agelims[1],to=agelims[2]) > pred=predict(fit.lm2,newdata=list(age=age.grid),se=T) > plot(Wage$age,Wage$wage,col="gray", ylim=c(0,320)) > lines(age.grid,pred$fit,lwd=2) > lines(age.grid,pred$fit+2*pred$se,lty="dashed") > lines(age.grid,pred$fit-2*pred$se,lty="dashed") > fit.lm2=lm(wage~bs(age,knots=c(25,40,60)),data=Wage,model=F) # TODO delete > plotmo1(fit.lm2, col.resp=2, do.par=F, level=.95, ylim=c(0,320), + nrug=TRUE, caption="fit.lm2", ylab="wage") plotmo1(object=fit.lm2,col.resp=2,do.par=F,level=0.95,ylim=c(0,320),nrug=TRUE,ylab="wage",caption="fit.lm2") > > fit.glm2 <- glm(I(wage>250)~poly(age,4),data=Wage,family=binomial) > par(mfrow=c(1,2),mar=c(4.5,4.5,1,1),oma=c(0,0,4,0)) > agelims=range(Wage$age) > age.grid=seq(from=agelims[1],to=agelims[2]) > # their plot > preds=predict(fit.glm2,newdata=list(age=age.grid),se=T) > pfit=exp(preds$fit)/(1+exp(preds$fit)) > se.bands.logit = cbind(preds$fit+2*preds$se.fit, preds$fit-2*preds$se.fit) > se.bands = exp(se.bands.logit)/(1+exp(se.bands.logit)) > preds=predict(fit.glm2,newdata=list(age=age.grid),type="response",se=T) > plot(Wage$age,I(Wage$wage>250),xlim=agelims,type="n",ylim=c(0,.2)) > points(jitter(Wage$age), I((Wage$wage>250)/5),cex=.5,pch="|",col="darkgrey") > lines(age.grid,pfit,lwd=2, col="blue") > matlines(age.grid,se.bands,lwd=1,col="blue",lty=3) > # plotmo plot, side by side > # TODO Warning: the level argument may not be properly supported on glm objects built with weights > plotmo1(fit.glm2, level=.95, degree1.col="blue", ylim=c(0,.2), do.par=FALSE, nrug=-1, caption="fit.glm2", ylab="I(wage > 250)") plotmo1(object=fit.glm2,level=0.95,degree1.col="blue",ylim=c(0,0.2),do.par=FALSE,nrug=-1,ylab="I(wage>250)",caption="fit.glm2") Warning: the level argument may not work correctly on glm objects built with weights > > # Test deparsing of the formula in plotmo.pairs.default > # TODO Height is included in the plots even though formula says -Height > Height2 <- trees$Height^2 > a <- lm(Volume~(Girth*Height2)-Height, data=trees, x=TRUE, model=FALSE) > plotmo(a) plotmo grid: Girth Height2 Height 12.9 5776 76 > > # test "the variable on the right side of the formula is a matrix or data.frame" > # TODO would like to solve this problem > > options(warn=2) > data(gasoline, package="pls") > earth.octane <- earth(octane ~ NIR, data=gasoline) > print(summary(earth.octane)) # ok Call: earth(formula=octane~NIR, data=gasoline) coefficients (Intercept) 87.818970 h(NIR1016 nm- -0.050322) -307.631441 h(NIR1036 nm- -0.060936) 83.025904 h(NIR1054 nm- -0.059068) 254.542458 h(NIR1134 nm-0.028475) 34.069219 h(0.484052-NIR1194 nm) -45.522897 h(NIR1194 nm-0.484052) 50.623858 h(0.25499-NIR1208 nm) 81.506833 h(NIR1208 nm-0.25499) -92.719551 h(NIR1686 nm-1.25012) -7.936903 h(1.27324-NIR1690 nm) 3.531658 Selected 11 of 12 terms, and 8 of 401 predictors Termination condition: RSq changed by less than 0.001 at 12 terms Importance: NIR1208 nm, NIR1194 nm, NIR1134 nm, NIR1690 nm, NIR1016 nm, ... Number of terms at each degree of interaction: 1 10 (additive model) GCV 0.05120795 RSS 1.298122 GRSq 0.9784914 RSq 0.990602 > plotres(earth.octane) # ok > expect.err(try(plotmo(earth.octane)), "the variable on the right side of the formula is a matrix or data.frame") Error : (converted from warning) the variable on the right side of the formula is a matrix or data.frame plotmo often cannot process such variables Got expected error from try(plotmo(earth.octane)) > options(warn=1) > > # TODO May 2020 'ElemStatLearn' is not available (for R version 4.0.0) > # library(ElemStatLearn) > # x <- mixture.example$x > # g <- mixture.example$y > # lm.mixture.example <- lm(g ~ x) > # options(warn=2) > # expect.err(try(plotmo(lm.mixture.example)), "the variable on the right side of the formula is a matrix or data.frame") > # options(warn=1) > > # test variable names with $ are not supported > > a <- earth(O3~ozone1$doy, data=ozone1) > expect.err(try(plotmo(a)), "cannot get the original model predictors") Warning: "$" in the formula is not supported by plotmo, will try to get the data elsewhere formula: ozone1$doy Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: formula(object): "$" in formula is not allowed (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(plotmo(a)) > > a <- earth(O3~ozone1$doy + temp, data=ozone1) > expect.err(try(plotmo(a)), "cannot get the original model predictors") Warning: "$" in the formula is not supported by plotmo, will try to get the data elsewhere formula: ozone1$doy + temp Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: formula(object): "$" in formula is not allowed (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(plotmo(a)) > > a <- lm(O3~ozone1$doy, data=ozone1) > expect.err(try(plotmo(a)), "cannot get the original model predictors") Warning: "$" in the formula is not supported by plotmo, will try to get the data elsewhere formula: ozone1$doy Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: formula(object): "$" in formula is not allowed (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(plotmo(a)) > > a <- lm(O3~ozone1$doy + temp, data=ozone1) > expect.err(try(plotmo(a)), "cannot get the original model predictors") Warning: "$" in the formula is not supported by plotmo, will try to get the data elsewhere formula: ozone1$doy + temp Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: formula(object): "$" in formula is not allowed (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(plotmo(a)) > > #--- test interaction of w1. and non w1 args ------------------------------------- > > par(mfrow=c(4,3), mar=c(3, 3, 4, 1), mgp=c(2, 0.6, 0)) > > mod78 <- earth(Volume ~ ., data = trees) > par(mfrow=c(3,4), mar=c(3, 3, 3, 1), mgp=c(2, 0.6, 0)) > > # multiple which, earth model > plotres(mod78, cex.main=1, + ylim=c(-.5, .8), xlim=c(-2, 7), col=2:3, do.par=FALSE, + w1.main=c("ylim=c(-.5, .8)\nxlim=c(-2, 7) col=2:3")) > > # multiple which, earth model > plotres(mod78, cex.main=.7, + w1.ylim=c(-.5, .8), w1.xlim=c(-2, 7), col=2:3, do.par=FALSE, + ylim=c(-10,10), xlim=c(-30, 100), + w1.main=c("w1.ylim=c(-.5, .8) w1.xlim=c(-2, 7)\nylim=c(-10,10), xlim=c(-30, 100)")) > par(org.par) > > par(mfrow=c(3,4), mar=c(3, 3, 3, 1), mgp=c(2, 0.6, 0)) > > # which=1, earth model > > plotres(mod78, which=1, cex.main=.8, + col=2:3, + main="which=1, no other ylim args", + w1.main="which=1, no other ylim args") > > plotres(mod78, which=1, cex.main=.8, + col=2:3, w1.ylim=c(.3,.98), w1.xlim=c(-2, 7), + main="w1.ylim=c(.3,.98)\nw1.xlim=c(-2, 7)") > > plotres(mod78, which=1, cex.main=.8, + col=2:3, ylim=c(.3,.98), xlim=c(-2, 7), + main="ylim=c(.3,.98)\nxlim=c(-2, 7)") # ylim gets passed to modsel > > plotres(mod78, which=1, cex.main=.75, + col=2:3, w1.ylim=c(.3,.98), ylim=c(-.5,.5), + w1.xlim=c(-2, 7), xlim=c(-90, 90), + main="w1.ylim=c(.3,.98), ylim=c(-.5,.5)\nw1.xlim=c(-2, 7), xlim=c(-90, 90)") # ignore ylim > > # which=3, earth model > plotres(mod78, which=3, cex.main=1, + col=2:3, + main="which=3, no other ylim args") > > plotres(mod78, which=3, cex.main=1, + col=2:3, w1.ylim=c(.3,.98), w1.xlim=c(-2, 7), + main="w1.ylim=c(.3,.98)\nw1.xlim=c(-2, 7)") # not usual, ignore w1.ylim > > plotres(mod78, which=3, cex.main=1, + col=2:3, ylim=c(-10,10), xlim=c(-90,90), + main="which=3, ylim=c(-10,10)\nxlim=c(-90,90)") > > plotres(mod78, which=3, cex.main=1, + col=2:3, w1.ylim=c(.3,.98), ylim=c(-10,10), w1.xlim=c(-2, 7), xlim=c(-90,90), + main="w1.ylim=c(.3,.98) ylim=c(-10,10)\nw1.xlim=c(-2, 7), xlim=c(-90,90)") > > par(org.par) > > nullarg <- NULL > expect.err(try(plotmo(nullarg)), "argument 'nullarg' is NULL") Error : argument 'nullarg' is NULL Got expected error from try(plotmo(nullarg)) > expect.err(try(plotmo(NULL)), "argument 'NULL' is NULL") Error : argument 'NULL' is NULL Got expected error from try(plotmo(NULL)) > expect.err(try(plotmo(0)), "'0' is not an S3 model") Error : '0' is not an S3 model Got expected error from try(plotmo(0)) > expect.err(try(plotmo(list(1,2))), "'list(1, 2)' is a plain list, not an S3 model") Error : 'list(1, 2)' is a plain list, not an S3 model Got expected error from try(plotmo(list(1, 2))) > expect.err(try(plotmo(list(1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0))), + "object is a plain list, not an S3 model") Error : object is a plain list, not an S3 model Got expected error from try(plotmo(list(1, 2, 3, 4, 5, 6, 7, 8, 0, 1, 2, 3, 4, 5, 6, 7, 8, 0, 1, 2, 3, 4, 5, 6, 7, 8, 0, 1, 2, 3, 4, 5, 6, 7, 8, 0, 1, 2, 3, 4, 5, 6, 7, 8, 0, 1, 2, 3, 4, 5, 6, 7, 8, 0, 1, 2, 3, 4, 5, 6, 7, 8, 0, 1, 2, 3, 4, 5, 6, 7, 8, 0, 1, 2, 3, 4, 5, 6, 7, 8, 0, 1, 2, 3, 4, 5, 6, 7, 8, 0, 1, 2, 3, 4, 5, 6, 7, 8, 0, 1, 2, 3, 4, 5, 6, 7, 8, 0, 1, 2, 3, 4, 5, 6, 7, 8, 0, 1, 2, 3, 4, 5, 6, 7, 8, 0, 1, 2, 3, 4, 5, 6, 7, 8, 0, 1, 2, 3, 4, 5, 6, 7, 8, 0, 1, 2, 3, 4, 5, 6, 7, 8, 0))) > > source("test.epilog.R") plotmo/inst/slowtests/test.partykit.bat0000755000176200001440000000145514563571565020156 0ustar liggesusers@rem test.partykit.bat @echo test.partykit.bat @"C:\PROGRA~1\R\R-4.3.2\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.partykit.R @if %errorlevel% equ 0 goto good1: @echo R returned errorlevel %errorlevel%, see test.partykit.Rout: @echo. @tail test.partykit.Rout @echo test.partykit.R @exit /B 1 :good1 mks.diff test.partykit.Rout test.partykit.Rout.save @if %errorlevel% equ 0 goto good2: @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.partykit.save.ps @exit /B 1 :good2 @rem test.partykit.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.partykit.save.ps @if %errorlevel% equ 0 goto good3: @echo === Files are different === @exit /B 1 :good3 @rm -f test.partykit.Rout @rm -f Rplots.ps @exit /B 0 plotmo/inst/slowtests/make.README.figs.R0000644000176200001440000000310413725307662017544 0ustar liggesusers# make.README.figs.R: Build the figures used by plotmo README.md # The paths below assume that this file is in the plotmo/inst/slowtests directory # Swindon May 2018 library(plotmo) library(earth) # for the ozone1 data data(ozone1) library(randomForest) oz <- ozone1[, c("O3", "humidity", "temp")] # small set for illustration set.seed(2018) rf.mod <- randomForest(O3 ~ ., data=oz) # png("../../inst/README-figures/plotmo-randomForest.png", width=460, height=500) # plotmo(rf.mod, cex.caption=1.5, font.caption=2, oma=c(0,0,5,0), # persp.ticktype="detailed", persp.nticks=2) # dev.off() # png("../../inst/README-figures/plotres-randomForest.png", width=460, height=530) # set.seed(2018) # plotres(rf.mod, cex=1.1, cex.caption=1.5, font.caption=2, oma=c(1,0,3,0)) # dev.off() # png("../../inst/README-figures/plotres-glmnet-gbm.png", width=700, height=400) # par(mfrow=c(1,2), oma=c(1,0,0,0)) # library(glmnet) # set.seed(2016) # x <- matrix(rnorm(100 * 10), 100, 10) # y <- x[,1] + x[,2] + 3 * rnorm(100) # y depends only on x[,1] and x[,2] # mod <- glmnet(x, y) # plotres(mod, which=1, predict.s=0.25, cex=1.2, pt.cex=.8) # title("glmnet model\n\n\n") # library(gbm) # library(earth); data(ozone1) # get the ozone data # set.seed(2017) # oz <- ozone1[sample.int(n=nrow(ozone1)),] # randomize row order for train.fraction # gbm.mod <- gbm(O3~., data=oz, distribution="gaussian", interaction.depth=2, # shrinkage=.01, train.fraction=.8, cv.folds=10, n.trees=3000) # plotres(gbm.mod, which=1) # title("gbm model\n\n", xpd=NA) # dev.off() plotmo/inst/slowtests/test.plotmo.x.bat0000755000176200001440000000152214563571565020062 0ustar liggesusers@rem test.plotmo.x.bat: test plotmo_x and related functions @echo test.plotmo.x.bat @"C:\PROGRA~1\R\R-4.3.2\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.plotmo.x.R @if %errorlevel% equ 0 goto good1: @echo R returned errorlevel %errorlevel%, see test.plotmo.x.Rout: @echo. @tail test.plotmo.x.Rout @echo test.plotmo.x.R @exit /B 1 :good1 mks.diff test.plotmo.x.Rout test.plotmo.x.Rout.save @if %errorlevel% equ 0 goto good2: @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.plotmo.x.save.ps @exit /B 1 :good2 @rem test.plotmo.x.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.plotmo.x.save.ps @if %errorlevel% equ 0 goto good3: @echo === Files are different === @exit /B 1 :good3 @rm -f test.plotmo.x.Rout @rm -f Rplots.ps @exit /B 0 plotmo/inst/slowtests/test.partdep.Rout.save0000644000176200001440000002436114563614021021045 0ustar liggesusers> # partdep.test.R: partdep tests for plotmo and plotres > > source("test.prolog.R") > library(plotmo) Loading required package: Formula Loading required package: plotrix > library(earth) > data(etitanic) > > mod <- earth(survived~., data=etitanic, degree=2) > > plotmo(mod, caption="plotmo classical") plotmo grid: pclass sex age sibsp parch 3rd male 28 0 0 > > plotmo(mod, pmethod="partdep", caption="plotmo partdep age") calculating partdep for pclass calculating partdep for sex calculating partdep for age calculating partdep for pclass:sex 01234567890 calculating partdep for pclass:sibsp 01234567890 calculating partdep for sex:age 0123456790 > > set.seed(2016) > plotmo(mod, pmethod="apartdep", caption="plotmo apartdep age", do.par=2) calculating apartdep for pclass calculating apartdep for sex calculating apartdep for age calculating apartdep for pclass:sex 01234567890 calculating apartdep for pclass:sibsp 01234567890 calculating apartdep for sex:age 0123456790 > > set.seed(2016) > plotmo(mod, pmethod="apartdep", ylim=c(0,1), do.par=0, + type2="image", pt.col=ifelse(etitanic$survived, "green", "red"), + degree1=0, degree2=1:3) calculating apartdep for pclass:sex 01234567890 calculating apartdep for pclass:sibsp 01234567890 calculating apartdep for sex:age 0123456790 > par(org.par) > > # compare to gbm with an artifical function of variables with a very strong interaction > library(gbm) Loaded gbm 2.1.9 This version of gbm is no longer under development. Consider transitioning to gbm3, https://github.com/gbm-developers/gbm3 > n <- 250 > set.seed(2016) > x1 <- runif(n) > x2 <- runif(n) > x3 <- runif(n) > y <- ifelse(x2 > .6, x1-.2, ifelse(x2 > .4, 1 - 1.5 * x1, .3)) + .1 * sin(4 * x3) > data <- data.frame(x1=x1, x2=x2, x3=x3, y=y) > n.trees <- 20 > set.seed(2016) > mod <- gbm(y~., data=data, n.trees=n.trees, shrinkage=.1, + distribution="gaussian", interact=5) > plotmo(mod, degree1=0, persp.ticktype="detailed", + caption="variables with a strong interaction") > par(mfrow=c(4,4), mar=c(2,3,2,1), mgp=c(1.5, 0.5, 0), oma=c(0,0,6,0)) > library(viridis); Loading required package: viridisLite > image.col <- viridis(100) > ngrid1 <- 50 > ngrid2 <- 30 > plotmo(mod, pmethod="plot", do.par=0, degree2=2, type2="im", ylim=NULL, + clip=FALSE, image.col=image.col, ngrid1=ngrid1, ngrid=ngrid2) plotmo grid: x1 x2 x3 0.5048516 0.4915547 0.5632489 > title("row1: plotmo classic\nrow2: plotmo apartdep\nrow3: plotmo partdep\nrow4: plot.gbm\n\n\n\n\n\n\n", xpd=NA) > ylim <- c(.21, .40) > set.seed(2016) # for consistent selection of rows for partdep.x > plotmo(mod, pmethod="apartdep", do.par=0, degree2=2, type2="im", ylim=ylim, + clip=FALSE, image.col=image.col, ngrid1=ngrid1, ngrid=ngrid2) calculating apartdep for x1 calculating apartdep for x2 calculating apartdep for x3 calculating apartdep for x1:x3 01234567890 > plotmo(mod, pmethod="partdep", do.par=0, degree2=2, type2="im", ylim=ylim, + clip=FALSE, image.col=image.col, ngrid1=ngrid1, ngrid=ngrid2, + trace=-1) # check that the pacifier messages are suppressed > plot(mod, i.var=1, n.trees=n.trees, ylim=ylim, continuous.resolution=ngrid1) > plot(mod, i.var=2, n.trees=n.trees, ylim=ylim, continuous.resolution=ngrid1) > plot(mod, i.var=3, n.trees=n.trees, ylim=ylim, continuous.resolution=ngrid1) > # following ignores par(mfrow=c(2,2)) > plot(mod, i.var=c(1,3), n.trees=n.trees, continuous.resolution=ngrid2, + col.regions=image.col, colorkey=FALSE, + main="gbm plot x1:x3\ncompare to plotmo partdep on previous page") > par(org.par) > > #--- compare to gbm and randomForest with a simple regression function > > data(scor, package="bootstrap") # some correlated data > n <- 50 > x1 <- scale(scor$mec[1:n]) > x2 <- scale(scor$vec[1:n]) > data <- data.frame(x1=x1, x2=x2) > > ngrid1 <- 100 > > # randomForest, simple regression function > library(randomForest) randomForest 4.7-1.1 Type rfNews() to see new features/changes/bug fixes. > data$y <- x1 > -.1 # y depends only on x1 (-.1 hand-tuned to create interesting model surface) > set.seed(2016) > # Expect Warning: The response has five or fewer unique values. Are you sure you want to do regression? > mod <- randomForest(y~., data=data, ntree=3) Warning in randomForest.default(m, y, ...) : The response has five or fewer unique values. Are you sure you want to do regression? > par(mfrow=c(4,2), mar=c(2.5,3,2,1), mgp=c(1.3,0.4,0), oma=c(0,0,7,0)) > set.seed(2016) # for consistent jitter of response sites > plotmo(mod, degree1=0, ngrid2=100, do.par=0, clip=FALSE, + type2="image", main="regression surface", + pt.col=ifelse(data$y, "green", "red")) > title("RANDOM FOREST SIMPLE REGRESSION MODEL + row1: regression surface + row2: plotmo classic type=response + row3: plotmo partdep type=response + row4: randomForest plot\n\n\n\n\n\n\n", + xpd=NA, adj=0) > plotmo(mod, degree1=0, ngrid2=100, do.par=0, clip=FALSE, + persp.border=NA, main="regression surface") > plotmo(mod, pmethod="plotmo", do.par=0, degree2=0, ngrid1=ngrid1, + type="response") plotmo grid: x1 x2 -0.03826182 0.05194756 > plotmo(mod, pmethod="partdep", do.par=0, degree2=0, ngrid1=ngrid1, + type="response") calculating partdep for x1 calculating partdep for x2 > partialPlot(mod, pred.data=data, x.var="x1", n.pt=ngrid1, + which.class="True") > partialPlot(mod, pred.data=data, x.var="x2", n.pt=ngrid1, + which.class="True") > par(org.par) > > # gbm, simple regression function > library(gbm) > n.trees <- 20 > data$y <- x1 > -.6 # y depends only on x1 (-.1 hand-tuned to create interesting model surface) > set.seed(2016) > mod <- gbm(y~., data=data, n.trees=n.trees, + shrinkage=.1, interaction.depth=4, + distribution="gaussian") > par(mfrow=c(4,2), mar=c(2.5,3,2,1), mgp=c(1.3,0.4,0), oma=c(0,0,7,0)) > set.seed(2016) # for consistent jitter of response sites > plotmo(mod, degree1=0, ngrid2=100, do.par=0, clip=FALSE, + type2="image", main="regression surface", + pt.col=ifelse(data$y, "green", "red")) > title("GBM SIMPLE REGRESSION MODEL + row1: regression surface + row2: plotmo classic type=response + row3: plotmo partdep type=response + row4: gbm plot\n\n\n\n\n\n\n", + xpd=NA, adj=0) > plotmo(mod, degree1=0, ngrid2=100, do.par=0, clip=FALSE, + persp.border=NA, main="regression surface") > plotmo(mod, pmethod="plotmo", do.par=0, all1=TRUE, degree2=0, + ngrid1=ngrid1, type="response") plotmo grid: x1 x2 -0.03826182 0.05194756 > plotmo(mod, pmethod="partdep", do.par=0, all1=TRUE, degree2=0, + ngrid1=ngrid1, type="response") calculating partdep for x1 calculating partdep for x2 > plot(mod, i.var=1, n.trees=n.trees, continuous.resolution=ngrid1) > plot(mod, i.var=2, n.trees=n.trees, continuous.resolution=ngrid1) > par(org.par) > > #--- compare to gbm and randomForest with simple binomial (two class) data > > data(scor, package="bootstrap") # some correlated data > n <- 50 > x1 <- scale(scor$mec[1:n]) > x2 <- scale(scor$vec[1:n]) > data <- data.frame(x1=x1, x2=x2) > > ngrid1 <- 100 > > # randomForest, simple binomial (two-class) data > library(randomForest) > # y depends only on x1 > # random forest requires a factor for classification (not a logical) > data$y <- factor(as.character(x1 > .4), + levels=c("FALSE", "TRUE"), + labels=c("False", "True")) > set.seed(2016) > mod <- randomForest(y~., data=data, ntree=3) > par(mfrow=c(4,2), mar=c(2.5,3,2,1), mgp=c(1.3,0.4,0), oma=c(0,0,7,0)) > set.seed(2016) # for consistent jitter of response sites > plotmo(mod, degree1=0, ngrid2=100, do.par=0, clip=FALSE, + type2="image", main="regression surface", + pt.col=ifelse(data$y=="True", "green", "red")) > title("RANDOM FOREST SIMPLE TWO-CLASS MODEL + row1: regression surface + row2: plotmo partdep type=response (FALSE or TRUE) + row3: plotmo partdep type=prob + row4: randomForest partialPlot (clipped log odds)\n\n\n\n\n\n\n", + xpd=NA, adj=0) > plotmo(mod, degree1=0, ngrid2=100, do.par=0, clip=FALSE, + persp.border=NA, main="regression surface") > > plotmo(mod, pmethod="partdep", do.par=0, degree2=0, ngrid1=ngrid1, + type="response") calculating partdep for x1 calculating partdep for x2 > plotmo(mod, pmethod="partdep", do.par=0, degree2=0, ngrid1=ngrid1, + type="prob", nresponse="True", ylim=c(0,1)) calculating partdep for x1 calculating partdep for x2 > partialPlot(mod, pred.data=data, x.var="x1", n.pt=ngrid1, + which.class="True", ylim=c(-16,16)) > partialPlot(mod, pred.data=data, x.var="x2", n.pt=ngrid1, + which.class="True", ylim=c(-16,16)) > par(org.par) > > # gbm, simple binomial (two-class) data > library(gbm) > n.trees <- 10 > data$y <- x1 > .6 # y depends only on x1 > set.seed(2016) > mod <- gbm(y~., data=data, n.trees=n.trees, shrinkage=.1, interact=4, + distribution="bernoulli") > par(mfrow=c(4,2), mar=c(2.5,3,2,1), mgp=c(1.3,0.4,0), oma=c(0,0,7,0)) > set.seed(2016) # for consistent jitter of response sites > plotmo(mod, degree1=0, ngrid2=100, do.par=0, clip=FALSE, + type2="image", main="regression surface", + pt.col=ifelse(data$y, "green", "red")) > title("GBM SIMPLE TWO-CLASS MODEL + row1: regression surface + row2: plotmo partdep type=response (probability) + row4: plotmo partdep type=link (log odds) + row3: gbm plot (log odds)\n\n\n\n\n\n\n", + xpd=NA, adj=0) > plotmo(mod, degree1=0, ngrid2=100, do.par=0, clip=FALSE, + persp.border=NA, main="regression surface") > plotmo(mod, pmethod="partdep", do.par=0, all1=TRUE, degree2=0, + ngrid1=ngrid1, type="response") calculating partdep for x1 calculating partdep for x2 > plotmo(mod, pmethod="partdep", do.par=0, all1=TRUE, degree2=0, + ngrid1=ngrid1, type="link") calculating partdep for x1 calculating partdep for x2 > plot(mod, i.var=1, n.trees=n.trees, continuous.resolution=ngrid1) > plot(mod, i.var=2, n.trees=n.trees, continuous.resolution=ngrid1) > par(org.par) > > source("test.epilog.R") plotmo/inst/slowtests/test.parsnip.bat0000755000176200001440000000221414563571565017755 0ustar liggesusers@rem test.parsnip.bat @rem Stephen Milborrow Sep 2020 Petaluma @echo test.parsnip.bat @"C:\PROGRA~1\R\R-4.3.2\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.parsnip.R @if %errorlevel% equ 0 goto good1 @echo R returned errorlevel %errorlevel%, see test.parsnip.Rout: @echo. @tail test.parsnip.Rout @echo test.parsnip.R @exit /B 1 :good1 @rem second egrep gets rid of random messages issued by library(tidymodels) @rem could perhaps use suppressPackageStartupMessages() instead @egrep -v "Fit time:| Use | Dig | Learn | Search |^\* " test.parsnip.Rout >test.parsnip.Rout2 mv test.parsnip.Rout2 test.parsnip.Rout mks.diff test.parsnip.Rout test.parsnip.Rout.save @if %errorlevel% equ 0 goto good2 @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.parsnip.save.ps @exit /B 1 :good2 @rem test.parsnip.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.parsnip.save.ps @if %errorlevel% equ 0 goto good3 @echo === Files are different === @exit /B 1 :good3 @rm -f test.parsnip.Rout test.parsnip.Rout @rm -f Rplots.ps @exit /B 0 plotmo/inst/slowtests/test.glmnetUtils.R0000644000176200001440000001414413727235376020243 0ustar liggesusers# test.glmnet.R: glmnetUtils tests for plotmo and plotres source("test.prolog.R") library(earth) library(glmnetUtils) data(ozone1) data(etitanic) get.tit <- function() # abbreviated titanic data { tit <- etitanic pclass <- as.character(tit$pclass) # change the order of the factors so not alphabetical pclass[pclass == "1st"] <- "first" pclass[pclass == "2nd"] <- "class2" pclass[pclass == "3rd"] <- "classthird" tit$pclass <- factor(pclass, levels=c("class2", "classthird", "first")) # log age is so we have a continuous predictor even when model is age~. set.seed(2015) tit$logage <- log(tit$age) + rnorm(nrow(tit)) tit$parch <- NULL # by=12 gives us a small fast model with an additive and a interaction term tit <- tit[seq(1, nrow(etitanic), by=12), ] } plotmores <- function(object, ..., trace=0, SHOWCALL=TRUE, title.extra="", ncol=2) { old.par <- par(no.readonly=TRUE) on.exit(par(old.par)) par(mfrow=c(2,ncol)) caption <- paste(deparse(substitute(object)), collapse=" ") call <- match.call(expand.dots=TRUE) call <- strip.space(paste(deparse(substitute(call)), collapse=" ")) call <- gsub(",", ", ", call) call <- paste(title.extra, call, sep="") printf("%s\n", call) # plotmo on glmnet mods is boring but we test it anyway plotres(object, trace=trace, SHOWCALL=SHOWCALL, do.par=FALSE, which=c(1,3), ...) title(paste("\n", call), outer=TRUE) plotmo(object, trace=trace, SHOWCALL=SHOWCALL, do.par=FALSE, ...) } tit <- get.tit() set.seed(2015) xmat <- as.matrix(tit[,c(2,5,6)]) agedata <- data.frame(tit[,4], xmat) colnames(agedata) <- c("age", "survived", "sibsp", "logage") set.seed(2015) mod.glmnet.xmat <- glmnet(xmat, tit[,4]) # tit[,4] is age plotres(mod.glmnet.xmat) plotmo(mod.glmnet.xmat) plotmores(mod.glmnet.xmat, predict.s=2.5) mod.glmnet.agedata <- glmnet(age~., data=agedata) expect.err(try(plotres(mod.glmnet.agedata)), "for this plot, glmnet.formula must be called with use.model.frame=TRUE") mod.glmnet.agedata <- glmnet(age~., data=agedata, use.model.frame=TRUE) plotmores(mod.glmnet.agedata, predict.s=2.5) set.seed(2015) mod.cv.glmnet.xmat <- cv.glmnet(xmat, tit[,4], nfolds=3) cat("==Test plotmo trace=1 and lambda.min\n") plotmores(mod.cv.glmnet.xmat, predict.s="lambda.min", trace=1, ncol=3) set.seed(2015) mod.cv.glmnet.agedata <- cv.glmnet(age~., data=agedata) expect.err(try(plotres(mod.cv.glmnet.agedata)), "for this plot, cv.glmnet.formula must be called with use.model.frame=TRUE") set.seed(2015) mod.cv.glmnet.agedata <- cv.glmnet(age~., data=agedata, use.model.frame=TRUE) cat("==Test lambda.min\n") plotmores(mod.cv.glmnet.agedata, predict.s="lambda.min", trace=1, ncol=3) printf("======== binomial model\n") set.seed(2016) n <- 50 p <- 4 xx <- matrix(rnorm(n*p), n, p) colnames(xx) <- paste("x", 1:ncol(xx), sep="") yy <- ifelse(xx[,1] + xx[,2] + rnorm(n) > .5, TRUE, FALSE) print(cov(xx, yy)) yy <- factor(yy) dataxy <- data.frame(yy, xx) binomial.mod <- glmnet(xx, yy, family="binomial") plotmores(binomial.mod, ncol=3) binomial.mod.form <- glmnet(yy~., data=dataxy, family="binomial", use.model.frame=TRUE) plotmores(binomial.mod.form, ncol=3) par(org.par) printf("======== glmnet family=\"mgaussian\"\n") set.seed(2015) p <- 10 n <- 30 xx <- cbind((1:n)/n, matrix(rnorm(n*(p-1)),n,p-1)) colnames(xx) <- paste0("x", 1:p) # ymultresp <- cbind(rowSums(xx[,1:5]^3), rowSums(xx[,5:p]^3), 1:n) set.seed(1) ymultresp <- cbind(xx[,1]+.001*rnorm(n), rowSums(xx[,2:5]^3), rnorm(n)) glmnet.mgaussian <- glmnet(xx, ymultresp, family="mgaussian") plotres(glmnet.mgaussian, nresponse=1, SHOWCALL=TRUE, which=c(1:3), do.par=2, info=1) # manually calculate the residuals plot(x=predict(glmnet.mgaussian, newx=xx, s=0)[,1,1], y=ymultresp[,1] - predict(glmnet.mgaussian, newx=xx, s=0)[,1,1], pch=20, xlab="Fitted", ylab="Residuals", main="Manually calculated residuals, nresponse=1, s=0") abline(h=0, col="gray") par(org.par) # # TODO is glmnet mgaussian supported with a formula interface? # dataxy <- data.frame(ymultresp, xx) # colnames(dataxy) <- c("y1", "y2", "y3", "x1", "x2", "x3", "x4", "x5", "x5", "x6", "x7", "x8", "x9", "x10") # glmnet.mgaussian.form <- glmnet(xx, ymultresp, family="mgaussian") # plotres(glmnet.mgaussian.form, nresponse=1, SHOWCALL=TRUE, which=c(1:3), do.par=2, info=1) par(mfrow=c(2,3), mar=c(3,3,3,.5), oma=c(0,0,3,0), mgp=c(1.5,0.4,0), tcl=-0.3) data(trees) set.seed(2015) # variable with a long name x50 <- cbind(trees[,1:2], Girth12345678901234567890=rnorm(nrow(trees))) mod.with.long.name <- glmnet(data.matrix(x50),data.matrix(trees$Volume)) plotmores(mod.with.long.name, ncol=3) data.x50 <- data.frame(trees$Volume, x50) colnames(data.x50) <- c("Volume", "Girth", "Height", "Girth12345678901234567890") mod.with.long.name.form <- glmnet(Volume~., data=data.x50, use.model.frame=TRUE) plotmores(mod.with.long.name.form, ncol=3) par(org.par) #-- make sure that we can work with all families set.seed(2016) par(mfrow=c(3,3), mar=c(3,3,3,1)) n <- 100 p <- 4 xx <- matrix(rnorm(n*p), n, p) g2 <- sample(1:2, n, replace=TRUE) data.xg2 <- data.frame(g2, xx) for(family in c("gaussian","binomial","poisson")) { title.extra <- paste(family, ": ") mod <- glmnet(xx,g2,family=family) plotmores(mod, xvar="lambda", ncol=3, title.extra=title.extra) title.extra <- paste("formula", family, ": ") mod.form <- glmnet(g2~., data.xg2, family=family, use.model.frame=TRUE) plotmores(mod.form, xvar="lambda", ncol=3, title.extra=title.extra) } par(org.par) # cox library(plotmo) n <- 100 p <- 20 nzc <- trunc(p/10) set.seed(2016) beta <- rnorm(nzc) x7 <- matrix(rnorm(n*p), n, p) beta <- rnorm(nzc) fx <- x7[,seq(nzc)] %*% beta/3 hx <- exp(fx) ty <- rexp(n, hx) tcens <- rbinom(n=n, prob=.3, size=1)# censoring indicator yy <- cbind(time=ty, status=1-tcens) # yy=Surv(ty,1-tcens) with library(survival) glmnet.cox <- glmnet(x=x7, y=yy, family="cox") plotmores(glmnet.cox, ncol=3, degree1=1:4) par(org.par) # TODO formula interface not tested for cox models source("test.epilog.R") plotmo/inst/slowtests/test.mlr.bat0000755000176200001440000000142314563571565017074 0ustar liggesusers@rem test.mlr.bat: mlr tests for plotmo and plotres @echo test.mlr.bat @"C:\PROGRA~1\R\R-4.3.2\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.mlr.R @if %errorlevel% equ 0 goto good1: @echo R returned errorlevel %errorlevel%, see test.mlr.Rout: @echo. @tail test.mlr.Rout @echo test.mlr.R @exit /B 1 :good1 mks.diff test.mlr.Rout test.mlr.Rout.save @if %errorlevel% equ 0 goto good2: @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.mlr.save.ps @exit /B 1 :good2 @rem test.mlr.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.mlr.save.ps @if %errorlevel% equ 0 goto good3: @echo === Files are different === @exit /B 1 :good3 @rm -f test.mlr.Rout @rm -f Rplots.ps @exit /B 0 plotmo/inst/slowtests/test.plotres.R0000644000176200001440000003156713727235376017434 0ustar liggesusers# test.plotres.R source("test.prolog.R") library(earth) data(ozone1) data(etitanic) example(plotres) # basic tests of plotmo on abbreviated titanic data get.tit <- function() { tit <- etitanic pclass <- as.character(tit$pclass) # change the order of the factors so not alphabetical pclass[pclass == "1st"] <- "first" pclass[pclass == "2nd"] <- "class2" pclass[pclass == "3rd"] <- "classthird" tit$pclass <- factor(pclass, levels=c("class2", "classthird", "first")) # log age is so we have a continuous predictor even when model is age~. set.seed(2015) tit$logage <- log(tit$age) + rnorm(nrow(tit)) tit$parch <- NULL # by=12 gives us a small fast model with an additive and a interaction term tit <- tit[seq(1, nrow(etitanic), by=12), ] } tit <- get.tit() plotlm1 <- function(object) { old.par <- par(no.readonly=TRUE) on.exit(par(old.par)) par(mfrow=c(2,2), oma=c(0,0,3,0), mar=c(4, 3, 3, 1.5), mgp=c(1.5, 0.4, 0), tcl=-.3, font.main=1, cex.main=1) plot(object, sub.caption="standard call to plot.lm") } plotlm.using.plotres <- function(object) { old.par <- par(no.readonly=TRUE) on.exit(par(old.par)) par(mfrow=c(2,2), oma=c(0,0,3,0), mar=c(4, 3, 3, 1.5), mgp=c(1.5, 0.4, 0), tcl=-.3, font.main=1, cex.main=1) # residuals vs fitted plotres(object, pch=1, which=3, caption=paste(deparse(object$call), collapse=" ")) # QQ plot plotres(object, pch=1, which=4, standardize=TRUE) # scale-location plot plotres(object, pch=1, which=6, standardize=TRUE) # leverage plot plotres(object, pch=1, which=3, versus=4, standardize=TRUE) } lm.mod <- lm(Volume~., data=trees) plotlm1(lm.mod) plotlm.using.plotres(lm.mod) # various arguments plotres(lm.mod, SHOWCALL=TRUE) plotres(lm.mod, level=.95, id.n=-3, SHOWCALL=TRUE) lm.tit <- lm(survived~., data=tit) col <- ifelse(tit$survived, "green", "red") pch <- ifelse(tit$sex == "male", 20, 6) plotres(lm.tit, level=.95, col=col, pch=pch, level.shade="gray", level.shade2="lightgray", SHOWCALL=TRUE) plotres(lm.tit, col.resp=3, cum.col=2, cum.cex=1.2, grid.col=5, qq.col=1, qq.cex=.3, SHOWCALL=TRUE) plotres(lm.tit, pt.col="pink", smooth.col=0, SHOWCALL=TRUE) plotres(lm.tit, smooth.col=3, smooth.lwd=1.2, smooth.lty=2, smooth.f=.2, label.col=4, label.cex=.9, label.font=2, SHOWCALL=TRUE) foo <- function() { afoo <- earth(O3~., data=ozone1, deg=2) old.par <- par(no.readonly=TRUE) on.exit(par(old.par)) par(mfrow=c(2,2), oma=c(0,0,3,0), mar=c(4, 3, 3, 1.5), mgp=c(1.5, 0.4, 0), tcl=-.3, font.main=1, cex.main=1) # test xlim ylim etc. on qq and cum plots plotres(afoo, which=2, trace=0, xlim=c(0,20), ylim=c(-.2,1.1), grid.col="pink", info=TRUE) plotres(afoo, which=2, trace=0, grid.col="pink", info=TRUE, cum.col=2, cum.cex=1.4) plotres(afoo, which=4) plotres(afoo, which=4, trace=0, xlim=c(-7,7), ylim=c(-20, 20), qq.col=2, qq.cex=.5, label.col=1, qqline.col="orange", qqline.lty=1) # check xlim and ylim apply only to resids plots if multiple plots plotres(afoo, which=c(2:5), trace=0, xlim=c(-1,5), ylim=c(-8, 8), qq.col=2, qq.cex=.5, label.col=1, qqline.col="orange", smooth.col=3, smooth.lwd=2) } foo() # test id.n and npoints set.seed(1066) a20 <- earth(Volume~., data=trees, ncr=3, nfo=3, varmod.method="lm", keepxy=TRUE) par(mfrow=c(2,2), oma=c(0,0,3,0), mar=c(4, 3, 3, 1.5), mgp=c(1.5, 0.4, 0), tcl=-.3, cex=1) plot(a20, which=3, standardize=TRUE, smooth.col=0, id.n=-1, main="a20-00, smooth.col=0, id.n=-1", caption="test id.n and npoints") plot(a20, which=3, standardize=TRUE, smooth.col=0, id.n=10, main="a20-01, smooth.col=0, id.n=10") # this tests cex with do.par=FALSE plot(a20, which=3, standardize=TRUE, smooth.col=0, npoints=10, cex=.8, main="a20-02, smooth.col=0, npoints=10, cex=.8") # TODO labels are hosed in the following plot(a20, which=3, standardize=TRUE, smooth.col=0, npoints=5, id.n=10, main="a20-03, labels hosed\nsmooth.col=0, npoints=10, id.n=10") # test leverages and handling of unity leverages lm.mod <- lm(Volume~., data=trees) par(mfrow=c(2,2), oma=c(0,0,3,0), mar=c(4, 3, 3, 1.5), mgp=c(1.5, 0.4, 0), tcl=-.3, cex=1) a20$leverages[31] <- 1 # fake a unity leverage plot(a20, which=3, versus=4, standardize=TRUE, main="resids vs leverage\nunity leverage", caption="leverage plots") plotres(a20, which=3, standardize=TRUE, main="resids vs fitted\nunity leverage") plotres(lm.mod, which=3, versus=4, standardize=TRUE, main="lever plot for lm.mod") plotres(lm.mod, which=3, versus=4, standardize=TRUE, main="cook args", cook.levels=c(.5, .8, 1), cook.col="blue", cook.lty=2) plot(a20, which=3, versus=4, standardize=TRUE, info=TRUE, main="resids vs leverage\nunity leverage", caption="leverage plots with info=TRUE") plotres(a20, which=3, standardize=TRUE, info=TRUE, main="resids vs fitted\nunity leverage") plotres(lm.mod, which=3, versus=4, standardize=TRUE, info=TRUE, main="lever plot for lm.mod") plotres(lm.mod, which=3, versus=4, standardize=TRUE, info=TRUE, main="cook args", cook.levels=c(.5, .8, 1), cook.col="blue", cook.lty=2) # back compat tests par(mfrow=c(2,2), oma=c(0,0,3,0), mar=c(4, 3, 3, 1.5), mgp=c(1.5, 0.4, 0), tcl=-.3) plotres(a20, which=3, col.smooth=4, smooth.lwd=2, smooth.lty=2, main="a20-04 col.smooth=4, smooth.lwd=2, smooth.lty=2", caption="back compat tests with plot.earth") plotres(a20, which=4, qq.col=3, qqline.col="lightblue", qqline.lty=2, main="a20-05 qq.col=3") plotres(a20, which=4, qqline.col=0, main="a20-06 qqline.col=0") # set.seed(1066) # mod.earth.tit <- earth(tit[,-3], tit[,3], degree=2, nfold=3, ncross=3, varmod.method="earth", keepxy=TRUE) plot(0,0) plot(a20, which=1, col.grid="pink", col.rsq=3, lty.rsq=1, main="a20-07 col.grid=\"pink\", col.rsq=3, lty.rsq=1") # TODO following not working? plot(a20, which=3, col.cv=4, col.grid="pink", main="a20-08 col.cv=4, col.grid=\"pink\"") plot(a20, which=3, col.points="orange", cex.points=1.5, main="a20-09 col.points=\"orange\", cex.points=1.5") plot(a20, which=3, col.residuals="orange", smooth.f=.2, col.line=3, main="a20-10 col.residuals=\"orange\", smooth.f=.2, col.line=3") # test graphics args outside do.par par(col.main="#456789") cat("before par: cex=", par("cex"), " col.main=", par("col.main"), " col.axis=", par("col.axis"), "\n", sep="") plot(a20, which=c(2,3), caption="a20 which=c(2,3) (i.e. do.par=TRUE) no cex") plot(a20, which=c(2,3), cex=1, caption="a20 which=c(2,3) (i.e. do.par=TRUE) cex=1, plot should be identical to previous page") plot(a20, which=c(2,3), cex=1.2, caption="a20 which=c(2,3) (i.e. do.par=TRUE) cex=1.2") plot(a20, which=3, main="no cex", caption="a20 test graphics args with do.par=FALSE") plot(a20, which=3, cex=1, main="cex=1") plot(a20, which=3, cex=.8, main="cex=.8") plot(a20, which=3, cex=1.1, col.main=2, col.axis="blue", col.lab=3, font.lab=2, main="cex=1.1, col.main=2, col.axis=\"blue\", col.lab=3, font.lab=2") # all of these should have been restored cat("after par: cex=", par("cex"), " col.main=", par("col.main"), " col.axis=", par("col.axis"), "\n", sep="") stopifnot(par("col.main") == "#456789") par(col.main=1) survived <- as.numeric(tit$survived) # 0 or 1 sex <- as.numeric(tit$sex) # 1 or 2 pclass <- as.numeric(tit$pclass) # 1,2, or 3 age <- tit$age # .2 to 80 printf("======== basic operation, compare to plot.lm etc.\n") par(mfrow=c(2,2), mar=c(3,3,3,1), mgp=c(1.5,0.5,0), oma=c(0,0,2.5,0)) lm <- lm(survived~sex+pclass+age) plot(lm, which=5, pch=20) plot(0, 0) plot(lm, which=1, pch=20) plot(lm, which=2, pch=20) plotres(lm, standardize=1, cook.levels=c(.1,.2,.3), SHOWCALL=TRUE) elm <- earth(survived~sex+pclass+age, linpreds=TRUE, thresh=0, penalty=-1) plotres(elm, col=survived+2, SHOWCALL=TRUE) set.seed(2015) elm.glm <- earth(survived~sex+pclass+age, linpreds=TRUE, thresh=0, penalty=-1, glm=list(family=binomial), ncr=3, nfold=3, varmod.method="lm") plotres(elm.glm, col=survived+2, SHOWCALL=TRUE) printf("======== check type arg with earth\n") par(mfrow=c(2,2), mar=c(3,3,3,1), mgp=c(1.5,0.5,0), oma=c(0,0,2.5,0)) # following two are equivalent # TODO $$ following look wrong (the plots have changed from plotmo/earth pre Sep 2020) plotres(elm.glm, col=survived+2, standardize=TRUE, which=3, do.par=FALSE, main="standardize=TRUE") mtext("elm.glm with various type options", outer=TRUE, font=2, line=1, cex=1) plotres(elm.glm, col=survived+2, type="standardize", which=3, do.par=FALSE, main="type=\"standardize\"\nequivalent to standardize=TRUE") # TODO double standardization, should not be allowed plotres(elm.glm, col=survived+2, standardize=TRUE, type="standardize", which=3, do.par=FALSE, main="standard=TRUE, type=\"deviance\"\ndouble standardization") plotres(elm.glm, col=survived+2, type="deviance", which=3, do.par=FALSE, main="type=\"deviance\"") printf("======== multiple response earth models\n") par(mfrow=c(2,2), mar=c(3,3,3,1), mgp=c(1.5,0.5,0), oma=c(0,0,2.5,0)) set.seed(2015) emulti0 <- earth(cbind(Volume, Volume + 100 + 5 * rnorm(nrow(trees)))~., data=trees) set.seed(2015) plot(emulti0, nresponse=2, which=3, do.par=FALSE, main="emulti0 nresponse=2") set.seed(2015) rnorm1 <- rnorm(nrow(trees)) emulti <- earth(cbind(Volume, Volume + 100 + 5 * rnorm1)~., data=trees) plot(emulti, nresponse=2, which=3, do.par=FALSE, main="emulti nresponse=2") mtext("multiple response earth models", outer=TRUE, font=2, line=1, cex=1) plot(emulti, nresponse=2, FORCEPREDICT=TRUE, which=3, do.par=FALSE, main="emulti, nresponse=2\nFORCEPREDICT=TRUE") printf("======== earth model with a factor response\n") epclass <- earth(pclass~., data=tit) par(mfrow=c(2,2), mar=c(3,3,3,1), mgp=c(1.5,0.5,0), oma=c(0,0,2.5,0)) set.seed(2015) plot(epclass, nresponse="first", trace=1, which=3, do.par=FALSE, main="pclass response, nresponse=\"first\"") mtext("earth model with a factor response", outer=TRUE, font=2, line=1, cex=1) plot(epclass, nresponse="first", trace=1, FORCEPREDICT=TRUE, which=3, do.par=FALSE, main="pclass response, nresponse=\"first\"\nFORCEPREDICT=TRUE") printf("======== glm\n") glm <- glm(survived~sex+pclass+age, family=binomial) par(mfrow=c(2,2), mar=c(3,3,3,1), mgp=c(1.5,0.5,0), oma=c(0,0,2.5,0)) plot(glm, which=1, pch=20, main="plot.lm") mtext("glm model with plot.lm and plotres", outer=TRUE, font=2, line=1, cex=1) plotres(glm, which=3, main="plotres glm survived") # with plotres we can also plot pearson etc. residuals plotres(glm, which=3, type="pearson", main="plotres glm survived\ntype=\"pearson\"") printf("======== rpart\n") library(rpart) par(mfrow=c(2,2), mar=c(3,3,3,1), mgp=c(1.5,0.5,0), oma=c(0,0,2.5,0)) rpart <- rpart(survived~sex+pclass+age) plotres(rpart, SHOWCALL=TRUE) plotres(rpart, SHOWCALL=TRUE, FORCEPREDICT=TRUE) # identical # TODO following fails in plotmo.predict.rpart (which is called to get the fitted values) # plotres(rpart, type="pearson") plotres(rpart, jitter=3, w1.extra=100, w1.under=TRUE, w1.branch.type=5, col=survived+2, smooth.col=NA, label.col=1, SHOWCALL=TRUE) fit <- rpart(Kyphosis ~ Age + Number + Start, data = kyphosis) plotres(fit, nresponse=1, SHOWCALL=TRUE, jitter=5) plotres(fit, nresponse=2, SHOWCALL=TRUE, jitter=TRUE) printf("======== versus=\"b:\"\n") library(gam) gam.package.loaded <- "package:gam" %in% search() mgcv.package.loaded <- "package:mgcv" %in% search() if(mgcv.package.loaded && gam.package.loaded) { # prevent downstream confusing error messages stop0("both 'gam' and 'mgcv' are loaded") } library(earth) data(ozone1) data(ozone1) oz <- ozone1[, c("O3", "humidity", "temp", "ibt")] gam.mod <- gam(O3^(1/3) ~ lo(humidity)+lo(ibt,temp), data=oz) plotmo(gam.mod, SHOWCALL=TRUE) plotres(gam.mod, SHOWCALL=TRUE) plotres(gam.mod, versus="b:", SHOWCALL=TRUE) plotres(gam.mod, versus="b:ib", info=TRUE, SHOWCALL=TRUE) gam.linear.humidity.only <- gam(O3^(1/3) ~ humidity, data=oz) plotres(gam.linear.humidity.only, versus="b:", SHOWCALL=TRUE) library(mda) mars <- mars(ozone1[,2:3], ozone1[,1], degree=2) mars.to.earth <- mars.to.earth(mars) plotres(mars, versus="b:", caption="mars model, versus=\"b:\"", SHOWCALL=TRUE) plotres(mars.to.earth, versus="b:", caption="earth model, versus=\"b:\", should be same as previous page", SHOWCALL=TRUE) plotres(mars, versus="b:1", caption="mars model, versus=\"b:1\"", SHOWCALL=TRUE) # lars is tested in plotmo3.R # gbm is tested in plotmo3.R # TODO fda is not tested source("test.epilog.R") plotmo/inst/doc/0000755000176200001440000000000014334575431013317 5ustar liggesusersplotmo/inst/doc/modguide.pdf0000644000176200001440000024645614055554374015633 0ustar liggesusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 3142 /Filter /FlateDecode /N 52 /First 405 >> stream xZ[s6~_FtƗv\If Kō,DRݱ)!ppps`eL+2* 3*e9ic(晔R0>E4͘TLzTjA2=cZf 6LgioQw, :uL f0ZH-KF13+ey;fE=c&Yf)MY'<%^ҘΘuOY4sYr+0ͼO I(IhCxǔ7{,1W!B͋h,M73 De`E㏌p<,KDφWՕ?or|Z^~ VrΞI>c'˻A:χUQUΞBJ+t=;!k訓yՄM0|_#w|`OP9)ۺ=Q~ΎѤ\TѼOۋ k6ȯbnΧ  :.SpFo AuEcD|=ZuNguB$Z4ol*Z7 2vNk"ͤM[JT$[ȯ8rY")tXG:NJc 3XEp"QN>pӸ i\4%eO#kY\c56{>{>X.q?0k $Ec3A'Wg'X'~3yCyeÈ鋣 :6bvE=Ud8'+&kaCZL[6,~-$dVڶBډp-QݮU+|13P 3a\C-.=C\jhf}z je3hШK)Ҕe{`LI]ڣ@bٴTҕDbDzjyq5iXS'|~ȟ/1??7-!sj3Q9-g1yb/%<_:O8:^|ʯSyK-sapD Pc .7e/DPs.OyQ|)Yj2s^ݕw3H>Uf:(`?P#.#q?/jeNy/A ,IPbvD l:۳''ǯN)hg{EjXߞQH{FAht0(\X:ӟO×x_mpZv7iŧ}/Z|zCa(j*bݾƺIMGƄ |cl׾uUmo0 OÚ| éGXbنp_;:d[: sGS lPx :{YsiEmt׶CW_a_Sq({/'d S3泙5"z֌6 >ƫDBM8 X3c0RU ٗ]sk[>㍜XQf6.ܦ Gz/^zeKNhd2Q"K< c aG!ŨƻSR%:VYDY8FU;.]rM SOu9NE[Hh:PL1:{\)!pm8rKnKrΫI9^dlC6 'IKik5'F0$|iEBjҡh#[Liʅ;һ3)NKRJh{R2&!lS>y\U"UU} Z)m.[H| <)\Nendstream endobj 54 0 obj << /Subtype /XML /Type /Metadata /Length 1629 >> stream GPL Ghostscript 9.19 2021-06-01T17:03:55-07:00 2021-06-01T17:03:55-07:00 LaTeX with hyperref package Guidelines for S3 Regression ModelsStephen MilborrowS3 Regression Models endstream endobj 55 0 obj << /Type /ObjStm /Length 1972 /Filter /FlateDecode /N 51 /First 406 >> stream xY]s۶}c;wNog9NӉs])Mf@˴FuIv}@Q帡xl .=%Gvx"$&-~XASD& YCX)MJq58AҸJ"w)"2i"؀p˜'J E\ JXi(4&^*q_E5`#c{ ^8vA0A8% bD454 1F'Հ 4L\6#hx @YX'"N'euW-6JvA?7&_^)WXY8oOoy1=\9&:DAQPĩD=pJQp(|4BJ5t:4Kv4j 40a$RUx$AlRFR.P=$,GZxxSTxrlRy)'졇~SW9*@#lʠwN ~da/!d@N{=DW@5` km=gGwջF"eV˧[-L򦧬FVuFT{lnz'}ӈ CA$_-Ilu*QRqTbOHV~Љ ;ThMTeiy2E.B0`0P]__* ͦt-Wgp2Qlg%\*$c]ˏcy?˶1m@̶,[rE⨸ȫ|?׼M_^ѭY4V|xOendstream endobj 107 0 obj << /Filter /FlateDecode /Length 4575 >> stream x\Y~G[fτ8AĈX^ V{H]OdѬ-VX"b'߮JJ߬~X:q~)0k%v)>Zѧr-9^շ/Nbo9\Bi`/6&1 7wVx#V Q+|c2nG"a76ͫ aa~Ґ;w033_}2 +?dQ͈KԆ[K)F;Z3 -5h)K&hG(!wKGIlAzk{icXKTIF T;5yҠz_HG|M[9σPnREk0PV2ӜLI5Ihڀ*ڌDJMX$VODPˆ`z)2b^)H۾ϿFg䘞/P!qa9UVB沼J֩hur=gT ZkìHIGl {{츰Kvl"q]rSS1!ˏ&QD*j1?:SѐpYH'(P #jtc2N8ڂ%[̾z[L: 66B<1& yE3\rE w'<A)<ұ/%Ԥ4fcImsp%&ʍqsO*1<*VB]&jP笕8яI"tDZEg2@Sƣ!r%Fs!_8'p(LzN0;& @_I{z7TfIPM=Pbɦ3֦L Au/2h.)k#0y(rm$~(m pxh 'Ѡ޾}^>\Va nqt&&%G jd^VT9T+^KG({z}`VŽ7Tv#cE4 g}l>1WXP+FֲWls`;C|^FɌbAuw2-dAl!4䄀L|p]%1e$ P|jaM4Tkhejr f9Lbz$kܟ.f"y6!ۅY}$=HXd ӊyg(>wt1BYh f2][nY?la}-K-dcO'jƬ~*Tkf)r 98N,HBn]WCJ18-?-x`7YC6$'ZC}A5e#^뫽>.-JePJe~ l_H.9 3þ- )2LIUCf>}+(1k|dMI 49՛8ΐ8k:y *`it Ԓn~ǁV&FBopx[vC@j2Yjx24g0=N -_PKAO6 @i&aZM{ ƙ 8P5HO*L)?_DQ %Dt+^Þ=QUH~f?ܴ"q.?javz*%Y8[jag bnLSt+pM\aާY̢}BolY< GW9&T\:nH^?5\34 tzjg>^F&϶L1Hp'Z݄{VCVT1|{FڌJP4D?:C׶Sm`it:RB2mMLtN>.x\>j0^;VN>`:і3  W_`RZ `k}Y} ;; .MH#n4LN9Yw^VD5bys>%U:rFԌ+gpƥo DO'މJ⑮.ǎdglT}n1['3-9/%i淧@#e-o( Ϝܦ.4gr034:Ϸ mn"AN] (m0Uv7۵K6P3921R~IrN$;k_xR墠"o҆wY%CuӐ|4V[KUh@-A?;aԵͧaHI{N@3m>,$mbWm:S~9P 9EIOHX!qv xy}(^vtc?@ǦdIF\BEvq-I,OuհCD̄ #%CM:P&EG+[+6ŸrJK-/q1ҭ+rnrGB7zrׂ|i(OJ.<)&󊝒S3tQM(lFq0e{8hu1j^sJ7@)l6ϻ3{tkh2UJ2"ȽhwU G^Ġ[MV;逘)+%>h.PJ$󏺳K[n+9/l0lJڴ>t1Bi)[npz 3ʵ_Gg =BL˶/b,PPl׷+$ F[l5l7'dpS]+<'UZd-îx:Q2.80WhFKA&onnONONk_g|W "i"P+ zGEL޿Y,Uxȭ-wh\Gr` 2F.Rȸ/㮃^>6+e{QeS33KbUH&~K2+h¡#]@DC4\ol:2U;=ųOy䚶c0 3N@g?-%O=iO%Ve 8xOفDKЧH.·.yrV*2ۏprV(Y읓]cϴ r 6ӐNwƧOua]-;~7}a-L3 .YpZh}tg T)GdyJ@^24VK u"te4dfȃgؘnȟ̇ƺ`!O*^r-gzGA ''xV\{pџ cNɥI 9K`%jx)=zӏ&u3#2d7' ./[tօn?wI!f˜rahF~`endstream endobj 108 0 obj << /Filter /FlateDecode /Length 4828 >> stream x\nIr} MC,U3vP$%y5~#""oͦ UYy8q"2=q8߳˃範:|=z a'"C!`<gr YOSOx=z^EϏg67f󡗶s)^αCi3f^ɏ <9f z{Ȯez&|}|iͱ.;nXCgu'rSRve$kLUv% ޏE 0k8s+Nw5*7q> ux,q"`0 P]?DطB;&[4jPlQAtYƖR]':{./٧s;vyݳc1Vo\oul`hMUƴzpP 2 R^(+;a0 HfѪr?#tw 둔z/h?~Ebϖڃ>A6 8rO0}l'; ԇ٩W)ȠOK1&@D`[ W.EJ=[/u8i_>vVv$W)Ƹc ƫiqc(ܡܶ_;4j<64v*2x U=71_KP }L8q8>҆11.f= $L-rKTѤJ,azڌɒq` LC p?-pҸRW9nPш6p%6-ǤHBMzz[%w_p|A[7Z޴;)n(iLW Jyz CwJ3i;?/ѾBi`8sg;FnDSG?Bx\P /DvYqm }{1;!MF6xRhǓ̎EtQr?yKUր'j%zIe!m1"_43ӧ3zj?O؛ep8A2^8i4 Qaò JE+̺  T57݈l!bbdK' *|qjh3ƽ\Ca؛h/3li@$ }iԸگ"Zu Aay\Viɠ'@u=p.\Ɵ|`b;t8(/eqR>7-ER"wR5/$PոI>QTtM' Kg CZ#+h4-4KjjWZ!ܶӂ҂ГעTBTF@ 1"7,OdX;v:X$/әbSzFB7!8aPAMS <.ڈR{e/|1Ŕc#XƝ/~:"]׾ץ!gyyc3׸þ+FH4 k[i/1o)Mw`o>op3G&Y}Q) \- "g;Y;a+N֓nUld=,EdmACϚ8kCS\(i(LS>Dzo8Mtwl󢳘`tAe< iALTlW`3,0fJ < ?S^о>48gJȷr%=oSh&wBC)} pӉw]r8kW%Kc$VEki @wtJ38;)lf %tc&? GJ=X 'c*vea~ nt^T٨DTg?C],"ߥQ? 5j RYN5%'Ɖ0qlh4a3_ 2ε:HuZeZIʫ(2SַY Kj pH4Շ&9SIIz>,+._^\?1|P ^ۓ@]ѻ5bY^7DϨL|zJĮ$2?O/i!>G@qEhpufQtXld8-oie`â2F$،x@]d TdAgI^ݿ: @-3N_P"ٺwfWK~$s]蓅'?hrN2QP\]J  fd?zJڿUNy<`?oOoّ`uZFQРPl9eWaS藱jT@y3p)\1$\n eb(Sx&|n>EnMqӘ vV6fWeG˪O ݂RD܏t=W˴%.pQ,恥:m& zLR;{.^ RQdŖ** YU-=K(TE'9椗"&zy}ATOcc6C=<%U]5Q|vuiՙ[M^ җ:RY3vf7C*d*keJ${_q1WCgk44o;W+os~źhy\Ga}U$\j7J  Z+{~btyHƥ58[9/m_D<&#/e]xkaz@g+0@#^;K)y$g wy^ן8kt87@eyn%Z>…OBuau2,Q13Zm\O!4~tAIKy}=?A y.uqLRpsM/ ػw̯E}'46_ǩN?94}1G% a@)ɔi=]?Qq¯(nbWͼqZ~8i,pŰIpRSШzSIn۴K \PX6{۪SuS.ހ/ ${DDU_s[,rM/ӬXJ2-w9t-ƀs@HSXvYlp@_(ի˻)IAө%"ޢ}Fv}Iѧ!ԓs%4ڨ\"rk _M6i숳q0'^a̿WOݕE>W%O0TEpjR7$`6Γ9(F-|-o~rfZtC 5 {Kt? is(ײ/Np`b@rjuVJAr4۳u:=qi>q;ɋ{ʱz<,X7WecP!Xśkݙg;וh|ow XIUχ838k%DNMYUSB$zQa0 !auDh 烿endstream endobj 109 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7233 >> stream xYTTWܫ"5^,Qػ%6`AЫ 3z@`@C*[Q&hԘhd33[ﭫ.Y{څD;7L vAI`)ˮ |x T ME"ihS`Pt0vM2aܸiC<==¶{xmzyEێ=,,h}ddXб!FFm]e0Pfmk:XӿNAa!CE9ϓ::^0tQػ#DzDm[<{JX]F̱h91cǍu0qSN>E VPCtj(ACQkZjBQ먑zjr\)'j FͧR=G-SR j"D-&S˩)35b(?eKufRTOJJͦ^To RoR,Տޢ)?5(.A բRJQOQa.~#]w--,>$hWf+mds#ϒh=[M5KzQgpNEo6~ޚkzM6?/݀Woox7ǻ7mm pjD[شeVāR!߅;Xm ^bB *e'?gZSxX#$I%(l6@'+ԷȒMK ZY/-pJh0P'ByA,Bi,<=}`$xOMdT?HD )})'ōǕDXB>Rn'0@-Md%T> Ô,kh?ZzHNE0E#m ^')x#%ƚHxϟ"-Mش,M_1oڕws_gǂKj6sq+hli6A c%<1ZH {:9LeDjQ.FudrN۟[*8MRJ-%)xP=^ %HxYԷo )T4G#r {<~lFߌӟ$w#ϖ051Xm P[oқKlglt9T]ָ7vH޺\Y- V3gc$FW>~kUX҉ NFn>( q,s3U<ėpɤDQ8FCk1ʔKQEgT'1nn'>?-1IX'9jPeriR!V$tյA5['KR9Kp?!Ijo Q%Q?֖Ky(I+z;ʂӏvL1;Ec 7  uEx J' D{bt[aNŞ&R%L,T,- @fk 76= ]L0 @:yt})uqIӦv(oؓe-.r,:H5_ͥ'gC0)#Iɍ0x03n;xԜ'l\&Bm RK[3#hUW /ԉ>ѯ3hń:c,,z|#_s`r pFoB hN4\f X4ȀeQLa'={{?|-$ZJ9P@l0mXmȻ P4Цїe89߬ L<[:)yT㲿[E@d@󫡋Wh^DO24ƃ8 a9 nI8F*3*J4, <h+$5p+76@*k[hsp㡿$G{/N5PDeBXbsKO'LXlMH$\η]QHj2z2vlr Z@6dK BBAt;4¿0hzӎ`æ.+sNp2h`*w a}PXT~U]j (DMӹOwPYQ4=.ՐaSzr@6~'ٱƼ Ԃّz-/$;2mtvW@cy1@fbFJ>&CS 5Y?M]E.CFvf>c/:}C*v&!~Hov߷}ϖ"w`-sY"UTVB,_HY30>{xb:GhMuDO}Ɵ _CMܒ㎭n k4A@f )b%Z}ˡ{g+8^M"t5GX,I0IJLM^:z\ȶ,MY9~cUP7j%Ҳh٠<S-z~S{/H.;Jҍ!/}Rܴs0hˑJY\L\^BIN,fzq\@Bǿhz$>!6ZJƪ;Yx5z|wVq\a8C DkeyIZCiVi^󝌝+ʠj܇aaѰ-&"ƈx*(sYĕs6.D]Ww"sI?BK^K=):iGts [C9|OjɊ Acbu{D-ܺ8v)`>-ςDT|4h'l)mi{3c X"%PZs xMKq?$L3b(tUAQueU3󹩄v#p{yw ] 4G:WOkKn(+}[8ut:hɍ( >wFX{']O>Wz80s͟ey7nk*#qr`[L,+]]es<}I8'˙A{y[d|&ęw!I;IDm640"<(Gd'BMt<,M4\5~DbU_FMbƬҌ8Ϳ5yV4~1Q_Bq}i V$%dyEs_ )g-)| h+u ĠyWeiӜܸ l"25,2pӻz:Q?,|Py}UgxC1rRʂZ‡!JP)+OGQ1"l$De\#VDgOPY)C f%v!42UٰSxୀm305J(3 \(w D4g4ph!Q2p8FX,15^>7፫B6d*!`p7d!^yGT~?QZ_ZVYPwlpwWLH3AxPV6W+ L'iو}^W22 3j/ ^ᾙOSCz:1PnSTr_g.`خ?jA46ՐRTI2䌘$ϥ_PwR!$yH_bnU|T(Fhێ ][S1ZvӇH#BvGUTk3/ oǎ-xߣf eYx9(7o_iD97Z1 w}onT`gj2rvlopڎN7P _gw’($JnQ{|PzXtvRj0'9 wYk8RfC+bɅ FJW b:h_E_*V?M'( yru"x#~rY/>Wы>F;eh&.Q$JIZM&0K+Μ$qAOH1FL =5Q$ N{`8>~ۼK$꯾ET/V.=D!Z0JSA#ӐQ~HEӂQE6NH]`hpWFy]U}c5=뒋ŵ{BSM'jfX(V>O2qGbsjAdwZHQ8G)s4v/mpaXvi(}!FN-Fo Wq|#^[Ԥiį ݨŰIA L2qMzzAWrrbJ<zKFQfVWU5q[|(3=$0h_ͷdOGOt$FT Cu_iAiw7>gQАa[xqTbqcqlYk/ٌjÎف2—ep*IT%; W[ =8i+J|4Jd(1n Wj'P8=AYe%xeg snˠAxt0<JDl 6]%b_4:"Fl[LJsޔGrWǧ.82/{px6>׳ 2.\v~۪u,9*?8̙~ddzw?}܅ZsJ< ^TZY8mE躌.KlȂF> stream xW TSW!$H;ڨ[7TN]RKY&[WÒ| (&D%JN騭ZN=N3/s7g:sΜ9$9ɽ-_$#HX5 ^'IWR {[e(GW^h~)/D<2l˖-m/Ulp@* s<2؃, .!.b5..[U.#?~0.6 +? :aEmT% >f &Lc13-fyYfd3bfla Xf3Bb dvvuAd)2Rw$AM$ɠ̋˅8 3q,/p/5+M6O)o5C;0u.K Hʝ2& JQP"Ob[{+xUG;9YqHd/@>Tuƛpg{bzYɓuėMtRtI ' d<`.%DZ<1m 2pԝ6J VDV.ሂw[pW5nAEr]EYjʹ+ ?_ӽ~58Cd>Ng٨COd * )\ص6J+y(ۀcTd1Jc@A$;-8$Nh<84ķ qg?'?g ?k27>p%uoAg{;ϛL$=|7+˻%8 '2ZNS2;pYqCsaz`f|Uj&y`TFYC\VI?BG~BN0bŧfh SL]=NJmZH|w3$4Kگcu8F\”ldyڜ ɫ@OZrSah|GzCpȋ&w߇Jp+E(S|>Rxsɛ%}5Ԡ`]7'q#%(kՒiǘ$NW4 >*~߬Yy;_N[g/{U؍aoµ:DUN8(nU<Ɨ]oU y|_!dg^x\ r\] ^ZD{k' NʼnRݵi&Cَ%6[7)WfgŌNb~.N{B? fً@mc0=Sk9'뒧JZaj=)s"[vB 9D W:8?ˣN}s=:H`(̀d>=&ܰp} t9z^R SJji?va vu6Yʷ p&.lAwzrgiq Ogju ]C^':X?X &?xb#\GJj7`Nh|z_w-$@di;d&_I2c1q!S /2uXUD"K$Ci_ȋ>R.\+.8h9mӄoTQhh{^P}mykX9V@v>/-[ڴQGwLKBQVz8vsNpXCWkӆ۬Fn!?Tb ̬$pZOԶ 2u#W+o'iV\v+;RQ'-Xh*?\aˡE9pVRIz"_ZŠ!)!1@YX 96\~]ot9eaz;c.PÍsƽ{w/x Ovo!71R+P&KtT< WKct\ݗbE16&zL} 5|UOY[XkYRWr!lhs> stream xW TS>1䨈=p.ũRmU+8"ڋ 2BB !˜!0TEŪZXԶZtw @j[o\ :'{߷ Q@ {m[p3n(BVqyYNh+f"ҍG@ ŨBg/XŹ _*:L,uVQda e EK)J8|sݕpw߰0yB^2}Sptt?^xE}lo\JļURW8E|281d*tMa&Yٗijfb 1J 3 ?b;x'牝īG% ׈"›x!Ob#;1 1@1bB3J3 R|w epr_|, "XQo7cg9-re.x\z9Wz|ް}BNݦ^NarZUnfȑc0Pv ^}(<џ=-4IyO'9h=D?vмJ ,TԘa-*DXN;1^~}MB_{30Cʥ{{XV/nݫ+alHlnk|pHh掸"%`7v*Pw@}-sEܖU&Scdܯ?qϐ%egCAlYx*h'BhwAW?[TCUu*|GmfA}+YҖBfAR'+f=c{hӱMCR[Mk6eu 2ZnƠR:&1D^_(;ȶZofR/"'&2B"%;]  eptȹ|cO*~1' DBF\)UQ:udrH<&hd/U 0(䗚P;^]$[nz-? %ӗ,ZVȳu7}o1) u0@@%okF~XG헋Ř$=y]@56ژUWhBÓvC.P[ڏ;0H;HFh+`#n?fI4u(¡]F( \®"yp 9‡ZQ#&{I t+u-_"t57"S߯em#\" _fVCA˕Ջ!iWA}̭0t&чj]W ho>:~}s&rs&`[ zM u/x}IG*ډ!9ӯ' |y^Am(DК8_[PXXʚR;G{MYm /j24֦tlSHYICD kV// ;MF«e~Zm&x׀ٍH?owwm\f 9oNMTC U20y:.ҴmWɠ,F0Ҭ25:CVyZ OM">$*6'@+wHǗ E60'<6v@G{hXTGCiIo ~/J_dcazv4?,/)TyvU|Vf+2 X->n⻮!`;_GB'?z=^>ኬ MIvn<HL,u6TFqRCGk7cml<¨zO#ym<G" @"!ziF֎f\Bߞ J JK2$hҳ6ffBjr2 /T:Oҽz <_’R(k zgeu1t5_+EKʮU*m֮@-M\l&//9/yjHunOPI;Iwg -$TWpf m@At-v_~NpӧcB<l'$Yx }v_ȓ{ -HxIrsY]rM.Ԛ#'/b:F0Kʄ1ްVAH eOR9R/D'N0.1"~ >jhoCQ8Ovrڙ@5Ec U%bXfJ> stream x>CMR8$vz-  ]VQmqCopyright (c) 1997, 2009 American Mathematical Society (), with Reserved Font Name CMR8.CMR8Computer Modern123OEpbcVs,jŦf,hjዸ⋴ #h,t`‹ ' <02ZYΤ<7#B? rGlwYx?{FvťbڽQ"DfVT@htkpozc,MI%ڧϋ1# :Q?f{ku؎׃$Ena}{mltNx~}vCoa  7 כ )Cendstream endobj 113 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 594 >> stream xGCMR7$w,  ]VQmqCopyright (c) 1997, 2009 American Mathematical Society (), with Reserved Font Name CMR7.CMR7Computer Modern123QN͋oKL0bg͋§j~'eg #e'͋JiuP~>}L讧Ǻɋ !74/XWϡ=:4MFkgo0w!¨oU CfQc3asloozb-N K֋06U;ixwlЖu4a}]qljeoYr}wCna  7 ڛ "endstream endobj 114 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 4177 >> stream xW TS׺>1sBou^rwp|o'Z]a-FQ@v9OoY' !6Bpvn+|QB &!;6.E=<"cFL xyz7g2|{HPڠ,(| .ML0"11ﾛ4;H0;VxG|4cElLǺ Þlw,N({ c('_JzGRPrpJHj:iXxvMQѲ~3fnޤgʇNm6S3)_j9ZFm/Omr]jZE>ާSk:S)'j!5ZLPc) 5J&RTZlTp0!"Wsy;8pdg1.bn'cc{UOn]EV,Vn &Q> VqtЧujW)^:ul?~rCC?X2"k72 ]ˈJ)JhZ|bqZi1 n[Bkdx vOFјG؏ CaAڠN?c脃p@a4B8lV(bCN}-h-7 \@&yOsH 81r}>ᘦU һ邴WA=}X$;HAP@ %ЍzsyY4DZ'0jIFG88??A| }~b(Klءm::նlvK5m4~}jx擲 5Meэ2_ȸ zX}Ʉ ١uk:ed@khQ: ~6{H[%$ UE^;#BQC"4 L>cL"+4Z?qk1ɏS ;(ƼilY~dN]&rR$؝N@W]s0o pӇ㲦2IdshqP1O3Z]hTh :`ʡF򈮂"e29u Ns| ˆ҄עX Vdi,jS_ (~4{/Råsi&UK2MPւY(Z6]5"P/%ڔ'Fvq&C{`?y]V;; b*PUFE7l|Kiz^">h< m+yq\{<^s''N>e\eP`@Kopfs'37/NV.m9 w9 $ƚ!{2:Q'B|KDHlM^O;fU9n9 -}4!ZYWGifrˡw痐 [=Th/t>j)oU ]p6ޘB@9vxLZ5ߢIČDmJMIfTV<{2gy息6|P.Bn].?ߗHpAiO_=} -(hYBԉئ{̖OelgBU]Qv p"TT쮵?֤ u|umg016,Z34Bn+9PƖo:ݽXYFhNhI{Jg$F7i7C.QT# 1tb*cXtKg螉j0Ċ?LH"N_~i):*YLC hK+;N,C_'57B0iFnKh'njI2V߶*H}ZVH?bF _J,z'z Xy%|";s;p8ZGHJ{"Ь!{nfF*S)v_ HU[Pɘ+2gN# FZjv۾[DxVb1,}|Y> VdW'5k[ұ)<?495)iiV0bh>i :(6oM]j+#|pH;Dk(b$"n N("gFDUh\v`xhONLPI:euIv5){O_G1mͶ=ޜY,~0X>dpA4aDLmW4'R&ۮBwſ4حe6X4Q{lvM&G7*<$3C5tMghޑ9fKUtAWY=E쁢'DH/ty~q%02Zft#c[yYTMyR'Jp5z0<|r̻Ӱ;YF.d.7[ڥ"ͅBeG<+9cFr8g!zȑ ȩR2A$V&7Vֵ.w 7 JgnE׭/ Zv/?H>f߇6W$e{:'QrɮBB>쭪Rs…ki򽒶}mDyJbR˳*KjVe5& +V,0JM;$)).Z֧FBprANO]o8mHQB6*̦ [+?^9͟l)e-hUoR=yN\P}Fcܮ ,??A|-cm_wH)G5kOHAZW!?ʷghE\|1`24ӧ ip;e?;k [Y<޲"x7GF!UЈO9חpB}oKvzdEZ]iZe;hD|Wm ,06*Mك !$J -m&h yDO!M.$Zԥ t5B {Iu4žRW *"9}؇Q|`pZH4Btt>wڔnHL5h6@XVBbQ.)>{[gt:bm.c%JȄ]9x vq&/ VhZE&_ѭkw{V}dEǗ7e9+lgN8_VYjAF^T,b!j& UD*DmZ7r/V loϑÚSÓ2vTy o.췒2ۀgrs.NVכ9/1rz3Z3BtD/*ܢ@Z-CckMsWbg<* ~Jk<` E߶FidngلףJ<45)3NyO89 *?o!W14 6q&|)@NBTlg;iۿLS вBF,+,.![GK?JE ˳TvWFf!{ Ao\P?ZFPg 0 MƄƺFY:". ҄P1k|EN5u#.y2A)tެ?sn07z%D-ƣ~YzϗuR17K!>@"۶]-w )EPl_9"& 㪯"$#gjc2[_s$4\s}vy)VsT?*]bJ "\F[.99x:6vvP<!endstream endobj 115 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 5644 >> stream xX |֟t P(4 mgx M[(ZJ龧i4I-']J˾EʒJ OETDo҅O;srYϽƊ¥3gNV+X{f v`g4mmNX )K#@ɸ)>9o;S͚1c8P_qw8woIo_[+ @"?}T*5-\㤁q||1ǭ[;Ϻi}FDK|wX\"}Ѯ1RoٮUrݫ} 1t;6}b,츹'u"A'>$ku$b=1 ׈&b3B,%$ˈirb:xE 7b%CW!!b(F,"b;@Ob$E8ք 1%H…O ZzClHyhf9L"lfSAAK7d됃vNvφ2쀽}pjxv#8:)!:(zwzW _ xGY##wNjWC 䋇T ̄DB롂f)5آ9d[)B%3YQM%i{ԜhPrѴmٻ)2xQύ[̇YB*ļz(e./ &KybP^h9):f鳥2X[+`{RNI>|d# (~T 8oDuFkhĴ 6"+dȁmo?+n3/vayXl@ j ޅ;h>/^8{%om{_d$CGZBG#߶yCYѣR?9ܣ&ͻ4Q o7e"wկCm3q*߽oѱ8xP)АZ(gѻdY4W\ny.n<6~~BW/=뜣q; tue,ǒ{ Z> b zP4rE>bVb#BIDk!lN- dzH<&Kp7h=G1$F.2 iPmṛWWyV O*%L%w 2}?XGki4|cQy#ۣ 24s7sn@ :iI4G',b8@շ4F i'(,ШtUJ&w%?}bE;?8/hELZezQ$P  n*(W3g3< g$+z`ZT 4ۀFTjkk7XCAx=dZJnuW.ً?u@͜0FW c F$; Tۜ @2>xaQCD v 9dyt "%|^,3찞| -[$^DB8P :p(k3]\ (t|4@b!)@Anm3 ̤K,r:mNK~$GyBNAkuiN5&ljÃrc+ <HLc9ȝOY gBWjJ_͛(w➜dms", )jmjjmv e^1zeQLth'ژrXOH}׾_@SI:DbhAa OyeҢ'ƃ$m[S4/[1~c{2bBdrs #o!TEb4ImwjoO$VPVWxcxⱳwbX FdtwNktRH<1gjkŠj}:ha{T~g!"¢WGn\wO&8J4?4G%=K1'tUR䋲 e4/iHQGcЮc9q  Y&\9w+=8z؉b{9@oMWͅI'$<sYNS'|!7KgHuUІȕ?Qx=dӉoL'gRa1,>R_Ko\< gK\*5(VݳFOOI/ݪ)_z.q4I 'NKKh% 2_B 'Ξ?zGo\嵉@dK:zpX=+-Qk"jR )n5oHؚUTe*"L$(CGC@ އgH4YחmS<@-'! YZȆB ɋ,hiѲupZsr~3pA5ytYTiw4pBcD#.ĝ_x3ə '~tG ,9W}A[Vwk`_*ZSRYZ T,M_½!E8m:|`:0hKߜS;n!m@3{|ptͶkgKILVeCW ^GAm~kopЪPbPk?io~n b3bːT7Jt>^uqmqj14|<)ze裫ãëj=x'#^8g/yX Y; ⳕy^R# [#B#+![:M̞O#{$mY੶YGb8|lC~~}'^Շ%0nQi34ЈiiF31&!eR?Ǐ=@D?s<{1;@i]6daDەϾ}'mVv!Q(e[+^眝Z"EN= Pmũl'bn"$9P.L}gBQC'Քƺ1X% ۭ? G4~jA]q Dw!TmSyi kn J򡊪+2T }RA q )+TOU5U<D:t"EE%Jl{>P֩MۣMw휇5{Տgl>*? ,zҥm gd|wW0O/%1eJ$h1բ>@Q_ #th;򊣈C9}">=1CRJY[Gʰ$4طQWγ]GEF+^ uty3|fVRLNNX*06W+f~uuiR6h%")7>?ktn 5E57:{. .pS9t^ TVHSq +RYXmu^YpʈChz"rVf2꟱#B6hWwΧsC4ݯxIt4[h5|˱ nv, [ )P+[$@JSBk ,$@B3a%RNş$́LPqȣp]^u]%0| v\nӦYj||;gS,S-L+:i?̟!4s|g3L\rj4ZzNJNMR zЇ5Y8ȋuWs M 'Tj*i%IyL瀺َ˷uxY ñMW7ȪtNL>nA) >"Y)B3?JƊ{kj =Ze'յ}9iR'Qjlw} y>0C#ݣ;G%b![mEPJk40#infz3TG33ץ+(SS0ɟNvU3|dӀiŒheGki#k&.ٹ}p=u}ɹr˕劄Դ&4B䟾cJ`L7MPWδ Ѱ_A7t'6P9v RoY7(~Bn}q.dzC@`|*n"p( &Ђf]pN> stream x=io$u߉@`٪0a'Xb>̒]ʼ!?>.Wv `Uջ*a0/}q{ͷ\nOO'[p0Øt_z3~s\D"l6YW8BL;qWIlǘ溘?{ ǁЅkR t{ Ƿܒuߔ/g@TXF-YG2e|?R%pEI f Xxwm`5/p?j /Ӧ=yI#vvդqyc}$wV[pF.] A 3lbP.JA"#?n(ЁSmX4_G 'Q7bf I3i@lH]ٙi3cbGo`4LAp.-ӿYRK頊c_"8u7˯pߕߙ8".?o ʮ4Bd܇zj` Z/Dт-0l zo5 . V)4:q@ z KEfY<8h%MX*q1.*⬻Xħ Wo#ypӓXK>sANq$©˯UaGlFNL+c{*+>B>yZ(}BskFp>: S42 S&epqu )a*I݄J $ 8ez)& ‘6zu6|OY[ aߪ] (GayJU'.'LCȐ̂/)dLXr&@l˕U*LW_q#Pp,vQBdpf,Y+QE@y)r* eyb:")7%V0BTPۖ=紃-=S$Wc#(&T75r(@/Q#_'4w稷w?^6lNjZЩbvTP 2a  A꣤m3|VpōG٬Scxq-]7KHx6&DEwƈ[u+cU]-$2nتhv>>Xd("G _P~7ExXoû5Mst=/Lx>BUvգ^°h}Q2n8v?IuXEeH`a`<Y|.}/S)NO/ycݫ(DBѼo9"d!gA?s %lmcI 5C)<C.Y]y3R Ah;{Awq]'*L9~Ɓh+bSQLvl3|$&S !P:LGpgg^d*lƃKd޿.2\|JVؒ< "$PFFc5q=y ^A#Tϴg5 ƬJp@ |t(a, Š?Q S15mU~ßUcq!pj6O\U1հĎHIa*Uedu>Sf-vNFu "&;~trԞCr„Օv*嗜vnSq:JY}{cHj!U%Yaq.M@q5~b\q4VVymWgl7ϋ`%P)~nu! }_]b,˿%fN=B45ɗ3C-o BJts|["X4 FiBk(K_@a*fߟغo\26r)W 4 zFIsDp ׾>>sCa?EI .z80pRi|܎x@ [@m¥m)œO-Q<"~2NUPv`\o+0 8c1*cd 6Un98>:: Fre!UfuJyxCku,pvR\UY 򿞆j5+ޓG.hX)>"+p0$xU]|LcGH2QbtƘ&C9{_|RvAV3^MRUIj ^(GV 暊eG}π35_܎>h)~}x ]Pҁ/)suz6ncM%J(ؓY &vQ{ϱAcQԘ8HxsvƷ=F-9kA.Sy}[넦 -m1n*I .e--Bkc(4M*pIMHnAiܭײuI(b^:ɟJ/j^ZKIMp;Vt|=/o 1GMˣeaD@ǒ [ +:{v" }M Oz#󻏋rl/c/T20c\ZÓ>5vSܖ~8.%B,8r`SXP5%KV{[[M4a<㷵{ Av8й2 >nHݜ_BB{4Ml,u:/>:<~Yhur'ƞpGMRy CPɥlB:W4wa{C/LA7)Nb ERINGǴ .?Ni5sF-Ub"4v(0'@>PNAƚϟtѬN1rê`7@"8:h4A/ߙ$zȊ#kDQ`FN'N9ruO]] S--;.$Gg=8_8Mxf[:kc4޴Tyoki暬YJ+*vj%R+)٣[J?K?f9<h 4mɂ rWS(8:ýMH(6l>UjZ܈:5XU:CX.YVbwH'Si$Օ;f݋JC|}ipR$8bs{WonNGIjzJGc:^?Ŭ&ὠ%{l6~BsmpZ)K!&SD2a0r/i8N6JO;L^xRRd&lsع5m'.L}CT\]^U mvSӘ2O"lRݑ NJ|~`2$a3&Mm9 |K1w6/an'U`mkmu >3"v%c°pa$.lMxR,+&JU)|SK/!+OL67 U/\L8z0S>F K+epKlOkJ=0 Nw9׶&*T *Y@ .^H%y:,4 ={SUl{|P qh4gG(|Go D&J&qBb#"_B&"lUgAݑ1#d$&_M8,10 dȾRv-q?yF) q 3p,Xs4] JSEDA}x'}$0;:+OiތayF.枌 C(A1z>TRZyTNvR`0TQ%n3~!wOZd1Pc֜RJYwOYv`i@P:krHx§z,[eW1Q)l$i<[<ÏHq4hk0QI"J7r"JԬx YqTbs4|!ލֵ{t=ˋvʳW]endstream endobj 117 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1044 >> stream xmL[u聾N1v{g„1fb&q(S*q+R.ܶ@K)/QJ)X 2tPlピe1qLM,8cbd·sNrr4 I*,-85gH1#A/!DH@t*CKC-(:!!I`/tFgrVR*Lg5 >40RF&z?rD\)=w(T|=smb-l-SiyB2r{!5)jY kR(k ABT)(&J8 !%^"!hBe¦$[8KEQ!ۆDAa%q N<7RtQ؂9Y%cI#s^.ZICcˋ+U98.O6[w1k[LT:CS f]wxԈeBVz6pNvϮK` =8Z-:?080=Y!oICXIv9 W}0q?ٷ>44$ﷄj>Zf}\*itC[ y=doY7(.J䚯8Rߗ%W Mn N^{X>,/ *4Ћy ,7Z;6j'՟_OFK)myq]񀇚LOjӁa$~@%O:1 FeM=zn`Zr߃3j˰I; wEe_}v#\x &&~<ɬݎ$淓Vޢ;-Vm-B9loQoD$K.puK8 7 )gGO|1jTجO8|MݘՇ妪y0R'֠А뒩m,V&RToTii߰TJv礡`Ԯb\Lώhr,NԝQoj*Au/T{endstream endobj 118 0 obj << /Filter /FlateDecode /Length 5324 >> stream x]YǑ~ؿؗYyzkË]ÖrƜ 5wD^yUpXGd_ec_ws{pv~9]v_8_bw,~wN/Lz/ƻ-O7ǫ[ cҙdvqL^yς1.<6SLg |N_[cIs'Jw;xlǻ&.h#XE) ^ty~ӎ;$ yiMw<߷ƱJ]vfʼU TE94عv:Мz]ۙ.V}!>{tS\TQωҴqZyG;A c Hy?"]BEi;p(|'ڏd(a0R1sB Ȗ]eB٦ GՔ\ދuz1aWs4:Zj.+ kP^|+ kgI:N&ܜ#HnE2QqnD8G .<3y[m쏮{%GPJ|CB%0 4 _ .;4 tzyȝJ+G]G8ΩJ(\><7H[e0#Tz&%vki?Dޙ&02J}huc߁**Ib߰v l K3PAfϫ6 eSFJ{ЇdnLوu]#񉔷l-2B"#]#EtZwF㮌vP$=*Œh Q^S0G-ь [0palZЁojGNu\N1lA+Sߍʠy|% P|63F7 @ ݵ H&2);ACqxmJ0(BT3c+2! ;'ߴkn_,w^&[ZPF &Og<I&}O*@M2rN`ז>=-g@d 53- _ܜ &¹7/k݃ba4^ &m\t&]K$k.6VHH3Iq^؞35Tכ*_ͥ ?>Vc,mATgM\pL1)4ddG>@# Fb`"b`qOJrF`37 tv, a{$ibW|Ÿp]8Q,jt,\;3Lu$T +]w9YGDuI&9<ϩRkDtF5ۏ89DS|BTƥ<C ټXIn~^z1~^U" C nnj>|5G4 "bMkrѫJvӅo0SY7H_;@xJJ# 뮋6J8w8Bb:sA־n 87łȐ:b$Ы.vf8ƾ#gFC)f/|.)\*nޗM yLUMc MY>Ěsd],*V|uн|zw8./ѳ4_d%0(BW /~&VM`i/f71W F\ְ9A&rR kcwYlYIBkۧ8A3ؚ@6AmP 6kŏZ./$}Վ7A|#{a#ַlI̵"?!Vj[%w*㺍1.r_-ʔ,pqXM` Э{`QhLjaLIB颬f?~tсZ f@x-;YlúHZlPr6_`VWa35 V>bBx_!5:T~5$JjcxVEwwyME`[C odlgH<1^|NC#EOƂc/T˒~t]_Udܝ L5L3r$.IKXRYt7'o"{uE)>KMYP.`l0)s1t/@-ZB7+18N縜6vJMzݹ/ɺR>Of ;v.K D̕>Rbý5|"`ZS]&-[؁+ V7,O·]iC֑`R׳̛ߺG"G`$5F*d<[I [3,ޙ`Vѥߨ 9y&m?NѓN@)ς}ےU݉v̺0iLWzIhMst6wDËa2Ǒޒ>gsP4|b,nDw'h1sPraFйP_ém^` hOdto8C) Q{nxZl5*?r.R'nueוgY9CWZ; gl~=Ж`R|jn7E>2X&T*+ۂ)W>'r64QT$,>GgHqk*2bpʙQ¯=KjMNE[k@bU?+^ߋ3r&sL C2jru-O eD,#K#X Q2bg2wPXJ<&|S׵Cʉd* c;eE]on/ 5mN&9^HF?'̙} n  UD9& I<*^ G05f}<5J٧+ "S$ 9_gӺj4:_ )&zMx^IW.3u$R5X@Q4]YnS>ryb+AC\@W>ѕ^H<Օ'TQ>}m clW2T/sxfW{hw.lm1So_P+HCxd C^Ӯ"va,͙KIm:EAШKa-Ng5lgǺWo+GkJ򸇈Qn!>QhK[×shkۖ=Cz^zsn [qIkT/FjJƄ_D ryzNO/r=Ȉ61Ω>Wjg0E" mO1E85tLHQSMi05ufN$_0r<|"^X° 3<'Wg֎e vSs{+h Uf'jf#[IotE#><-[;pkrp2'`s_4X! tj>(~I?`2s)s6pOvS1ngA^Ț:( l ٿ&fendstream endobj 119 0 obj << /Filter /FlateDecode /Length 3872 >> stream x[KsR p*9$U~(,r!uMJ<l\6׻3=3{~ֵl?r{+&f7g_gr;36)9xw榲Vm' ѳe# Ƹjk/Vci>:%>n,٘_bP-7}Zg8u]M׬UjmׁR7ă[6ӿ18B]tvesyMs gh6h5}MvG σ1H7}/ovHJF`Jpjݜ-\Fqxy:;/% NH{2U"_/Q3"XwFCeuq5ml骫}70[ `= W_JTns*F§޵(&6WO!j"=&cT|~7OZ\"tcZj٧U]iKAU /zr;oRxx6Ou[VV)%[οhOqX.m?N HZ[vJDכ U[va/b:Jֳ2knT?bkCzѳgZa.![6- F8g R_V6;9UJ(.PguJ =So^[]GIL AĊޒI-ia1FƟ>LVьVHcwW_OSvLZU L*@&Q/0u9)T0P<3T!Qa n#x9jhlIԓSH7jl7]?yskk)4s1KC!2Z.pKcni^Lm0o<3rf+wUqK o> ZsU$ȥ:fh@;..5jv5jwjZ [(7JPrVS'J\|]>+fR$m/wE9uY+қT{n~}bwL$&pg7mDeJuCn2_FwZ+Z;p fō"|¼Ÿ3<+~1V6b˼g|p}jvj G{/Uخ"CRąϺ78=9ޙP>8kWw& Q["ea"fLJjM1XtA!$(E,q 8dنN=Gp59뇫3܀ nsd\nWWw0l$IGe3 n͞a,Wv02@ Cp]_5?lq d ^GH8jcEɷKoIo vMUF?\]5O݇|}86|Ao$&{6\Ou*}gT+ ʛj~ʫnk~ Z Z},]wO# 7a+Xׇ;>U)BB s׉endstream endobj 120 0 obj << /Filter /FlateDecode /Length 1658 >> stream xXmo6_!-F#ŒCt@3ӴDHrb#ߑEґ]D${ˣ`b937ijc=,Z㏬~ 7bݵ)b%;^L0X Myq㯑UT*vi%{(A0&FE/J<+iޕVMem4쇶+*Y??8[lMM6mK!*l &<4ltǛ\+0y$ݠLw;)1WZ"1q\%Vch 'K B{6OЕ0pzlZE) BD$:ЮѩW*M;(2Әi~V}OT,m⇎(ʮվnPLyX *&%][6ى#kCU=~)aЕ]zX hߧQxF)8L>Kk\{ǃ}xAto4k]ۗ,j$yrYBAmD1s8[G&{?Lb9$ (F`w/$V1hi2G]bj/ZQPNˇ:u狻 DsT&wﴪR!vw a'::[iI'H.'OYt&']+ٶܲyb} Y!N  JCFMW}l Ab5>G 3MZkљ 4(ȇ3_?O%&|Dv & @\QaRzf+1!=]*_jy}9Շ^P'kK`tٻ B2Q=,mpqg:!c?sט@y 063cn}A@K\"VcǟO<~&[ eF Auရ-Y8ai,V&4}a!!pƎ1juAWfO3Db.0Gu9Pc_Bl/p =lsiQ^پc֑%"c5̻)Gfi!^]fBKG<98=Ѕ<2Vؠ(9٠0d|'>-A 8endstream endobj 121 0 obj << /Filter /FlateDecode /Length 4342 >> stream x[Ko a{6QbHbDRK2 =U~r SޞzW7 W'rquW'Nu] gWTF,.O«|auϤA~Prqv{S'OWYg<%B2V۝.%5g[oɘ4f3o2x`R%<?9mG ؉nX#xJw0.yǁt-]wOv&W8] -S åSE"n9?k XxGgߝr.a` kp9)+w.TNu 2!̳Ltw۞LX2ƅ Ϟ -ݏĿMoA.x# H6ۖR S8r³2ŠU9p8B\ou"a3/!;L~!5bf2]fxEQ 3g%@SJH2QǠЊ[<0LdyY 4:н!*F\MXT1ffsy+Z&qE|@I<4BهUgU*{"-z+}l(u hxIWf+6v&|RĂ9B%R跗:gv:͌Uҷ!hժi*HPixf図OB4OR s"G|:+Y.bVIVN.@H|, x_r-a!w20)LDy^6D(d4 B KQ /EB[x _Mvp7qÛ<7@!A:h9 -m k<I mW?JzѪEUWBpKVNk z8>:ݴAɚ9H^ѐʱp> @i fs.IU{DAT<%):*CB$ 6p":FN+kYI$ڥ&@&Y@zt4PK'CVOi ;/Kޏ-aKBTVH$LWZ(KeUR,Y;+`G~^,~*8! c;Ioܕ W|'}=DkN S ؚ_$(SeŠ"jIk!(jc8G<[ἡQnOۺ8"̃`Aۢyh^eR X;*E _Y@*Pfh`4M &0j>Q,d;x⾊;2L5fA|w^f3Sgϭ$DTdǮO\RP1PԂSgZ:*L*a9VhE7&eM0y[,X"]֦r'Lwdp%R!L̝졩tWj |\9ѡEv!G똠!ۚ\vjPT D/- ewe*2 oNxi $6ߔH3}"SReEsi36r( ó*cب+}j,i;kC-CF:։0ԣL^TTgf0oz|2Du>ע[U+ 8Ce mZ%QFQըߕWX hMZbRz2u[֙(e|c<1&W_(-o>9xAq#N/O0"qXЭ)9kYbV<HQ=I0K9jpݬUc͝oDW>)h]ņø^6M &z9 Ag[iՙw|=4B~ʰL7H9 0v3=$id-c>te7wrsD35\cpUikkq̅kZ-S<-w[7Cո=ҪWdANa?ʧʈ^qD757 x z8Hk3Yڵԑ@cSLg_,C!K5.nx=,*ջwB;DlG@L\㞎[ިh*34nJ*7xRrgh_~;t=Z(Z1Л;t|ɵ=02|2-$&3!4a"iߞm3- Xf_mZfĠA"4F.I$ٖ2цF t>m=ZEhT򾞅W{̺l%r+tx)Ջ!q5=F)wX޳(@P%(?QaB )Uo0!+KL5l]d쭍tc q8@GӷV-[dqI~tX",|!((U3b; #S{r`FLiNq$؇tQi}MZ=%/ftJrȃz`cXedplr)ߘ:;]sp9|;& Wf>u] zicr\ƭ K FrKiX )!݉R1P ţZO1+bs%actK[9qpG-Fv5yr?|j!ZU^.,"(N`8qkR"ЀrmpZpꋖ_(4g6aU񬻜Ԃ$kWOZZ.Ӎ2"WԂto*9"AF2BSgzt;|*B85Ǔϫﴙ_o@E׍5r'(ӗYd!ie7naD:W a_7_O:PRGck 1bbޥWרshTg>B&qDMݞzV""~VGWO颐\Jñ @:@Db!/Yks=K}݀^3a߯77h9Zdś^N8#j5jKRn;azV77eٝwO~~ax.F:V^cc?Y _)n׫i wMlp&ތFM}}Jgo*EȐ~9h0z/!-_/L7 PQhrįz~~\mS|4jٯ :c$p࿐6[h3 F~1Rendstream endobj 122 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2074 >> stream xU Pgfp$:jXрQk Q"^KT@,\ef.Aay30 7  PV j KyxȮq]ZgkՐMm֫z]x$D$) \;I~?[8"pu>>+J.^#]QҀML^A(L&\$NIIP$z)1k/5@YL,+5#2y~JEBF(ex +Չeʃ6b;DDEl &bXNw3L FI?SuB4ֹeBxSxpN>Dу"~:'VE~ *|>̐QQM&i׷9jGg/_xs([7>L[/-CmH4믘Ĥ>^HD>Mep삨V1uoYб~.uSl. qmܖ* }۳~D]wQl|I:UbmNUyc_|u9 bLW' m-oPeA/놰οWI6EGE"RRc2 &SFo7;f4EرEr2PVՐ1tDNqӘJ0k֚L),KMEVT5%QZ2YE{-8|C%\3Ͽ/gayVS%PPͺ9s(saDE;!,3 T?YcvsWQP+-Ԋ|t`] O~D79lpNY٬ FWK\'pܢ>@9pH47]![2ė +԰Wr:oxS,?`P s,bY R>lv3#O,~_H9K'}WY1ICZ&)5MTP[x ?s5q{m7ey1%!s,j"O}"~urꍆ\,;0syq=#GwjOg%AkK=@Rc̺ {61{F͇/Rk؈r]*wVjle{Nt:r}^Ɠ .ȱE]~c|ץ7=? ȑ+Bl\J|ˆ uɱ&l%h~ +|Uv:t~9o/ε8OS:,@a~"D?vCm@w=i]W DML2n skLA;g+ݯs>,m "*]0#;MYOĺ2F7vJzYe3'ٻA{zg_m_Z&R%gL\=u'ȫ 49LIkdr*V5a7 h7[N$l8A *q ac${RkR67eAy3Ps4Tl΃k#ְB1O{>:zQBkcc JIoq20Vc#KQ%QzAل!îgTojdĔhHgY]n#@TT[DsY0(tW+ZZnwtaYC` [`^eݚ|avtF_,z *f7@+ᎯFfW5pu5&"cĹ5Bamګ~Ż<* ;BK"aJI;},vh%%^*mݪ4x@0kHa\;JuFpH}mW/q)cjL^@m3]u%⭥KNi@gv{6#h2!ߊ2'P/WCɉ a^JP`νe1p"$C8Ƃ^ )H3)c "T[^u3JwRN| U{)Dv=rFyqQ1pF0/bp8 3mFγiyDnq lqkA\w)HwgarLPpɤO0+#LzN٤PuGQs6U?j<_e}C7tgkSMr*;K2F?0BBfK<` ]ksSׅ t**Rv ܲM^p/i0g|x}70K mAr qq/DŽ]"`ʯ {.HNָ 1{A>/r ND<: ~+H MA%A:;yg k|אB N6> >(f`$6I7*X0*p4*3} ]L<^Vt_eۄިhT3+U8wS&bf/zξ2'~ke![VB i֟2@;D!Kt1hJHF-gYis;$<1*ߘ@u#N lj}P+;cmK4_R皰񻛯+ I<%]Ȳܷ,D O+PF$ʎbbidfjb@9F_ ^N‹rtwC;;sM22NKO`^F"ȿ4>:mlMȎs\osgx\yCq$*SZ&iBwZKwYj }S/0j`h O qs v]-`$HT#2VTNv;-Ua +>g)KEd%yL UslN\Dk[+ƿ]ݫ-amକotBh_ߵUz$PQOѓ_fB>ϝ,ggc6Lst&3\! 6,-pG\bP Ɣcc 7D IQ^C2vMItź~*ڈsn"LUede3m;ŏovYpYj8_=}L4^P.5ASK,?:RXŇqv`XKXmF /zf¬y6!MxD<}٨ RIgohuS9LIJC5p1$ A;xSQVk2Jc>bPG@[ >=wl#? }6=Y5m.wo=սv$t1'p؄e/xq`ŻX0/z/nJK#Jf-V#bzwƣC[UhZT,Âߝ"$eW׼A|MM<ZuX׫-@7%t/mײP@vrb'.[a .]7/n !*ʍFEi&$isZwWy*+AK-}5a?bDWH cYCgI`Q@vh-rc6NY㦜v^Zh..?8 ΉĔn:.wzrWk^?ǁWRuU5rUWOJAMw i]O3? endstream endobj 124 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 4493 >> stream xX TSW1bզ=nm][m֭. (!,IX'/BV[ }UjnS;nsǙ37Ng:p!c7vyTy?N < <6&74 0>4=)ՉH=m{xlrD.MKIE73bޢE?1Ef&I%J&e&$d=(3f e\`9|J+0nJ/z"~٥\87;7#n$Fq ::ZƴAw^lr~=Y\hz,wE4 99~q?1XN04:jKւR91dĻ}|ZYƽ2ȹ.h9HXѻ)֌8ea+Fm9X}P'RCΔ4@0yA(wIR[xh,ueUu:9R:ç_W>:dGu4nbnr8(D>P?oh >r -ʃpCFPio4zm4F  PڈRQK.V:l7NF1 i:nK1O Y[TGͼyPhuXҥ&0\*ML VX=ۨ9C)Či)@k)k-+^GR* >D.g-E:l D s@!rBI)WSuh%Aȭ5Uw3U0ui/ Uנ`8|JPMJj y %s*U eŻ&Ss{%gU84 j%WXT#gu[=Y _+#T)}ȗW~ .5InL0{Rz,] G X/]ZPzAbxGxRp=wwZwL0*{WYvt_:.,uTV d=ˍIPQ,uF(&cH}E!OWTpS[ڷ>۩pt kc~ 3| L~,th~YЃWԕI5XMy ?!Crא EC|s( j̨ TQF̵X{ VPz$?"z0CdyPb@/㖫(7!9u_._IxɞsӸzMQlJ9< dې%UH/Dr޹۽=-;9/WKez*T1ن;/E~@$,vC1.[[&O%e6 JXU|vG}U1UB 7Uz/}lR7E-7J@biaP?1m }`[^I>jhm(7X'7k(};vHOCާ͠ iܣV&A)Y]R͖4Y "w@( tk;c?ZUh)=Nj]ޛ@U 1;މN);?#MzwQ\j\z|JN*H@\C}kz٬R[/'?wo;68d=[@@l9.YG:n LVrwߙ9p5Yb ~ý*V`2Amkf+?6{&|?eb;60'.7 tMagYL RW(  K5+p~kd?f1p:[PZ(a6SƩc)f$ Ш l6pϟaQYIcq[-I/M]6ѦKa%dh# &'wmxr+\/l+}k4[썮ngqUEp/B:NaWwkщKttz yGQrͬhڽc.; HkzSL*+Q0YI۰#ܴ9'6yNs2"AwYJIʛݸrKMBś,=քB+C}X[ h~ #s 6ЌSYTh[(lhW 3ʺ41ஜ׽茟p?Cw!''^)]#&B!]%YMIiXMK4}ā*X[ũLgMSf,%{E©7Q^dEvKɋrh<4yI>6VJq665o]U=Eۅl( ;_Mx)*tTϡC8U7$03ZbϨi[v%R1sr-ޡ)MgF^x(YF^hK[6CUz`br:cU4Mi?Ѽ:$W'ՠ{m))gl3w&vSC%ZW4npq\DN*q%%R9 _S5h< (ψN5f3PAHƻa`w,]Q;<5?bǙq9'Oީh f!wa㊳`Wcm5GCkCyo(NH#kAcWѧ?aaS\%WT4K3s]> stream xb^ݟGO=w'?4su N$}*'3iaNoOgb1hvgF?|v.w7g:I:Sn B:!tpF_ɅX~H!,Og:F. %℁ v&;|18!}?56f_ه|)$c1_G0dTzŘ*v,/_*k;X)P@οP4ӌ w؏ 8>z=8^j q\\)\%5N LB&O 3pš(\Ĺ[A9a9"5DRC)2q󰔃?%\Mt]RE~8şN.obܮ3Dj<>緉d"-ԸIiR xi]&$ %|WTQkV;\H []盄 oLR>}'-5A$5IIGetY`kǤt9]~!ĘT+pBd{;,pC*!$ I;~|i]I2;O,(x6Š*~ IwY`A$4YhmCL/i}^26Lq4o "\qqňL&R>I!OPIVy=kî@܌##AEpt!K*y' !PB/vyW֢ zRRNfehzmՀ8gJL/|YW+ll)Q.$#LYQ?sCɴu` AB% H+UhwԤO6ĥKUf~N',%YPon!C!CP %ɰU=)6gK>yi?{+s` ]kO{ n ֵ C;ѫpG(_ep6~lא7~C{xtp|#pgg+.9X8"ɲuTeoid+yLcW&G>^Edג3(zf,˖(YX5 嵚ZH ]46qpp,rKd@FqI#-)>͆°F??p׎ EA/=[ Hv#ȷ֍fk+ja>>'4B(_ 9w؉7;`6*ѽY8$l}ah 1.!)1/- 1"bgiz-LށzHJX JF)S?&_`Xe ]h~e{0 Cx 9]Bt6|.e#T=#KV1_$e%?JyJ+D6mSj\N%MZG058ѥK48*exsB,AZ ZęY=~f-|!K 9)Ӹ[/-}" &LH-<7V| ׯ#=^҇>jh1H[e̬)GP̊PdeOk懂邬J&JN9̠:3ɞ5Y h6O:QnKѧh~z[R&Ag)M:- }Ɠ([vX8e(ޭɐ'@q'qKC A٣ZzD>p9()ΰTvD-Ut $ ʒh[wqhWWJN!HN^n<^cY*N17xTFB܂޹ $^QOy!@}>LE"#Lī|L@>%UD>*y5P/Oֻ) <oYY/ el6;sa|텁-̓Igs'I7ކK+i^gpCE sk}6‘[pd#a'p^C2 5;L${ 9^G5NW.xSAcp-?, _bp뉴C.a${!P>VT0r> Ȭ ́e8Js6õz+CA{S^5J4"k2(֗CH, 4C뇺HE{JuUZf~;zPX,sTL0YYQL(MeKC[` 蔄KZZ5R|BP'+QEcqvl -ةI}R2 caun=Sn)#KyR2.5WNtu %w+yGڨSP 9S* e%F?h)hP]. onh(iS C<0rg^.&OQQՕpndʀeOr!7n @0sS.3^2T1&\{o g)`9& <ؙF)={(&kv%&)H$k$d[j.8UEoE[?,%=Dzo](ٹy4E8sFzau,tG]ņE>˰wiqHeR%!b fJ㛧gaבWL֓X^4AM~aL¿xʛM&ӱytnn|S~{32)s55lU;cOoFQ ݈%BozxB޽< $%y țգ:ӉN=:KvZ?mľ!ܗ84[9X n-gF*;M)V'kBʁ@oy ,<r(ц7"H7 In<16Kp+ ~-\}A1L1jQMZE6UK&y4(.2BI$|S<;Pe':ٵ:aIf-!KR~DpmP_q`*XiiݸdvN菉\4*"=wFOrS+oL~6p'RQg;fs~XǿITBbpk5/[@},Vai4ba$kmCp%g_/ioCRQ(dIp`^pWiCg(u&_ՑZ O(̓;꓁|ˆ?~Lҷ%NUP䙃>'i1Bb,݇7wW=5F.p.ёd>b/bLxIH&=j̳h;Yk2YlF*pºbG־c$X)a+{vAia@,HFsv%NhGzw!5#(.NG]^'t@22XYOg=|=M7.)0*ubV\|i3mne:Ho`'3ǘ *aB~bϜ[m 9e[a+2k=fT'iXԦ؝O;__)0b6Wmi Mw+8 2 ri,6CH4.4,Lr@7!JFʟO:endstream endobj 126 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 278 >> stream xcd`ab`dddw 441U~H3a!#Gk7s7BcG``fd/mq/,L(QHT04Q020TpM-LNSM,HM,rr3SK*4l2JJ s4u3K2RSRSJsS nӃP%E )Ey % L,?:~t^|?ę|fH7# _<&WB7smbK<y$]}endstream endobj 127 0 obj << /Type /XRef /Length 124 /Filter /FlateDecode /DecodeParms << /Columns 5 /Predictor 12 >> /W [ 1 3 1 ] /Info 3 0 R /Root 2 0 R /Size 128 /ID [<9c3c937bacaf19e3c2c89b2d04f26cc8><8e83fa87989553dbcc78a2898c55f624>] >> stream xcb&F~0 $8J@g}f_ ÷gFÐГ8d iMX DZ R&H5 RLH 3ɒ"E@$)$9JAl)I )D20 endstream endobj startxref 84896 %%EOF plotmo/inst/doc/plotmo-notes.pdf0000644000176200001440000322375214055554046016467 0ustar liggesusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 4549 /Filter /FlateDecode /N 76 /First 633 >> stream x6l$,g Yl.@6+X+R`6d+-XLA<{eX qJ>`e!#jPFp:".>VTkt}h1x}nDrAԺ}UWPXBzw_o!G_SOd>&%ZKl~ů9._~o-2Ĵ"@IW/w%̫|Օ5/ c-(xmW?5W\ L%" j mDz`cA9-pA7ŀg^N('+r H=3pj63؈PӇg0iCfezU0 Ŭn$5|S`[6X1xo?z>; 6fkMУŜ挬bȔ),rzQ- 0̅ C[6qp]> |l<-/n΋ŲbݒqozyLq]0q̻#cǼϼ=v3o7]V''pO{ULU9[첾Cu[Oj$ +ޣ] [?cM:ԣ>j{BFݜ>:8>"#>$)CanZ:)er7 "wG)lx3V&@{>$_&}5 O>82ǹِBg%)ߎ{ 8yc0?F>{2y!6x5#᧶C'/zM, b{jk7֑:C/mN胪(W~K'YFH>b\GOk_~L*z1~uX/#1}B=KlN|YWt!g?!$M5N1促SQ 8I eCoٗz⻳ټP g*2.;Knَ?6`JߥmZ -Jo oXgX x޳{4^< fk|,8--uIA0kf>Y@1`ri-<[".i =i"׈4얡FizzvDx'T*$Z T2c]UNIBo(S."1O@b}^_5.ƕK!K@4F㢭f><u若W"1A ,6KT[cB lSb<~0i'Q;>"%^g>i ʮ DeF߬ H# ݛ t:Y(=a? dLZ7eĿ9l-"]]a#fi&ԥ.tmﵖDV֒D]X:M,lLd`"`^+x+[ZKdC#N:PT@E:P:B DpBuRͩTd#+2Yu>ٕ:AR:#4TJsu-ɺFT#sQ+*Q ǥ4L:!:?hy_.KK%HH$$I(k,ɣI$%yvLI<$OO.dub9%8)I NJpRd'#8eMҹ%gY-9+) P9whcqـ(t?m&1Y[_a+:dن&-hKV0j]Aܪ6#9ǫQ{/0蚕7^y5p廙PI4[y7Xڌ]y?vu`6-&mH=䐄[h)f}#gmaӟG!E}#gbiJ-l<.vV`A;:Mc 50DW M{d6꿥|xUVuwmN@[*uKk[%x:9V_+`mRǯiM|캪noߒ<Wb>x^lQ,w@Alve˯$4Mug@&x|f1;ʯk5I zl*A5K.LN=}E u7\7dՕJ\u'h Kt0X4Ec4_{ 𑛖^ H}N9r:GrTw> LߕP9W| *C ii=PJ߲׆Ժ+n (.*~s7>-fYk &=P=w>Z]oG%{/_{b^ 7kh:>4PkLbnM2EM(/s>w"OF|:2aꮼ(H~ j>4 e3lh:V?4AYLH7_BY\0bY5;Nwql2ל1=́}H>hni"WDcSrjG2Z{_t#3;?Z#M[4cd\m&t E&gm,v xW|r#k䋭ˆfX/YL?u&Ge%v0dJG k!/8 88&Т?c/띯t6"d&ک$/HO}J 8~5 heBR:!A \{| -),~?Úﭛho5<ēx0|:I1VyI1xçBOԶG鉆^>8@H^~WϖNv?G'Mendstream endobj 78 0 obj << /Subtype /XML /Type /Metadata /Length 1615 >> stream GPL Ghostscript 9.19 2021-06-01T17:00:18-07:00 2021-06-01T17:00:18-07:00 LaTeX with hyperref package Plotting model surfaces with plotmoStephen Milborrowplotmo endstream endobj 79 0 obj << /Type /ObjStm /Length 2793 /Filter /FlateDecode /N 76 /First 665 >> stream xZrF}߯ǤRu+*[UَKNu"! k r^4H٠Mɩ-̜>(dQ1-YX4Ģe)|}>_ه)&j6./'մ(ϙxUʺX=8*usx-@ ,yS-pxu}#ZxULI3X#}n>uη;r?ԶL `{l6}ztcljUz=!a65//[|wH'wS1jVb*rq&Ņ(L\RT*s1srY4x/<u%q->?omqah׃2"l/YmY ϳN;nY1yTr!u jxlYx݉f'PV$={.؝("]S-P$s{S4ki8 %nVؔؽ ܌ާ `M6 w&זryǡzLqrc:ȑz#V+sfHBH SHҜR݆:bclHFP(t H]۹gLAin1Eα7"% ؜gP>6b7Wn*`3R5/x^7` ^s?N.^? ;2 '#( -Qc͓DŽCsM NKr _8o{0#G%H`F&42?{gTh3V3PwluLw98ke͢hib Fe߮}'VQ@T'++:Pgώe&^nE*LMӨ$xAyv鳼oؓi7tDH tNߒƧhrRA0g**=!AQ[+};]<;;<SF6 9D "76eq+8!@D(d T CR!%Oj T ٽԶ d7#B2@@? AT[=cU.MP6 6vF=MŀI6s5J3ţFC~$9VB(ԎJD7F7P16<;2(؆pUPdWڳ*%Y t 3,+<[L.լ)>dzM9E~5;糢wHuBg8T{m}` =M> stream xZn}Wcbݥ`b32Yb<%BRcsnsSD蒚V ͮ:usnG8Ҍcu\H.V;˙qW]㟢' 3DL0Uœp/ 6d"8fBp?G8('d{*;NjDž1s6v'jv6ǨXD@$,I\ǫS*$!1WvLUu1]9`b bԊS.f `B&;K" .-uIp]%8KVqdȡl2d .&LP(c\.@XEM@P dEٞ*`TW \ [XD 3DSc_60%)QL!), 1 >dţ2@oqobwƮ+.n JHq˻k9]mdQW%3_{Mt|&_-ƽ|H9O2{"#,. MSG@5R0\JW눠qN$'XPx3CxAup6떛wE˫ٷ.of+ u7]|v?npmSj7U7X؞&o Lٻ)UȻqvb|܉qSvRvȋ|q q{%#a.شBW > uTo#(9FP!GY=HQTAMkĤ"p+$c(l9BH=4;iQYl03s")U@0"?&e@Y`DT|FI, lau8~SQ1iωU2ϖA WCyA![O{yPO5hs|+}-PVoXKBb){żcą4a[nϛo'>뷝V&|6?e.?G '."L+L$z^xNݫ =( `@N:ᡒ@AH(@G٨t }fP\Mƒmh>iB %p.J*/V刨%2jqB %N&؆8I(_ ^TC,NBF*e'ܷ5dI4F,ު(q'n5`羚~_X=߭fuZ( "RPk!7dE:T'_*^d2s>LѺҥQAPP kP@1J1TrZkW6Wr Rh"/ْAd&}[w ^/*5#.4C Z -*m u҃20? rBb2(u"9xRxTH&% :mn<܂5Q($뎲#p)X@09*n #"7V*aOJ>-Zjsv[/VkWs\leV1bU(*5T<>3ޓZDNfR{Hг2HJ^9@5\ }m5\],p(4qL =r+Lq骥Kp|Mm5P4 oo"0u4mԋV?K]/K4%zPZET6nlv1'9}Q}% ^ʓzO(cZj$>Sx.ãTxھ9Ǩ7SA\0d9lG?ۻ^]\h RI,CS!2Mv=Q[DHelKze"Y0 H3j *47%*0h Qrd{Ӕ@٩f%z75{Lfi0ņe}<)z"Pw_c{d,G7MF&i4ن ǝmAkW ҜwuSh_22{E~0WLRSq XTkq(#'oY[@1𿨜gendstream endobj 233 0 obj << /Type /ObjStm /Length 2128 /Filter /FlateDecode /N 76 /First 675 >> stream xZ]oF}_1 睙8M76mVfl2i${PJr(jR3wΜz]ĕI \FAIhqJ$9Vm 6x 9XAY7X8anW,- i\ IVExa$ a=ᣰOI0+)ᔎIxYFZJiK歕r^Se?}jLܮ&iid̞9 prVs=xue^9d8A?7EsN88X\$KZj32RA:@) c I@\k{\bEp:WPV\2 ^Q-#SH{`#"Rw>o7Q$#='f04M#KZ 7~=AѠn033T5>g}VhM v8)Re1Q7sN% w*\;TX_wM@hr𳰌] D1JbNwME1j:@ІWnJ.4r4C+̛+Q|t}uuǏ6Mq=[T&Z9,Sn668½yZ˾WdD  5܌ϓGƎQŵrP[蝓u} !:BK gr][3B}Ԩ>ڇaqr_ug|0 X^z N yG1 /l@\ 0L;%tr׹FCQ(jŭFY|Jl {xqmaOH uqLB[q^l*dCIXUxk.gռjfRq՞ݕ/ՇN{vfyx7;&Z(rYd,a`OLBNӰ]ptY[VSF7ŧ4tdƒ ɴ_\u A_soҎ_ ;(`}5|ӂƚ2NYtrV=endstream endobj 310 0 obj << /Filter /FlateDecode /Length 15522 >> stream x}I4q~EU C@0f7l."Ah~{Il$Ad)(/[f9_?>ݿw_?nE^h|w⽕v+ߛK/_}v{sϿ?\XS:|~s~7{Q\).{BͅϿ~-~o_~&ŸHݾ|#~8bR⎟?ܛ.:?w3ҿ|9zZ?"Gj]~;?|~!" ?Ͽ~E -EW=ʊ!v䇏_nz> S[pVNi}[{,)\+|wUkcL߭w">q<"GЕR;[x>9TKb84^c;t<94vpz鴧@A&_D^w_H|KwtaKMJD?RO5>xKmw<8>ebx=[{H{o_}݉:I>[jA|y{~"t=,^B6!*{Uᷟn^c".4JEw!>t{Kʂb _E(dN K"dI%{_\lR`  !֓/n?q gb{^AzI?8d!,pjd'|r,)WC!Tc9}0c~rJh!"zW]b#jR]C|rZR6r@ ^;S\Xe Q:wM3<2Y6X-`3BQ; vED y^!D- L8M?Au ;DZp[P\ фE&$tYP+5 w&< hb`$IQ j'qNNOBAyy6DC2<vuw\0cD M.!3&,q6`s{,Q&JLVx(%XG1@+u\L 8Cc} _5gT9嵘Ҥ!֠m#g֒V[Tʒ hiaRQ{I>т=\qX!|7!aFu\5t~2;ɩٱbr@!e'9.O&3W ̌c9J_}̮J@xBȄC?6*$mbT4O`2ЬרG V="J\ Pv놨*R~tDɢq9ԣ'MI7xQYq`ɝΫi< 0-δis::nDK(; y 0{>C4:ZT1WH{?8Unhse;̴I] uT4 '_SI/ui?T-`PjmRCYNk\Mua6X]AC2Z屹+٢MMjLܝ-PPo~6z67Ձ&L3%6 HMAdosaݤAj¤{ζF4lA:&vqa]A;3@Q,/)UˤZ ; сer` grz s%qT$,&zv[u%A.(2j"6{7jB]yժ 5o$ꝳҁD7Dzg[N#E% ; Pm^80L㸰ZgW1f6ϱZ9όqax8Cⓐx'瀘/h'YT['ӕt:n'5v.:C>OG뉸z} ]v.+w/8Ď񀅝|$VIbu>A n`>Sp+ׄe2 O~d  /.bRS")/0mO"H+Ox~ޏI"<~~ 3'|BɗIϷoF> <: wqzYʰ%̄rvs:c.]oSU鞍LNp2%VUeU>;pၱ C-Fڲ{ּQ(F_jx 'mQ>4i1eUcC9o6=<c\)j/UQ%`6>%Fgۙ0 @ vvTY}15l!MvS23<c#Wũl|`7`7>z(#'JuLp@J ܡA]lvpџ35ra5O/=#Rh4>0V+~qB*,\hlR=6RzUb0[[fADX=$&F媆]mL8xSS&ғhɓj7A_M첳Kv#y%Σ/P3e4@ p *l| n| HcnMBp!f7> FEj3d5@06TdVC7%*٬8@ᤵsf Ë(IA9cI#=l7AsVZM|pf! Ȁvr@W/v cͺ(< Fl`Dlt Lid4B=9!XݳaX=uXޙ!*ڍ̍'0m8j AWXKo4CQp_.?۪??>f!٫A8 lvxv3#`6D{n EWEf& bAd\4#8n r;C/lk6DNYjӸ"/M4t!b8D0( pH}An P`6BBv# PᒻAAJ Mz%MdMi2AW$jvS o6A\F  tJ  `6A `6NO<6w0 ;6 $BL!dMąA1 ./ x41Ql5@ *2V p߭&Fe} Xj__AFXb0泌 UMdpk]l P&/=MLA]YZ {񁼉k93+²KfXl| cR }vKl7?P)C@99wz#9t40o''X0h7?}X Vp~  Ͱ @CfE6 EcALMoA&qd} :LAl9j  q(AmAǘi5@0#Ah@h0jz `XM>L`T IvͦV9Mdpx3g5<,BhBvxGx@+o2=%{MD"`7=7K*3,g 9fnx 䱬„CX၉͡@M2x(f.lx och5< 6o7=A X VA0[{2xT]c4c5=Xսk`7=4tWMzK6H{4ˬt: Y˨{7Oߝ+vn~ CAp9j D2&>l5A&vYjjTZ&LV#D#DL8;[Uf7%56!H+o5B1 j vb!}!`7C𙇷Cq}%&&!ءn O VS/rʩg)<{ Cu;c9`(vSq]4ZvSq/b0l6E\JM҆S_$>-9;EAI҉/vyr~ -M­f[dd/lG&y׍>'@;V Vir*hv sddPf!Zd7;L{hv fҢPLnBpxǸg/'S^2 0M|6 /db7>m@_8?^> z$">'>ɝP B}0*pCOBx2pC9 Q4# Bvs:83(m'3HxKxdTq)E9c:/:\$rc\rA/)I҉-U?lv~9 2s$R$J$+)1eF޿t:z1aHa,':q xNÓj#9VN[0? u濌t@C~yaJS Eo7=[dsppE"FeA'--GI: ">Mk:qcA){k{x &xjnE+?=M9A&lNZc*77?p@=1q:[RQLhZ9mMw5.\0#~iN`:~7]@F10q_ lE (<`MWP䄒1D6m<ꠜIv+ _=%"U:(_q?5) ]8.ɨ͠:wb1-PV? `ioK*Oo ϝȡcB3tPMNA J ]K\](+Cç[,z)?[erE9`uCviyX KW*qu0:}nb C)f\,pqa>@0y҅ti\#ȄN c\T KFKAv9j!@H_(Cq!8 ǎx!yL#Ir:0(z%T1 *-W2mHB7m܉& ]sfT!:y`GQ7BGQX 'IӒw 9Q%1q\F,[ǭm1 7QNDVÙbsAbEv2|:Ur KJ f-TrH#r`z|1.},6cx[Ke4Hg9Hh}w.JLa($d%%QU ̸ͥ}j^h' +gyZg%LMWDdY"Gn>bG >!I *{aL6FdymEHwOPK")Vٳ$\ɷp֣ e/4K8"$e*9=@z=^;Ho%ɢH ˡPCȾNVq0C/ T15bwН-{P̰gS򹓽x*X"~FES}xDo!hE ,yA/pΝSh'CO!ޣzK4Y5wZ5Zt8W5K;*;SMdS=\4RJ>iN4<&OF,}Q/W/;^yfx( ' HJuqdqWhNWd'_njh,#0_8I6O ~;=SUvPO E%PZ*\4`'+v^}y"ef"W' Iw / ]&..sRhFW֐2<7!s &nFwVޜ=\Յ M S9!|KPnd&TVi9t_w+w4QPnI h6p Wa!BʿN9WӇ&@6+N9CMu. |߆k#n=)N9WWnOG{n+X4x+w·k=5;M(_h>ިʜ"lԏaXsePO`ͤ;\٣2;+iM%QzTtxHWyv0y6]JSЕ39 'EͅXaY,DF ␥]=SS=;\Yb?xTgйRW0'wk~c ulzvTcMD4jL=;XYNSGsa3r3*=PEO渞NcŖ0!UVޫCU%jUO+0e"9XL:h;;PYq[:p9cMc30ee&W5"'CeJur wvr|;ep]FwM_pg*+OD-,^txW!w|m(xwȰ=\Y8Ot$^ͱPÒg*+ߞX dY,3`e)u1 PϭaLȳAjϐ:`_<;P Y] "vt8`V+L)Ci*v2F'MϠ'Xp[Dw]WP!U t􍩷 vAbLE Y.vJ{=+ {V9QV":r9,-k`SA:-V Kvb*<. {hn.LU:%h#3&JvH՛I80ybM"mI֥Sp hw fp*媒@3oBzVe抙@\J=QÞG"bW:!AxWEI/j q, \࢕WFQs` p8LE V5wro.ܬS}Fìo-Ʀ6k/!-'gi+mjRQ^&ܩJZHsŴ`\T> /F-4jpk+mk>)֋0clD?9&L*Qk(d8ixC#x\"x _ԧZt^-Rur%VCO,8q=Amj*n]/4bGKdݫ!3#VzQR׀h;ZdlƜ-"sE.bTxRO6s+ߟdž$7Q!ZK7aV3 k ø~`-lQ CK*qиWvŴ ^\뉒{ɇ~Ŵ `|׌6GvWEO|kVF iɁUr:wQ7!V:ΗdKch;ZevwG* Hrvh @񑆏e *3j*4'DWWDۡ*UjkܴxZhhZd Ub.۬. 5TM+Tf7qaLpUε~D9)1W5|g܁*T:!0, /7XɓaI_z*[<-wPjލ *$ `.BE=4Pp%=/wX2~_P6VvprKqT;i4P`8C]H i;Z~Ώ47"%jfj_ mW+AHG i;Z9Y.{ i;Z9}ϕ 8WP@tPCG_73#(;zW% ¡, v "J͎K qeëU ~@Wl0'L*SZ(s;%Dʶ+kwuc +]1mWD K4h O+z?u=gy{w 4g1kL`Uޤ"F5,;p.tK1}#*NZzR{Wb b&*P;-l UL*w0 0ps|h\pF |@x4).M*M`p\Ga8]TՋlS+*0V1CK? Y[]lU+yK72qcz³ V|˥(f<ۀ|B;-=q@%~h;ZM#PI$lBb:.R>#QmY`Q;_ꑷ~A:US ; \ItCcZ }B YZY0V +w8ӛ@\Ut p uUa@ *w8;F3g7"J&wY3x]lU 5ꚲ GBjYτf;ZgHw2 vXrLUcj\*x!V+07ѣN8hi;ZOLW]B292+j>$Dz&Y +b?!mXT-9AОDWT!*Vk>M »|P`*TNi r+WW=P`@V֫-eGr-U>AV޿K|kg vprM]vymZHuVƯ!ѲF-iZdIq fΠxFS@.'L*RgQNPDMMUDx [)#9CV/(BMj vh}O{&z?.`_lU ע[JtETl'U!*tu>.@\lV+BwTD6_FkF^|Sy༂ d jU_`g)+OVHHriƑ5S}\y3lX qĨ&ـ{  #0ڔNC\zטE![jk+le庺6g7ޜNPe3e>ކfC&tP^FN\i@_Ag(+cϗصr ,l?~?z`pPg) ە,vDkX4+3aOVH`0Dq4+de͇^9iyB,LhY%v>n^f% 6t Cʷǂ6(Yy3e3d blKVsIt.&Ƅ;m_pĵQ'f9Gvn|sgH(ĘW~hG]tkפ 6ھrFRcN3FzpSe^%E1}pSoJs$l4}eksu'0hw.:SBbB>NWk 5i~sG_e()"T}fG 4}:n)NWg#W;łl8fW'ZstXuEWKc2UQ~ł/|9Gͭ%r!Yew2]K&~ળ;\Ci\;09;\9x2D9I1i-?9Iv\ƫ)& UvzMi(ۭ eW6)FqV]F&N~}Tћenc}Lj\\j4+O& rM!&)gV pS/MS+oċjf˻zϣYvJ2]e'jV;Y9Cp 5NgVʝwGV„MLa&j2+\8*0Ï/IByt& 酋{ܼzr K&߉J:\̃~/bA"3 d6;̹] <tP\+TlǵQsPt{BOV$-,t{ATFcY7r=no/bXuWJ/)q~'+G9x'R)g'\n%[/%`K9.OpC1zpyXMC$;vTHN¹z\~0 $4I4W[Iw.Dtu";[Iwi\H qcϝ;gF8tP2 NVQ9wܡdt'+T$w^Qq|/se4R"z׮\,ly|wM7W :1h*B;X)k{dé%h'NY&u"c٬!YrvRRMܥ5{ErvR~عtBwx<;"c>Etv~kt#7qM w[>]c=EO ^~ܻ O,=sxǽI-6v1Uta%k+w[l\"// 1o6udj E8F w7[m9_ZO;ꌯqo7\ wcÎNٿ1HiYP0b!$`ˮ<ゕ]^ٰmg;Ѯ9{Î˷msrh..jXdbŽ'G$ADE\3vTX7Ve? tvcZ؅R*Bp[γUզ~ՎnYodkvX "\קuF$G{oڂ)2FqN߳뺅^zn$Ηp^pXW7wK&?~~nJzq 2|5@DǍݢ-V1t"߯?Vn_~?Tt쐯 Tm7:_~{?EJ럿ϱ??g~ר }> stream xX XTWmC+*WmwhTqWťAMAٷwhh$hDĨ1'DGüyI|w设T_udIF&:M[sLC.:$=zˡɱaV Ǽ#/l5~66'[mmmc=kKK0{pߝ6-44toT@'L ZfelݪxS~-ݽ'==Џay /mhtϲP+vػr_cZ/u>m?BSZO{wFΚ=]ɬfF1hf 3qd1f381 M"f YLelic,a3Ke f93yY39 x1=+ƌe0L_?3 bxf0 a,Kf(> ?cD3Odkd=&(5&)VLQɎ`Or9Wqϕ=9k}ӽzϿ}K3Ͼߓdotrk?Ob_LrbEHˢUby#0Q\^"EA0xmj$\JqPwCޣpLRpV~N,y ȑFS_an F C9p!*S6/2'Pп637Gx-ʈKp]8B6cgeG`ɥ đd I\qjCѬ0Ae,La9(rY}P󯷜xyI ǥ,fBpe+WT Fc^lQ:EŞsX>$o98zPbɂ_ב؉ѓmǀ c9PJ[|!4eMF,8)h6 Xƻ(BȄB56U1i쟃' EJ^iVdΆA4@̐𡇔2e~$Gq d4:(4ǏOv!5숻n4!ldKerF,2v6Zۃڇ ?xe~:6+RDnc+#OzftPxo ͚) . +qKV ⴀOXbbq^߀;FAYx8MXsqES(~Q.tISbbtϡPׅ "oq9q8#V+5|[YMb$Yæ`-55iv22t%e>|zaJ~HPW>#!Db#I.a"H@7piuM;N$'k,Œ}z g)RK2")Y"{-K!%-3 tęa"WOxy2‘%v  P FwMfl'rkB|aSsr'.*PʕZ(2Sfyov54?>Bm -s33K#HEëiT3'>Mx mhM&0.j|Tt:ސZЦg()[.*EejJ]Vݘj0[bct&uJ«{ wزUy?rTQ˶ڠJ-1ްv_J!2ƣr:7.u)pVS4*6߆ "? LύR)kqb_>-/5㢄2/uű"4AX-8џڡY/12d-$AD9P>A!^[]Fs b2&ڷiW^fr{9D% {w/F{jqI?Nh4j29929*-w Ҧ̒a?Lq8t^4E|)mRy/ ًFh4IaPMp*EVg?[RDRR5Z(Z+:^N)BH:=,RpPfWFņ@,ĆpoD>M"馰mUvcg+2,}/|(;&wUOy6Kl2MIFY~|#jbЫrg _"_}W*(O-%' $ {`^<(>r/ŕo~*0Gp._3蔳z02ٹJg•'ʃ`u+T!/#7zzL O}G4=5Cހd!^-8ЌOl 1-p/LȏDi 9XœgYx/N^w >-slSjʐdX;eہse_J.Qy Jߌ6WU>ߵ@%L`c7/7ʧv;bģ3S=20B<([uk1|=b/txǯ2(;ChڨҀj/tz)Gyq){5e&Xs#o@'=>g8$)s w8Z*&9]5n>^5^ 5YLQ<pNÇbw؋elgdGrLWKAj8-d^H MqFVɚXA9PD4F͟NdKWx(e=9Ґ*pT!s ƱqRB]^3s+*>z7RѬx{GDVAPF)ޒz9NJbL(˸-Rֽm3 ҧoo cv&9ti%t?deg^S:*pfh6<9.)! &5Uq&ElAN~ni!qOhP/rԴKIC(Dk$Dqv%ߔRfW;7by}Z N[x 䯀I>ę;.-3?T˟0a͇hbkE{DZ*BPwP'*܎dcQ᭞ !;bG F Da2v`?})^<=.%-b8^,E=.utgJz.{mq $q91iy?C/vvܾ{GGKUQ~FkP찰Dj93oI߷x-333ZH2M,֝i4 '`?kJgVy݉b EMTצqiNNr 1V !M%d%PLV^!Kp$Apr NćG_Ay@ɦ[L/Rpd1x+엺Vﭪ,=Zop~}ʎM")O1ylȐ^J ޵;vx{QP[oяxu}|2|sJɚ]PM6ҥc4;T'kA=ptb9ҦcS9]\9ڃs;>IyH%|Aoj +t!W@I p29v3xoxxoTzZ{fR1 >3Ge"jQTu:sQ"@ 헅ٙi@U@tz@鰙[ yBn@3<4pV|HnK&G[܋iDF,ϟr 7nk9>wD 6r({@Co֕?mkj.|Gaa1,{/pxǶ?q+hvڀ#z zJU<k*MZnww}mO;SK$ޣSػQlÝ],[.ol W6!i3=EF$+GAF3Lfy8wom0 >endstream endobj 312 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 5281 >> stream xX TS׺>1prPӂí^h3T uD!  a i0&!2Z`EuZk}>M};Iz뭷ZEFx`a$ٳ"bD+g:ćJBcq֊"%&L\DQ`hw8 U#E.Qkkc$q@wYGn`=x}6G,[>3fr=R/X%!7 /b1HxS bKl"6[ gb+B"Nvb 1XK!oy+1p#Bƒ$F0pb1XF"F+b 1G N&^#{OL$78 Godan+wfJ%+r/A6rH?F=k6o|>fɘ&=5nq?ۮ-?ohM3aӄ FwZ6*r &\ WJύ5rS8$ 3ahl;DF62G45ŀpZYÅdm ( {`jIJMj$e ٙ4~h>v?u-Y3XeAz29Kl;P_e XA4Hfzq_V͠@">vp3C ڎ._?zKX4c \wH]jDTeP2hĠu Co@[8[<91=!UqS rZypqߝ9kv-RU 6Cb="F>Gbq!Yu8P=|1~s_K;=cݺwW͘: ȕs0!2Rzѵ9,4ܟyW::kt,$G 6%? OBHl[tǕ?\tw<S0h3;%AC;2HZA~Z ;2 im5UyA8AMmWDOF0dq :Í4yݼ|h,TmEeMg@#|Lʦ5[il3$M*Dz=3Iط^$ /oe_a>f}Ͱz>:$ 8cb։JVYS7S/'4-8&,D (lQ<;Ebh@G9qf Ecu y^ã\&'~֌ZTxv>Nc-EܗȘ% M1#̓gՠFbl/}@-uC‡(HODA.Y ja`Zr'kfցJD>j> `3fNC=*"UW?@Bz\Z}%!圔m_jV&3{ Z!r[:ed&@ Ńo׃:0?"r /Wh1SDL1}GkRչ0MF[`mTURM~[15j]V] mC" 6fxoMp Q~C3#3E6:>'?u=O( I2aWkǹѬ2ۡ8ú2|Ssź?SN‘hf֡2$G{Ǽ(]YG`)Cjpp^FXZq%뚘 `4U H _u[8~ЂTLƸ"͐c7x75%`]n$@=Ȋ$R؞hA UX!'%H[wBP WB׍G7BHNgb}bSM87겲؂,u6HdTEip [_/9N LܮbgayVnjm< uh`hC_hW 5ڽQ]HԄ\YX?;ʨW4(n+!О4\9>֖T[,2)T(l`ka]FS32^{ܬBQ pD=3-sC5UlH9gvsvߒU.<Ć-f`~ phx(W2I<_kZٟ؉xK->t_l fԋA;͌~i6Y ;5@= LA}<}i]8 34 ۧp O|ېU.U)Txk,?OF{һ@0w+54`#NFB. uAHKu])p|.,i.nVyfx"uS1N`p.kWó|nEY&_LVាZ큳+Aʥ2{ϨoHQh~Hᭇ`%5 ǒ]E$j#͹"9o䏝k6{7Q8µ^3@gSZTirs 䶔Cҕ{6NSoVJ[_\#Bq^|`/+eF9FoO1]8Bf$ϝ:N?o]~&vt>U~-/uw:/A~y/w~'<{f8ix}| |=g4A+x ϢzZ@6]` nH³ꋇJc"bҔA(plWώOIiQja^۶=N{0^z/j8>^,g*4rwԇH ԴS(.K guz`Zrކ*X@e&Tfԋڴkәʈ13.uQفgNҮ㙹lP4wj$w"'\>NwtꩠFrbg깣FO܄˰u6sHvD@ c T8[&It =Nu3G5[+xq6D:qOǙZzs+NWlقMbI⊇#-e9_$Z&};+-:b=C^ Ls^l,>v.Wϻj)ܰwSH AIsݴe[$QBѷg=yr8b(`C,Ԧ_l,ΟYDpR?>5Z MŨcl ɴILV"; *-[T=( 7(خ PUZVUZ[ 4s|n-|F66!n8IB kZ>C36,La6>Xbs ^VA271BdqO Ίr*ATg_ h5ɥrY$Puz# E;FTr\TU@\쥕ݲn +J+k3ϺP*UZeQZ>+.m  \acXgL ian}lWFzo8Ƨ+~)hţ`x2&ɂ0M&S@6h @K&)3?3J +J=6Nuӡ^yh"rCO$ '81(Ovh/|iMwG6 Z BpAUZnޜbyMo ӿz.HUXSEiOArM0b5eU\tWPwn|צ,B>i:z9\b23, yXaVfU3=׮n޶Ez򅳷[qj޿ ĝ&. V 2APf[ SnPR5'C4 {r2JP:Y}4(1mpp9؅ۻ|`JC˦ƒH#alW%뢣pH0 >]Ya!Fs=G4EE/psWnYĪ3A&Fʑl`.)G` .)zΰ6_$+6VE 3:+%bJzf#ehV2R ?4 9K)|DFXpat/.l2˵K\%@aɌF ׏e5 endstream endobj 313 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2813 >> stream xUV TMi콑ж%q$^"E鮒nISI咑r+1R%RCdrj&)8uLf1wߧfY묽;{<>& QIc"DĆvOO!0th(^EH]lM(v!"I%SbcRd+fϙcsS3Kٺ9E&F'Ŗȸ )ޱ6'e2qaI_11%9eְmR÷GDD5653ͳOb9G""XI8A"p"V΄ aFAX^7qOL$4 DpdB )61%PC oHDf 5(jԲijWĿST*uBt:}]Lqw5ʘcr_x֘<͖v8ԭ^n9e~l_-{Jy-חv((>đ饅)Q;Y"Z%6NعWfA'X V4Ӟ{[o' M}ہ^{T7S%qG6&^ `JYS'!‹yAF=_/X澝0jkᶼ}yBp-AљYS͚fg @6cXCLWwƜhIr+k: f:#:unuPȁ``M5WlDpxm-"{unn(f&Dbp{OXdeO.РIz})IN$P:E#4S)pVlIJMAilf1;wYt]8~O҆4O{m;\z!󂣠>]SB0ELʑΣ sBL7-sT)V^䗩C*)D.^۷_Q$-t\H; /fIl_ct>X)ewS[5ei>K6n}?6O6!o[kH.e|YGTU!nSepHƫ@500RUN$)zqܺOxr'+D!9MRwuSӊ!nXYX3 Ex'E~zp K}ɂ?""<&+nT19Y&/U(f 4SF<jz{\.K G%Ru8yK>Xˌ3H,Ux( Cxh?k,r15vaM"5Âpx d+Ex23pkxUӦmRVgcoj^wwC}7vv&k.3]@/PKi<9a"y][p) c 7GyeiM Ls]]M,y[Z6 ()|i=_@u[}CSW}숰8z8/ endstream endobj 314 0 obj << /Filter /FlateDecode /Length 162 >> stream x]O0 PЅU 8QC$@g|wYvgA>E0u- -m1,O)x@fw5|֗:-NRP> stream x{PTeaUf`wahAG6eeGy,]"DD(ҡF#M[haw3HͤNۿ:;7sw| A4(lک%+EX( w xv,>YѮ I Rek%_])_(ߤRj0.QRMӷQxA;i|To=2yqAGQ[cizI *i6(k2\a'6ozJl~Y] F{:.nQ R:}zޘ4WClB:QpL,n86-upY& )9BSITbQB^{][L Cϵ\ jU8MqցQ%8e /Oay gXDsP>c6AG,%x6~ȵib7v%kJIp633p.l5bW Igy?u$^މ% _a9m鳲uz[ֱv1ŖzωDpdTl)KùЋ>u7pVx/|}qsEg8ltО7K y1[yc1E<)ñT*Xc9Bd)c55DY-p݈Գ1AiNgVc,yՈ6%QUV[A(όR[Z pl0W_C_r5{њڊ*qXVokw?Ѽa^oc@snuf?m|n8br(ӂ{0V;jvtL0nu #208Ŋ?@%4<6!&"7+R9^L2aL=D%rkXFk3B/>5vˆ@A/9ȳwPƸDX|li|CIiQ%=uёWfSeBkiʏ5JJx'FGR_;Be8t{3*UUuV);D9f3]3=<k=f?O7~endstream endobj 316 0 obj << /Filter /FlateDecode /Length 4132 >> stream x\Y~_G 8N&!AY *V䷧E!b_jjŸgGq^;W~9Uzc`Wb0zu&5èXF k !`[x\(17qYַf Cuz}~G i@SӴbpHJM[c QH~\,/h:lMlqqT{&>S zn1%mYc$;co:s$t?r&`V0[ypn>HV J+gv+K .*'FNq^1zVY==_9 | 3#R۾LF%W FMYA<-; k=x!UO#0vFEFc]-2\d-ȑ轖8i삎q4ᠮ..xǗ㗿7/RYrj+$H<$,W\&fw¬_!_ 䲩 oq ('AIi}^#r@5ph`L&e:tꕩYMu- :Sڂ?2.&l]GJKK ]|Xޢʛ|iv%|O M(@6zserS{MF%a8r}`Ƹtjzmc+0렬% -mE H3N_߫0_\qf`퉉9UX˚B[yȓ!LazNBYv͂ ;JP8Z(׫_;׺ohBI#awsU>6q:GcsS+b 39%w׋3kW#v6IVC" Ay1k2xf;SZ)L=Ͽ]Evac<{D&DQOA˕KL(MK0p`ƍ9/zx@3;]wO`XyBq2O#ml*9KZCff-ޓr#@M0ȸglsz~[|}E& hfy*vY[)7{RD6X0vz_z>0^J{~z>(OnI4PEd`z[30Us<ƾWquYE(}s`zLUm#QHh٭ʇ4F{=iҠ$@GzoqoK^FnM2VXت [ ZXTUU{ @%LP}Ӿ FQ_=_T a]WU$YสIDyH* |P Ge},, bMת\\DJ3LKJ_DB54e*Uݐ(=Ont$T:0#_yJzd mCc!0fVlfPN~@cF̻3a8:m\݊,I/׌;G%0[oAT X ɪ˗^8zk>#Ӄz7] #B-:r ߠ Y`1B+Z"t 0#yUHlDr ~?v='D剅ǵ|~idJЉ~8TfE%oiItx"S(eG;Bl}(㠦\5t%ѫ\Uy&|y:uUWBxV|K >|]2VZjEr}P]3Q=:Isr￴|;grV i1FLQCLVˈβ}Ww \SY .\孕TP6܋qsji* ~zD7NV-i,΋Y28%+$^,$7)GD9"%zڲg f QF7XrVXIYp %`3;MUK0;j y@HS  ̠} F*χ[>.&I:'][VTE:vQB0[AŪT C s;i4m  P ه5 j0R{jݬ.LXb2^~mD!~=NUŸٝ?9QNUoh{lj)E,ՉS*4 [ѦO_}\as"02Hu;bq}"XӌpЬ*/cĴ|{[b荲Tl/W'va _~Uڌ{&^env>傩jg)ƍo!m&ܤ量!>@},U7Q7W/"r sUȻ@+|(=sufWV1ｌDѺ]W1 s*+y=CaniLW\$ɗ h5+@W7IdsRYK7dyI#_NyZc+dZYO2%2&! 2EοcZ}_·U*?63la!  q4J܌""LBdfGӜ^rDv^q١ȟ+nw\QcWh^$UI!`SvHlǬHgxum_.RcҕH @0::Qshڿhb !W&5Jܮ[YXnvj]Mn2P48xZJ #^<y*ʑ#f <~!,( sw_Yja~R_oLC%yLۤta!}` 6rqJ؁~ pS -N?ȩS*Eku*K*ٝ CCh^B@$a q=vnX,ÙPQm1au5Xb~J@RW~28>:7ع |rZEVM|p?YWendstream endobj 317 0 obj << /Filter /FlateDecode /Length 2234 >> stream x[Yo7~#z0x* Z4E}hHlT_H}=fVKYWP].f!e̙WF/޻jNjї(o:pL ϣ{ø b`6t5x59LC(Q{=Q Uq2\WFw4˭,#{+ BQ_'G"NB0΍m&(.cp.:HWofմ4 e\* I+k.4d#LqR Z})8A5jA( 9ۡ"ZY֌U@Wٹ@g!3T ھ̀[㙵gVmE n'=;@e SMOŏUӺF\#BbAO9; _4R`@ܸ&}WG3lEVQVki>[m`3D ?L`^?i0zt=C} =R ϸugC1 %8"Ѓ%ވU=6r5ɥyye(=8N SˡQPQaY pO4iu|smXT12̱J$ sL(N-`\3XSJu'O- WLbƎv͜StU?Wݩ>O(wIl̋^"dl:P/;u陁i#b3)C>f"%sV5zۓ3J.*LL[%"9 b-Yu']4 RkU\ƪTkU/Qr2ſ/XSK:*cYa>|C-M !yv?W|V%2փE }"A"lLp4>s|3TOƈ٪} ҟ8](#X6ei8k]\d\.dSzgsڷ!B ' w:h3ԍ5KPx}g'!Lk `U\RzpT&ga|vs@-ƪ9lYRS*tg:Ȓ%3q ?8E;@w%S=Ղ6 ۍMɅEkRs>c-)|&&924n79(T~HE ^R`u[j;O3nG:rdJ}$7=$нEOu{MGSJ^ٜu"i\UOW+Dir=H'Jh XE^vv?J5̮vo#!ɓ܁JהIޭ;aĸ>>=L9@c(&J\Y=MQSu3Cu%D,t o"&8iF~ GAb>2~x]>IWIO:Ebx1&yLg֍e?zޒ~N0EhCd]P'0 #x^L{TNW4ek8N<վ7EISKfTJc*$kKk<'=zDãS H. tBu@PeXxז/%u} 2$5KDA338]<0NLemѻ ųLaMXP=O"e"[iR O<8CJ*:*-)BG.1viۉj/6z*]Vly;2y,MdLo)ӦxLUV-o]ty\.Uה6CujRt .g;|{w.o!bu +i$oKHgW˟[-_xZ:@5FBxΏb;GEO@%RCvӻR!Ndϓ2%PyVa]S0A4n :Zs0+=? ev"x6;]b5ŠΝL.wk$=GCσ qpkK>U| <@r<^KE(~T@wJ9gIST67endstream endobj 318 0 obj << /Filter /FlateDecode /Length 6776 >> stream x]IsGrc#^ExAvxjEҁX"Hjt8k=m'r'yٽ?7'HqKhwr+iy:b{y{ө9;Rٽ? z&'v}*O?wh EkLó؋Ɵޟϥ]<vi›֏濼wX vR C]|ؽKRӷip K8:!w}xXpdlfCΞޝ)«ӯ/xs rj-\O&)u-9dM6 yzoܳXkM| 'sk d=E[ᅰVV(yc'-.1,ӿ9C2/ ŃmL5Nv O08ˏZhh>iEO&m<8}$6"./<АB& yI[۽T>'[)}>v^`+GJ5/R ߃( h'>I ݒwRMޯy߶l9ф e K2V>+Dv੻vV]#ŷ+q$@k~U%YfN5.P@̽3q2 ~\ f$iG>No0 /qoѴ5%ۥ7n0[ _2॓&!@pֆR- );"R]dUU=ȉ NX,Ů.J? s>NJ'][q Xk2-N@6~${Pu񹵞.ʔJklS+X1M6 4|Η-]և t)ȼ,x[Z4/h3ȱZ Vہ, f%za9L>ݥ)y4`h41f6 ~2h%ps+msyUI2mJH?HOYo| f, w3jxfZ0wW_ܟ?ӧ3K{L8ZFs0y[#q3 U;:YnnJKQclk7+v]}`ڙ-$tE 7cn/KZ-h,Lص K<3̈j{@cHʲ_\ᒁ9Ljo3"L'"s#reg\?u@djCm^ji6CTLVmnZ'ڭX9 ydmeB5R&ItcuƂ(&5i;ngzYBRp< L|ԼZ0ݿ_GBˀálqD^k<-6ggtP7-ǽ!sfӞ6Fcz%0݊&ϫ:Z*ʽ|%+q7(糨\U#v6ɚ^d,`CO?c mޛcJXLA( \QI=UzFѰhNݭ&Pv^؃]%0KP<=}6A1*KhaqaTWQ&7$ƳZ?zrmZvxNlnB7IaPwߵXÆnq0l' *Oō(c~iaÀYX<&K5L,7 0*^:Y˸{lbA ̏căre~Ȋ+v!ip}(i{e!4N`^K?Ѻe` 2AXZh߮`7 j'j-j]F@ pe ˃:Hmw8E^ NahX`;Eۿrٮ2N#4o/a~eķdk3~ :|RQC/qh t yG所6dECQF3N۪F:o H ))bdM|`َDz׾jYǔbi7LKs{'.n<;w]Ԑ%'l#L.؇u*< tji*ւNM9hIO%B Bɨt$ȟhqgmW.%~&gOe n*9 4͚#ޞ ̃YL3|fCbhֲV=M4S (YH֤0}g`IQyIUV8P-ҩp8Y6.Zs A }Aa-8AKXp\xR.)$zv)cG[ ؤ 1VGA3KkW554'DXf9κQ4@(\ 49XV QE-9CX8D:B '˱Y% S8+Ed)Vf',C}NcĦHXyu7I:So@Ƴ'- d'4Q2|57"\yS']m/ (E"[X"w%j(Ul $Kv4Sj|ޔ5l:0t蕘X&С~b) uKP{huR)J(>حǹT$nv%_lfjaR:" :;g0$j߫j'Vx_bn*ֹH/9;vwn0g.|DBf/ *,/y{ymq' 9]EA9Ը'w(ʇ-1++A*#PˤGƬ`*?+)_44}2 imQF}{n'{oz?pLh<`(5gdžIgZ|U@%RtunAa]W_]|lSFh0l&@dqV꧹QnZif [ Ash-F$fqrGY뉟*+OH%P(/)zTIL*+o_}8X rrX_aW7[;5 5eNeU'q2ti ɁKRӖ3&aC9Um1&8Q^FɮMZՃh\B;":c156~&Qq~s.CXCsن Y:8`cێu$9M;OxqLۤX`6{IFq^.v.i0 m {)YeHLIIPakqY3ae3Jw.<_mb!y*, aM~1μh 11r0%P+Fpw*DZ,X P2qQ*09 gy-\2[ˇO֎1K%]y) htՇX<(GmjdE<uSs NœF"ڮP=Z {JNu웲c|fǽ县.J_7$4Hʻ<7a{yqkY8<)i{~q,>dFGYm͆8yԴH{j\^F[^ݧyZ9xU)(q)T`p)@[G& ||Janӎ%PI2xhs[~3Z|1 |(8(&_kmtV#Ń:,yy1xLty 'ߋhR3ϯ9a՘UlϤD7:c.6.106RZAT `w~pNFNlP B֓^{mFзwfx8[w?j٧ )}gۙ 2&z9bhoD#xm8 ۷>G&3[2$._9Y>)>iSB&}_%yDx_gO-~~ȻCXSL-u-K~}a|ZOA54D:5+0 UӾ~LWY1ȠqE~<=w$-x8ĬvO"D'΢ 1T@T_Y9պ+VtҚa ͯ60ySv~ob\,hȗezw$d:P< @SV7U|pyt*Js~S;>'3Ŵ!4Ys64_dBx)}>g-|7Mep6@x?Ěb X=1j88 vn`NdmpΣwiPGCWۤY#is%f(S',%9o]S6kn3W1#wGκIeQ`ٹ'%|f)9T0 iKOg `3βe <Ν {yu7{EH`(wg?&bœ7-U_'$p&G('u%j?_J9> stream x}ێ${>"}HAEZ@FZ`%+U*Ue53#4s:8I3;vHuk}s?O77<9~nHOF{wx]n!YM/|JkO^U';ݾRs?;e?{JO{^?_&gcn_~!骅ߺt|zYo`||z'=rǯ[=ᯯ͵j -Fz}M~ 5xAic-u^O.RMB:ȥʵ2ʄk|>wMf_^>קp7xh3 3W6|Rst+)fUH(*_Ȩ VKb?~f~u+5)嵯m p }~0JwPjI Cg}nELֹ[N*goM6~u{OE8(s/|Z% V"waF+4VŐ5#tº/xEp=.ybkc1KdŮuxJç\LMdkA:-VOZkj+N΅oV h䗺/7^M5 |^'o:/j1:,vy4\:lޏ[r^1OW]+EZ+oɆIdO0݆xmNjIڙ%&?X'"BmQcmkH)1xzJa!O`fP'(bյZY=W\UCWzh\jm25[2}?|XѮ?Xv opSGz^' ̸:$Xh?{课ZW4><易l@{[3&kFY]"};gm)@ٶL% y㯨m(cX2m*- t蠇ZQ<YsRC g9^5Aaa{nu̲|:83F},ḯͱ&d!9V.Zi(~b>ş( ,dLʨ?LY}` OƢKuXk]r7#ܐh;azA&.!ҝyoFHr=zrmvzϒ1eU0&Q2%ϳ'hڠdEɮxoЄeP~~< NV^:ZjzT/9[vikΨACѾsORuPx_aso]}^ް?WC@\**R<{'$D28eVC5.^Skh kSd 7T}c]jdE]˰O^7R3%`~#oCY ~P;2wrG/}2eâ8jÖ_=rw>NWz@ve~|г.z"~GG|WkgK$JRAT+ ?՟#m[ v-C>Y0b_-j*?Wy=?R]-{K .}OBCKqQR[,CwCu?xynm""ǧǯ?}ǻ߼+˧w6B ʀ.7 HDr!F;)mN )Av"5+0R ,yJO'M+  EYnclGrms}#Fa 3ubu5J:hՇ]rXd3 F&+el_.sTVR7TCQ) u'̐լBk%\ì#-k&OL`Bf2*Lpra}2H,P 6w{5D%Hx~\adfaR]ΕS0' :_@I;X{4cEBRwڭDO,z1ãДPzrD>8qEZgA5qI7O7eM' C%TסK{]p-RI'Q.X8sj)PqeRm?ch k-5Z`P*TK+ӐjKI Y]F&!mGu7Y@[ %*djrp{q+s`v|ЩrLCtϨг5gr+vH&#!ڦr9^I?XG|sf,zeLt [:~QDte^O~`%+6#(NSt=/Kƻ:(S&ly4@9T:RXIŃyW}+N(;]ҍJS2u,-w2 i18%cJ;]rRkdoەY@TF1a+3Wxg91pgZS~4K5$+Ӑ63)/$}B2 i?}9fV{}"e yeV*LCRt0!n%a P"r5\7yuJ2 h3 O`4ޭ1ו)({}^քLQeYFs2 h3qh K=>Hɂ\ݚ[@ڧ)W0+6Cp1u@P|{]u-Er'˕iHә&+ۨԐK<P,T" vefUuӐ!HBc <֢:zG@>Wf &P;>;'3vef,h KLǔ'3pA,WSpZ{ $_0QQ@i]Ɠ2 hoâtxEƃLC~IW+\S+VOj40B_AbpBڡ%, Zʾ,D$#F $%*.uZJ<>, ʵkņ4R02fo0)Ыq:BQ&lmv^ -e_eNa^- 5-_eFaFo0h!nnlMDZ{z[;4mV{VPYڐu9IQ\&֤Qq( H_eAǃ2 iN7`.k+1! e&O:S^ I+`.s`vGMh bB <4MЙqAMJrݢpi W['vrB $ˍhQ\leG4<4= 8tic-js #ePotyT?Lx.SPv8Gq" 䑶 I}$aCڛۈ'Hm>\!p)m> ~a#j /п]_L۪ B <<$fxI$"u; mgTvUX|)({#!eGNQjG=+ )$!?w2 ioSў~ '$LCڒ!%hTRBt;o=jrB <,I;e Jě!\<ޙI"H.Ӑg1fOg&%$cLCT2 8 I,X.Ӑ1(bD-/VB <4Gcm۠ЅùLCډP7Pƕ{#)eҢ== ΋͂z#eЎn2u!` 4 qxXY@;uJ$`©* A.p&^ %TT z$)eҎzZ͇h*HR8h I7.Ӑ"Q­攉ItL'ЧcLCڛ4k;~ $2 i/5R7etqxPY@; 2sg$CDT 9ʘ $bڛABoQ{ס^ I2t#괐sxY@;]Z N0 1$'|͇} CPm3y!IeN۟tAn{ B<4]I?2< I<.2ɷ1ҀNN /XHI8ۓ4Hˮ +y!IeN㠅kۄG\hj eJ:8ţ.>(!I.{#hEd2 h'꡾ 2 MԵXec-tpW.2Q{'QRBo5z!eҶ0ӸOܢQ`Hu%zp'D`mh<|lU&,Ƙ.*7P1uz-$ eNwΡIu\/#ڟ[ָյY!2 hCm7@J I:Gttdf. ZH9<4L)5ю>^We$B钀!2vFHG1$cLC[̆{ *CKK-[ ZmRz=%9@HF t[V((ep);p)Ӑvt/p\3dp);p)Ӑf"nݲ?E…̣VJw}32 i'}32 g[I;qQdg#LCQȸʵEA]32 gIؖ6 VkE<&-RyY@":(_T[rw2 i'BA\\θY@vȬ_iHᑣ(!% n$MHS>ګiGQvHك_$+ "8IBÝYw2 hG;A oζ4$)yp+Ӑ6 3z>d!{0+pD-6e_Mtcpm#s+Zƀ yPv%J6-Ӑv$ GGxL̬edpR8 `.{mf7h[88 $%FX!툒@Z[ǴH4P4mYb[S&Y-22 i-MM/{-03w2 hG$:jjq[fe҆(1!5pD,Z4L'jV{hLCIxf@P -27iAas!JdZ!$|kqy+wiDvܮev‡g28qψqiH9kU߯l؁%V-Ӑ6rKt$8zBȎ̡++r CI, &h3BA, wPڳ#ҡ9 U n&5|Vյ!W4=M"Tev[E{ Pj*Ӑc W83i2 ċPfĒ:4Q2/CO}n[\F 4O:hIޗW W&KPfmմXAvP!mZyvL4RG+A3-i73.o֬ev{bcqNZ: `c۵ ,_`+|q nq5+hj?$V9\Աoo~|c+P enXAc?@k7m}f}5]+X ~ z˪ reu׀~&I][uӻTK :W6g|z׿-a\R.dU_]P{s ::vOa_Y=T+ k;?){V6?rܨM\k0^Y{FK?LmL`A`h|C)p:>y9/o5 :A_ߚCyp~{_uu㰋πQamq~6]ihPuUƏk˺yp=6`+cfjHw]\OG+׻Fd,,mlEM.$\Yt;rَ諛mN7_] buUyqʕ]| \g?[<:m{EM-%@>޾ǻÇg)mXcm-FimǦ1lK056QVUwt4ߌqCU p9H@ wB+ɒqyGtx m@ёxx[cBW rW \z-J=ǻ><9_c{Xz@k?yi&x7k =OȞ9G|5]-=}-nqu}sͻ~w4:o_NONyk'߶ffǻUBglx~g;닑(ˤb@7ɤ"Rk=4&y۫gAn wRyi_dppȇZqwkjA  Ks=Fo^3/gۧcT&q{ۂ!%Oq}n1@4j+_qEm-endstream endobj 320 0 obj << /Filter /FlateDecode /Length 4957 >> stream x\Yq~,A~ia,r9K45IC?UY=CWXSgd_YވIn_ޞ+yx&6|&Mvo lfsY(7NBGVN.[y1ĸ;) _[!=bTz0?K׬ݻ0ۏ}zye[ 0ͤ ۛ2J^Q!=];r*ܺv!n.~^>%nC0ɘw%>K&a&_8!tp;O1;c~10ت ڧv qy1cp^<,Me.es`xH|#@geմwFI~q6D k Ƃ4\\[r =*a˘7l0J'Z=?Ef7ir{7+I3d"BRC@dO3 \ܾh*ON,%v 1o> cai6&g]ju-5igt#ef!Z5.R(s'|%JBp9zw(,2J.!Lf^t*֫ca5@Y;e&o2 j ,b;|a5e?3>,gD' #ՠ]Y5-$VybO%:af}VPP=tزՙy=^{I+ V|8+q!aHW9Eo"u-HÀysrת`,NR``VAWX Mbo(@e5)Z1 AB֜,{FzŞ6Zq[Oف?Gơ#\zf@F[r3ʗ.7g;Kؙqf ɝqNAh`XC6xeCGWܸ!}UNG-+ ƹ-#\UV1rKfgؚVءx4LK? Da9##D<W h{cAT)`ڊ|qŇ\5G{ } [y컕H$d%uCkQ$ۍC1Oλ*[JJ~f|zH?-J*Dr~g%#Fe6JU.u'-αCYd4%S`\n{!Yx6O#¼JLr9MCmFṶb4loJ] )mJʸlbyh.v6ŝO14c C+jLVEI9|Z)B +\Vϒ%SU:u;nRcD-( ͤKPv3IXCJgCJcR]HXD.SHߧ@+tJ{nKegHwP1Hݏ"v*Ab";Vy屩dQFPzH%`Y?~4 ".@*X?mBcj~^|^q!vV+):Yj򋻒zK;W^4V# ܭKZP&5~a83# BWz$wNUɘM#JF^}q"ׇ VՀt&I10wwXQʬʫ|̇;IkOmB4&Nx3ڟΤbEE1dbj@vɴ(ϖX4&t^Ǹ odʋ.޴@RuS/4,&5d$UUb/8KEFv2f S_q2U6fDk ,U':&xR&~p QYg^p &\O-ݜu#vu!43X8,8%e{ BCL `7 ՞nM7o%uuhT:.׏0mX4Sq78O8wRx ĥ++K{R]導2Z EB:r0d+ 䂣RxMFP?,>/`=Sx:#C{dheCql2]GidJn3;):E]A/sp]GϿfN>mzs`P5|Qrt0ӗ"C5i`ݺO9nO˃[#|wL,1@Vk.<ܡ"Y꘥Q&ٕIu I_hL^'>Ҙ‰)wb2hɽXlA|,q%FׄHTpZZafŸz@_ F,'^2Z'uyuQ66*(RPMXՀʊkEZ6VluWNl,[c),(=ݕȧx}VX)T5d1ˊ8k^F1z@#\η_V[چYBwM E |u T~>o2O\GR&ou?q=ݎ 3=H (Ҹd Wqn*_EX9yW/u.n|}㼇AH&K+>V.HL]*;lä' |8]:}17p B|n< E.$DzwAOQyX&8r˴[j,jI.l?b+a$d |3E8p<\ZOa}kf,ߕe#(dAXpЂJ8W]ԻelՇ;i؁9`/z*G]0D|? #drゝߞ)T; >1M/ǀ X2)~ EMS `fPh|`K|K[\vt&ytkب߾d}a!Co9!8 >&x Tŀၼ`.JmG^ %˘,DQRq3`*l9!xWғffM>y"xWF@AU紒Հ{+ T 5{FBa:2 hѿM12(?/\}#Q_&t!Fӝ(5_οnҔc85(n [MrOAUxYNdA&Nv*ƛ_(ɓu_s:-sily pazp?0ƙ?"bY,,ߝ}&,endstream endobj 321 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7685 >> stream xy T׶v-]DR Jp'F*ḶLtTYT4hxQh1 C51˻o XZu{7J"Ȝ]:Hnk,3 zKwvVC })D"Oq  a?{9sfMw2e ߰o/WN !~]woD;#"BN=+(|Rp±"vڻE/ Gػxڛdf&(u1xS7–/x3ryԊh1;Vz;[vk]wn8zEc=a=&O0ma3g͞3w^5ZM PsZj5rFQzj F6P㨍xjHM6SNDʝZBMPoPj5zrSӨtj%5ZEͤY 5beOS WT??PR,5Q6-5BQ2IOI/j9;Jt vO =}X"+*Y =Lx2=HzϷz)z>Ǧ~k+k~i_~t0tZnd : =i m<|p8=zRv{zmkGn Nڧma[ bx݈]#=ugIXb:WEHJv=IRwZupjh0#Z]1dktx. Ԡ a"u,Z`P"neB+;Qee"n q;;5 vVr4wWۓayI/"[GyBtŋ%\8n03֝I!!q7;r}=Kw~*-z{7?GW߅A^?`ޯ=¡'M3ܖo%#ZM>k\cyk!AQ)8$7QMvfp CqHz>.e!G5o!hw>RPlO6X~Co y;HVܒ +: ^V[C@Kj!MDJ pvA,ȱ5d5q&:B=ɵ- >bU?ǏlUi TkM; yelt<k )5jE:>eN`Wbrybo4OAh8V9 2O08`ZsO_9q^"`J @ۊ7d0ReTvSxk#].0~hodU* yhr<]EB z,,?zR̍ Spwkb}4Qo:Zx R"uڱyŐ LbUdnU)EV LtY="25U.+CV4<4j2^ ^ Lz>Sdh!g䆇x.<̂D?{mˏ.Q 4]ZcP[o2қ+g6Z7)"U݆O6x7c&;} 岰;V竊fњ釷[wN"xɄ$6rvGl,O _ ,T0p_"e3sSJfi?[ KR­D5vsaҿnIIǭ>ӂ&Kؓ!*`()iT iB=OajɪXZ_)'d/3 0DOW5HuYtg)vM䦡`Pt 0B(=*Ey>KLI&U|}2l >v,lrjotE|q$3a[-$˨LM:;T$2vt,( trN ҲPOص/%oY^XH3)PeB0 Eɏ2D0nK;yֽK&T`7L34_d%+i,ÃRC'Ak\*F M~YM.g'.'1{fFem+vߕLK(y 6H~*h0ECMx(Z)L?EDh,0̥soE^>a9g M>}[*|-6g\ &YzIjs |D7w&"ֿijNfUӸ"H 2Eo 4/gn_3CE CےNLf*+,5$9Iݖ Knpbj3HbAdg-U7~Ku.R sr={t$%bQbTRaͯ,?n&fruB6l:A2ʤwG ζ*Ee9(( D3]VY-'<Qw~LSߡd%)Ndv/Evy[׸E;++޳7 "4oe{>l|PT$Ty鈶\L(LK,U@ h -C1ڌFM$D-d5DAMVhbua.hWnL*Ɋlڃ7ǾT XeYqTp7O*Vҕ=A-6OpnN]Ȉŀ{\0H|v\IHm 2[=ܷ9V UmW:Q ̱}4ަZ4 2 {罣'\OK>E]S|L)$;q-,jҒiØ0DŖl.+Ez $",95) i)Q<>an' SR?i!]մ{2"^g%IQI^Fθ>;=;Mfd*! =U j- N8^aiR%Czc۱DIl X]r͂Tk 9z h6ҧ@6xVN(\`"#ST-D&BR ³2Jr K۪۔G'CjqQ$ɢ E Vpd h%U5skRffzTIgյgVkXmaYuI`JTxсށ v6&!D/Y'(F'  EzLF$o8 U⦐loH[{xnX:?xB3Xghoz qE5`01wb.Z 05ҳh]}-#[yzQDÏF5J޹`q#jERLBARY^"nF \Pbb󧾹lk_A +'ScmcXr[6,z}w޴W7pj6 p4+ R`;; VU@[y-7FEŽ>F#vɷ[jʒ|]d,:S7<7 :@*d氈:47llCc4lZld{d"WBZOsr 9s5? -Ohx=F[ŵMf玐(Gؠ=B?Xm2hy˰u]!I:+ ^43AD Y =(梇wU]..wϮ 4'%x)̇#"q=c'+ ]ᕫ!a(VMkԐ\ZX]**(2fgփUo]&dZрbJDUFFUT7TTr.tO'yZu Dp5<=6Uqaq[:BO_NHO$H{-v=ŚϏJC~r UfD0]&:rr>p\?>sPrL4eiM|`>El 在P+XL˃LȺԑw‘L:աDSi9嚢DGj8L$Ei߈.PR~7+Meu/Dj5أ6q| X֊"0L\=9q«ki<1BvO8~#E UQ*'abyUA⾔IsrKN9L|R G>ɬ_:=) h xuoʕ ښaٲ,"ò"A7J2"3DySv:@sk*WOYl< wز&C{sAh*v)U4jHOS\g~g~b~+ g_%95uW*BH*.ubOZ+D}jyM@Nw |DzY6fƦ#e)WN! w gLu%T8*\[4ypZ8Uq 0 d1Z}˜>IlWa_ Wo$OkўRp=Ш)ݒl.L~]U(,,20ҋtE\]v=/'|='̃,^q4:ua|@]LYXlhEo#xznGXpM_̧b(2_ӑU+0|uZveܑE9֎ = ;"KcjNc\z;$vҗv- V> ΥSj'sgM~\VDn m(p"Kԃ;%lNqPgHY JuVE¼dr2hl(3 6b41ǯ[ :&El{?̽Y&Y8% .+L\s} }{$}x.8albw d.v\@oendstream endobj 322 0 obj << /Filter /FlateDecode /Length 4054 >> stream x\Y~_7CUye;NG]˕~v]F,r%+>8l`f(jɕ* ;mj>`_r~\3^?PZ .^/IVx7\<G;+eØtu8R׌Ñ^-Vq)Gᒴjuz*)Y{v;f`VT.` CCj2.&ka/U+_K, 5 5a|d.ϗ+*a=*׉ZY\#߸J%`I写kh1S=54\]F2Q-v'd6Xvi#j T&TUOcQj9&.BˡЎ6kR& X`a7qV,I~eJx6I@8, vdB 2ɦ,G,orMsRs|NŝE|U~?* NGin{EOʩ!zؕ8VF\{kPUOJ=W%L gfiCv2E$ ``⭅ gs$y| k~QFe؏5- [Z8pFV>6aΪjЗt*Vր2-H/ŮmBUmnFB 00`2ٞMvGiEhmäۋ-iB7;< 0~ R' r @|Hھͺ5Bv24S>T]=  1x#?:ހ33/\. VaU`݈c#,oxt[-7%FW6k+x048A8h*8A4?Lzzu;e]r@-IlW؜m+Vh3vԚa' @(sD`I! )FSR8M&z2s:9D`uD[B nqKz Rְaϔ:~:ۚ(ýPOH))?&zSo( lz]clz}_ǾMzك9N?'Kuum%pJ "kx&p9|LQ "Y_܂^2f˲껽eHZ9i t狥ͯ͸+vy]`yj~:ZɃ> $kWxZLK8};' 4%, tjRN@`Xy~@acF|:*fk%M.5vJIiOٝ(h~/}DM/"1vZܕ}̬4Y1cq/A_+ ;tX/* njk _iH:_/ǁ[J#%j*0T}70LS$ GΨg!b0Nw8ha%UW6mpyKY_+B.#"m:^. k*C(WbN}4%wsT"a3ϝ \BSp*fn|} w"u)#:iւCR?$ɉפ#%yճt s%X&Q{Vf0@{Jõ Ƭ2hpyӧ`0fd pkjyk̸=عݔ. .EP`/&{ YP_Iϐ@![/|Z[c34?dvZfld[U_a&4vqlbl!`VKhx3^O6GCJFb[3c:).0j6y:y2`3I7Ӭ o2 '$R "9Kw$d] q/ŵ{qZƢ_qUOsy]?$R^H=D yɃG *#pfwvѸGm߈TDhO4-13r,4y<-Y!R+ÍB4ogCٻB%-9ֱPڣɍQ2/Pw5`$X 3zXR86m⌯0;[ZB͛%I~p)"[İ-vGO"ltpo =]!;3]R7Do{Ͻ\eap9x9iiW^{0(B|^HCq/pۓ[" v<)1D qkwa1+ٜƋi-T 5HuKUpMt4tL4c^롧{0IfJ-j644ve0!K5ejpu~i_<(_*c e|f%F'2&4tC"үL/n<-Qga 5_t΅%> stream xy tSa(maTP@dB nhTpӡFo:čp 4G(JaXlCUhX)±6 ڰ7 D[MdPߺ oL/Mk[ dX;Ij-W b4N-@æ {sk@1F*΍|m_@c\h)؇{K ș4VP!ifK0>#ŋfrcyBMV RRɧkkzhd?NY)P`m=hTp fwwtַzZ}$2HaȄ/ !bcqk=*@}kԐAϨ@O*_yeyTzp!OҀ* mШ`a}|7 RUaNG]WЍF P9rT2DS\V[zlM;2}k>8-O^!>4tSS.%~yEyԻHp+%}=[ CE!gU21˘F39`{V>T~6Ay?t&vi "܃MP^E/\8]: FD0J[SZ|(|[\`ĽQU]?S&29ynX%u،g&+칚æ5b>D!%%;]T5dM[ތxјE^}{g㘭ˮ5xa #P+`oLCTy2syԛ@.͹ل~=};?,2ʬd/.h*nC% chQo7I9`2UA͚Yu:6nvzH"2ZBoiK)#)MGe$(Me/'7;mgc@GAaU, JOVɀΐ't:Z]CjЭnn/ 8 J B3NG+cYR4Mmcz Lp#x+Y^s|C4ɉ׳ˇпk0{O~g2QhPhJ KO7}IwZ]MN~z\{VW ס+ŝ]h2!w@Gel߹ H1li[}Gvui`Q%L#sAe0+^$-H+?Ot<LeB]y39ZQ `) յ7X/:y='LfAϢ޳ɕ=a_R6%lrvNŚKiÇdLSkh}z,4QJ6!kUAY㔥d'l5C"e6a[*7N[]y v (!8J>GmlաeM9& HEGA3Z?U )sh8 @xھ/<;bjwuT~A9(僤'lA`-qtyZ$QSIrq3$}tlÚAg@}eI ڣ->4:#A\m;lf.U,Ԇ3뷵_WQUC]z3~ ooPbJB*);m=amkEg~"Ʈ3Lj eb%wJg4+dOPbOOhY n w4'>-$2"ʔ,t487 {Se"+lpi`VnOfX"3텾}ܸ~$f[ ߗC"`NE[SFJM7S0W/6[ ~摣t_q(W"(X?YAC7z <7 Ʌ-h1Q׍ܒI۾ffA[e@vxı!>uJt}W Dvs{85M Gځ)qsFAg=[hou]+'ur+ tKT5ʋ^\%+|Tݍ_B〵cA6̗j(juɠ$ER=³9 Dx~i~b-^#R)vE$lnYR JKˊhKՃƠ 4U<}NB4]E@>Yq>'Snj6s+nFisqzw\8! nǭRO߶6윅1o_%߰!c(@4,GrI3D!P&D.|DJW"P])Gg~n*mj, fp= (OW9}1ܖ;w+ϋs#A; - Ͽ@&gIC}KW4L׎56VP G/d3tAi6iZ^w^ ԧ܂S}:r\p&i7[[f[4_(FT'@W[SOa{\ʤ0H́@` JFE˘kC(ס(ĭ߀O/ c"ΨT|Ǎy~G\-J~ |J~\YͰTߗQU"7KDekbZ+VGyɏp<'Ud<㭫4`o"%_ (xmyVd3C9羇:ncǎ+}|ayK-NA]UVCqmBM:䂚\ߞKH"}sT㩽Lt,6bf7EX- Ud,\ oZq} ف߿c 5Tڨo@0X}tEZCtE@(9 ,iiVQ=DdLj+a22< -,[ऺ뎿 "0'nwo/57+xǮ"F޹yS\(F H\hkp8 Ώ|`Fw f$#-=#M= ʽWG3*&Mnr+(`ˡXtHܵy64vŲe6B@VI&. :D3׆ӕΚ'63!w;uK5یֿhQh`E~M81^í Pi_yNu۩hje dyiu:J" `sLNא(2|lT,lvYgA :sOJq^e͆"<>!Lmki,ʛ "KJ ],̎o\W-q{:zZvtIʡdXFY)oYgjLM)/0绬0ɐaͦfFp?'q#&wm550 MQϝ୾R=ˊ1L,C9޵yڤ6U_dE&+n`=hۡ-_+3l6'Acb8mLTiz9Co.+VaA5Y`(*W1j9+C(!T׿塢O¬)'&V/}>!傞=QiE55_&qLagW,f`˸@l:4kt{cm]C]SViZă29KOb YՆ^D;ȃNXTCGj0č Fīѿ10#ê?ZMܶtc,ߒUjW1mwW3G=R&D#} і͋O9A4a]fAfb8)"[[~G>P MI|6 6üi\)'U(dbs'[)--"z[ki'_}jףv[H Zf)7ѕ)N!.Ga(3PW%C.`o , NS;,XC.$(v>lA6 eC`嗢Q(5E'ri6}Q2[`/>AU餠wwi8!9!DVUX44⧍n^.m_0/bƩT*=ˌ~yr9m|pNX({Sߴx]I uz4x0z&~poB빛Ws=Xj4c!W{I07ϷOxmhM& [i";aI5: P&V^"ͽdb;္ Ak`2ߘqFnԅR- tя(OX]TUZU቞wKUp_+@[*T *֠tS69+pVI%|֣^1/m[DZ97hn*8gvY(GcI}=4BԛY+:6@go [gGu3ٚCN.hvM.hyܼ]}S~|/i0&V(kغe)g@Gܜ䖝WpNWUK{6F?Q-ʳKiD^vvGN7oWmvGJ=,:ʖ$cɸzwӗ娹M˃o+J:SW g6ېXn&>7?0S=T٭69|Uz -'I: vfHܓ͛*\=j-t9 (i?[jtztAY^XTOIV j8SThj`iJQg{?`"GGMdX \QgIiCԁƺj{t.8wnKѾ3'gQsRuJ,;hB{: _g^1UnJBO\IZ `3*|xh/Ư\jZj:Wˆ4vwl:F~"VmQ#)B;EȄu)[r h\!MZj=䢚:R(㗷'FHK] Phl30`+L!þ y$^(f66R/rw'}R1/{KhJ/w[0硲N8*xFRiV ?ޮ{HGT:7< \ ?.>jY .O L,Eޅ{*pqPv7%X})}A!2AxHTZKʠr:IFFҞ#'yK3Y6 5^D 9;CԨ/G_"endstream endobj 324 0 obj << /Filter /FlateDecode /Length 5339 >> stream x\[w7~WGm{̞Ȟ}8d3ٍ=-Q* }.cgwNqZMt(?ORL*/r{RM.O~>$zSh'•R=987e8#JtVUW, P\ g Cޯ꿤*蠑;dD2#qDF 5)QJFt& ЙoәU ӪTA %tVveYU8RXt^Z> \|SYUIs|R%vҐ_/JW,׋0@ LglʸPl𲪜++/m a8Z+M_ZTԓo!,[U"j]q9䴓ΨbGSi Ilt^/n$*B&.p%{N 䇓oǥô$U&N X_lʬGwdɻL$AjXg/(Ql†;cGl$p7A>L Vtl6eM&C*PqZ[~RG v:veۄ3TC.ԃXe<$ؚZ`΢<*K $Z|=J^loQ1_/7gn.3Y-DTf9?@A69Uwyy4v%DZ@̿6=fEu+Sj3hc,PP%i`Uik$@kh{) #+P#E9]+= qR_|Pn) Ks~~ ؤ]bbo#<`bY?n@0 U N17#'^2lՌ,LPJ1#I$}@{aD<:wr^Bǯj+ilrbS'Wذ;цOwV9bq)pg;z}DF5f 3 W:9:w2pgF ߎ+ric)\PT4Vke[exe.BO"BӮAҋ\'4p=6 j/Ar 4ݴ|$𑃾zFxwh@U־alRϛ$CB =6B<DO=i~ <0CP_N~k+02#( ViJhMَr2v; Z@R>; I:l D}:^|;uhEq>Ko< eyM:v) l#:XN:McU9?_ 5dIH)Rm3 S]8{_J-|$ :9٢pbUEzTs=X_Y,Xu#L6i hgr@O;LGyTR:.v|ao#xy#ưcn_i̋ VZwYRj! Nw/@ BA"]g>vlwǐ6HsΚLCf+ 0rהo;V3[ ]k69~SDP腞#S:cHZ^;o6xEU;$4$HAuz*1+ex6CCb/E)?4ret񡻭9仌Si@16h]fQ0ʫ,P.~`FVP|_FvꥰqPab(\`/yީ^%`$bl"t VIg\s DHneP;c7/m &k찡rcLc'}Dp-1X#hRKO 'Tqk3EBv XrRXn'e{ciw<6is7z9{r?JpL'R#cPC_1B 6c%5/{LL c祁{/KHQsS͉Xo7;|oTjLM[ztRȣh,4#0US=>efswCuL~P+p1nU~ǽ^O0egf'?`jlN:?Oϫ|fϻZn1: Kn|Z8RJEyaL"7r|T=o8&X^0b+[BWqace2*&}>Ev!CǛB!4EbhX =ib>8.@9*Ov2%C~uu pi%NJp?U)"cC(MMX3wQO^:K*=jTcGrf%0qIESxӏM_Wxzy=_DŽB#nZo̘7|im"|<̃+H6I6~Eo M/dxf<ᄭ:ݶC![hg2uc=NƊ8(;?PDz4ν}^TG >Jf,/+)XsĈ9Naf/yiF3cnuE*$L @T3pV'r)O/sxzՀm'J<9>! u"As/pC^3(5/dzKRS< 1P \^eDG~ɚgCJ8t&vAeSeE^:9ϡ-?F gt=27c3폱# er(B mcxg_c:D5ȁU&kQcjՆjNB3UitE<憚^ BϢaňg( Jg !*Tf.!9(իMXnϰh!v/e+E|ƪ"}ƎdEk!~2RMj ~m](rC[!֞\،/sM슘|ҦXTEI]/8G:eu =.^ 'SXMю3&O.\t1F610__0$\S?]|*) 9BO<%amhQFl2 M,˱jHq^9qoېU.K/}czc4$x"(~8_qendstream endobj 325 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 585 >> stream x>CMR8$vz-  ]VQmqCopyright (c) 1997, 2009 American Mathematical Society (), with Reserved Font Name CMR8.CMR8Computer Modern123OEpbcVs,jŦf,hjዸ⋴ #h,t`‹ ' <02ZYΤ<7#B? rGlwYx?{FvťbڽQ"DfVT@htkpozc,MI%ڧϋ1# :Q?f{ku؎׃$Ena}{mltNx~}vCoa  7 כ )Cendstream endobj 326 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 594 >> stream xGCMR7$w,  ]VQmqCopyright (c) 1997, 2009 American Mathematical Society (), with Reserved Font Name CMR7.CMR7Computer Modern123QN͋oKL0bg͋§j~'eg #e'͋JiuP~>}L讧Ǻɋ !74/XWϡ=:4MFkgo0w!¨oU CfQc3asloozb-N K֋06U;ixwlЖu4a}]qljeoYr}wCna  7 ڛ "endstream endobj 327 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3925 >> stream xW TS>!sH\jjqhVkj:08qE0i $;aA$0DPDVVꭶY[Zr}?Pw7ub,?{/(H$޸u"oi"aOb#FY ΎK\)H"LE dވHܰy-Xh*yboXHed{&9#U)cv+)z5zuLkk㕪Đ{""8/xsP&j&BJͦ|9/GSۨjjMާPkuzCj)H}L1^JNM\))H&QTU8:|/&xʉs*l<00&xM4qr'9G8yzRK;';N09dr'SJ]9!E86[evE(|`9,6сX6iCXLN=<@?v2VnCd(X 18hi%Y;y`CfisEmt꟦JX[ Ž,G;a17_;p3-=uK i=-}ռ˄K,.7," Ȋ6=׽k"i,"6j-(4gOScǯ hq8 S q 75pLe SwC6,w+,T}xkA맑֟1XNk۞`9}.w`G^z%|\ɢxt_i`t 'Y*,˫M#2RM!Amd%+aA#EV< -+yx8 GI Nl8iSح[fGv/Pa~,1;交9)$ \B{~پx QHjd(K2& V^*3I R9=4aڸJ;[9ИC=;iϯr(<; *mY; Z!] Ś-ryy፡p'*AK5f& ঱9FcCoEDY,i3D%˨M4~k׮r4=n5GHcVufW0&Fʜl>+B4g~sз+[ XpҤp3f$l j&bU36Z)!`HdtL IռKܰ#jɮ ܭPhGX G@Av ȭHmȩ (8XPJԳg,l*[sVf"aU :s2 ڜE\Ԓ[3@{C'IhvmVϴi(*<; 4?W@h>)6l~f]в?YJg !C_>E&*C4tCgDUZ^nL69 m}e-]ؽCKݞ&om GÉLzC/3'ݷWL lrA/FGQ|H_Uk8N+ c%do\aF)*+GOkCcM0:~aזpVMo&֏ٷ*?*zsJ4 bun֟7wꚵAAČjcĢ:K52>eeüXKd>T(ZЗUuz=>BavSt`,<!>|71|#H|# :^9g 6]U uڜXȜ[- v@-7cqt(*rIUGe|c~9@VPb*ƚTLT#N]p0XKh=ž=L@,Zv+6.4/[L\MbX/+;Sb OOK"܂KK!t0m0Rch)?=' p“_~2ȥkK3 9L-9k1kVvOB?3.h7)1c[fCɓ+!KMNJlh4wi_ e75hDM֡CPx&K˶3AJA &Tנo%uG(cu(4eLBU;cja``co?^XCzu 1)iUui-CC֐|0k׾d$ P %nJ a_&>>UFοq |L Y} 6 쵧Ϟ8qpr \TZrtdyCJ5 ,< ʿ{DD(њ~Y,Чx~{k߭* |vمo7%33]lwPaWn ೳIVؗ߼h MEeF&"b9 ,_]T_d ѓ'mccK:?Bw$]ӪK|NA~u[y5]Ws{^XǾ8J!w>hI#ZM9YIWTU52gա?v#Ƿ~F[hSzj9dnq+72'5ٌSpWjqvK\/ߵ7Ok StFT)jVAUɷpi5FS-a=!wHh᫙&{:DÿTfE%8Mx<|y< > endstream endobj 328 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 6499 >> stream xY XS׶>!prx{uZj[j*1!$a<&̓"֡ZqCt֪XmkwoW}׿FDQ"Hh)?G CDP;o\zQooXlOE"yH"n[6vǛæΚ΄aӦL5lAggకJW R#S*wϞe։&OL{+>kRpCj55EFSk1zZOm6R M"j"ZLMPTʕzZFM-S+Jj5%8xՓzE͡zSs>"v ty1X?C>t-ÅoH(+!?`#|`1u4( i39铢hTb]RUț/̠G8x@*_U.?>'2ק -b"!5W;%,Nү`0m@;FAB|6nixXBK<ԙV픴ϫΛ}~N',!{Yt , 3X~G{삕|wWMr,e̢XnE2@%%oVFrn;/ˁAo}'E(Q`툙27o>٭ Mbh +0 _vAp=~ɲ%sesxA1 @ j^6OovxHЙEw-Pb_YȗBl! t]x,i; %Ќ]0{|aql& cKQ {qkW!ُˣM&mh(.]XI &nk6Ϛ`Yˣ-ou+ 9YX~jfl <'3otXbD!$َ4{QY)f;a(d9 I>LJkAkyU뺳&Z`'P* ?B\DLyhnKa;wٶЅV!-ŝZ?J(km ӦI67Я"f's8Y2MHL{?}T5MA@P*gO 擄Eb]\a@a*gyO5>9uvNٲ6/I B#8)겋 My 3I59Kb_1xO#8(6̻tgݑ+*Dz7n9ZL2p.yh%bӕ|̡fp7X@F8*c+Je線*t zf) d8Tvf%ի7?*A !wv)\9uvr_gd-78iAt0ƊiieUBg]3YCcEpˡO3YG?1"r)E(wO&X`YT$DLHM&뗣R rH"FT_N̕h ĸKP18p )QXM[ӔJ.1W>41:}C^PJ-J+c^C˾_:.!{gHosjs|iM@MNT+̐hO"70ɓn2MMJk[,t?^~ PT_^kχYk'?$W`1ؙs~zC[֯OI'ֺޔWo]uQ}\YVL\<ƶb0^(MLH`$+PdG.pG(f` ҷMLϲYBǢEzYUlD)(- -^2;fOK|eQ6Vp@=o~fe=~Uɑ?).qxZ$40OW)"ϛJ s'$/-=yȦ: / E!-C~5\& g.r.VivQ3Gz. ;%ܧ4>kB,{Յ9 EWZ?lzٰmgu¡NQUeYFAC6w BT%saC30K<1S'_3Ԑ\S؂s7s'V<Ό~LmZSeA"U[_.(]Q &(yv{q"S)TBLFY |'tFW8עӑ,bg' 3576֗_(zs\t\ G+Бzdl'Y,CceRBMxڱ2[=ѦMv86ߡIorǽB;4=mwĀ@- D[GWn Osݰa: Yu~q={uS"a}g_6Y6-'Zk*Aa>S羣:5F~>콸mVјP4Npqn}nm9^ETRtk54C/z7 FIu*F;3<@2yDzృ894OGsڽ_H]pӎr(WH rG+U7[F=Uq-99#\bWh-+Aɥqmuhs:4n 6c(|ldD9 "ia!)SQ2 h$xEZаY)$&8|GĢ0sALj2Eyi&Y1<zHYJSTy͠1g"Pd6mJxA0"B2ïx[DHNG7MΚBoe"M z]M}AʺtJP>,qќ|l|t<0b]Aop b30L|uىh"ai+&?Qq(K#S f^|u^Ǣ¸4uo+ G+LCLV1(o8::qwf᭵DWxbHH X>\c~Y*VL,*I xmtl<2Zΐ!Op>e}]3,i #5NwMW'~< "x(i}]`أ{jk(:<EG2?(Rq@px_jD*kϋ={ȧ͞f|ه%8W7.Əc?#z/ݒ߄# <0U ɡPp:pWfpAF "9<D?eV#H$k$0TE br2[6\Gg!caqIVBNbF#O"095$SY-ȄDuYd@()Bz8M2B.pcYfa~F<'wpU a1wҫ^`'g0HZ,v2 ca7Zce\8i*,DRJ?LiDL1^" h3S%i5MJU*D)<[CʳqSRkMEP=%2[ݡ=ʎ'5 'v\zGFs^36D%iCފ҃?fO4nS:﹉8} j-/γ1xc+Q;'1f{V; R$y'I"HR;J|ꃏV]1eǼcA|zzf22aF2D7GD&:} '}mZgIˮ:>_ "m&JAy*ڍeJԌPST~GGCjTST^l,-C%J2 =P4C"Hfszl>ްfBGNsq/9 N->773]-{|nŪkg$ԿwoJ¦Ɋ@a(0*#{85$!n3:34l a0hhDmzB3P1S6)T~%a 9鯠b,=i`Gx}.>r#뿸Z5JU_囷QRrGiø[30ÍFaXwؿ*+]x Io "}G<[Vm>5J@Ɍ TZA__^_WIw-p. _}A`y]"s<eyoZk&8 F}(fhXgl/ӞHBLMp*;avY:TY@SQ :!fuvJ$m$"0E06U5}vڻxp^l=g` 3-krC.0[5ŀ {OVٳ´D]VQg`y@wG^,;e{4VgJ=-jy޽-Pendstream endobj 329 0 obj << /Filter /FlateDecode /Length 175 >> stream x]O1 y?Y"tЪjGĐ2 t|wl6^t{ Z&귨N0;$eeEƫ w?`ʪ" Ai g rV@wj`ǧr DL,\vqx$z0%g~UYEwcZlendstream endobj 330 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 462 >> stream xcd`ab`dddw 441U~H3a!G=k7s7BO``ad/ms/,L(QHT04Q020TpM-LNSM,HM,rr3SK*4l2JJ s4u3K2RSRSJsS ӃP%E )EyyI99% L| % +@Nd\Gߏ x8}ߌ)f01RR|d˓G~Ν|?ʙH~_%;{tnƦi c~ↆɆMS'N.='vMj-9}iz7ĄfL=cZ97?Hߌӑ~뉚_Ň.[/i4\Xy87b^ɞendstream endobj 331 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1449 >> stream xmPuǟgIEo%jϦazxi%VG8R66_m66D(&P̳̺K>C]8}yPACPŒSLOOwPb3xHqZ(F`sVE5Zby]HH9Wvs8o $|^ ''-礈_(*9H{8^qYHhnPZI $EbT ᤊAVI A0.>!qD2w-md C#"QTQ"?nZ ΦNrS³J~׮ j1Sh֎!{;p7?< :HK[ O Vn$. Pc]4vxlex`VA 5;,!x¼y:|L0Y?D@> &;hƘn]YR+nϓ/E1%@( ]qr "k,SH[FoaAr.7̠XֻB=T6(h-&̥rIDf}A`2.Xg:d)F>ctN`zZ[]%LQtt@.⠰M-H\n73 ]"}Al{c styp:@ pcd&Iu` MWΖy *֩VU \)4ɓצnvc5xz*Jl/oCv?G'2YOᐉee':m}-cW >m F) J^q_TLAjYlo{78G͠ w(c{Rfh_\t]WQmn[!!b4CYz*F;@ٲMTv|P> stream xU{Lp9CFVLC܁RRe$ҪYB:#P֒P&c6`s_< y1!J`M@TmV-ݫL[=U:OQt2LRrZS鍒 ^{h2UUF'f>IRHeU2]yZ/yL%|0Z/I 4e:5a[' ސ+J +~cǰ؏bb|~?',M}"1:3Y-Φ% }8ʸ/@7GD0ց~w vF{heͯ6PrnO!Xjc1na;4gXVM":s5ØlTY^"xm љ`ٳ-rEݮ!8mS EP)aNar 4YM7Jb<ŞNwm`j4s\>/VEf~鋹5HA+~%Ls'*1j~Slmvk!+$3678u@g5NȺV9tWh7Hs&i @0ttwgbQ7f}n}OKK$:,8۵q/]M4AL/8:@*\yY!bd, YIc/tzGTFmzGCܖ_dd(Lᘿ/zſx씭wpܐNvNZfR ,ߘF[{Fo0 =<1[Iq @s{/(druUKՅ6W*҂~2-y*@EVũ~䙖(#0MOYI7Ğ>ruy-Yqwz;G> YWAf8XJ[u&0+ng_Kv+wG1:0362yrϺ!&h";r=ڹü*@P?$Jv~@qwg|Y虇s[uwNo&ҮZ`"98O7PLJ.@[ǣ!@w^A0+'$k@GmApK`tyrZ̗u+t !%WE 7Jfl&8SrPlrھSYM!YKS9%ܮvQߖlc]ǴҙhǁoDƟg+KXYfOy5&R[ͩF0=#_]1endstream endobj 333 0 obj << /Filter /FlateDecode /Length 12327 >> stream x}[7r;?_ư]; oZX?(ڼտ2Du/P8jAD"vvwOܽh{GxyO-%wIwWy ݕιջo_?휷-|zߩZ91/G3l~GZgvٝk3ZѼؗ%j0,ǟh ^dk9OB{rC[mU<'D{>,n[ƙ3pto7^7om"| {w3@ 0BL-!ؕٓ;\J[?\1ch7~<y\0@(1 l}w?+ҾGp9߽~3h^=ӃR:rc& {580I( {BV-m'$Gk;GRͭ:%7,(5t<ɓ?ʄ1u?'^nڕ -LW"\xWiWmu3DБoZHHDfe9Eyܔj_8|ު{#)$,6Ef^X^W?OEGz<~k~'D4k?Q^$Gs7pKpzR\}==e j iěsJW^}OAM?Qk m5,G?ʶ?U!:M0Tb*I>tߜXzN͑-Q21ZuGh?dn_Ώ_ ˽Hz=#r RyCݮ0d8R/ȓ]|q@DA:J]tr< rgfQ`Xyco'R;3TQzbrԆpWb b<`vV{aT5U\ZKlԿdz 7b ts"^:>mCM҇F`^p'30Ar^#hKs&Ѧ}qW0{(Ԇʤh+_uB_ ;:!y%QlnOa堷eώf?qy P#ax;p^z~5"C "n(czZz!_ov+b_n2oic ,~Tͱ#cIf˽O`BY8xATm3[P ]ry;Lb~ YBq] VSYI$m I^ DaSf8dc;-.fi_˔v1Ǿp]ڋTpSZ.ȧVԓFދ2}tF9uކG<ߛG1-N*_aIJ৫Z% m,RKƸB~w5%-$Yܯ3[$\ SBf154ʪӭþƘ_(*k-bO@Xp>E,ERj<!0KO&h;x}62.jЎ mZӍ?Imؒa_z[nF6 :$>wm5]Qv_eM+S|%W5%wUaNI4'vG/_.~]0Q:[A3廻uו>_w-ծ1=Pcg&cSO8>V?b_dqiժO$ڹFd_bnا2j}7Z#)mnN["jl&Zv<r9 櫊C'ڠE<ό7b>s7.WbR} p G1Tڠ2Р?A 4٘`VjԌ< 9&yQ@Mw֙ KNwݲЙ߆]kxɥ{P,T~M ȸ3S| -r&}+qt\;[b-^<@jB)Ng~8oG/"V(1zuݓґm%u, ɋ7o?||?Np*Pq0,诨iLUT|Ц>DZܼ/M$mW9sKy8_AP3(-Y H[I+޳^1K.niJRrnƠaz囏?*%6i[BsB;NypHq/r b!"Z_iHrin+[ws64đSE҃SYLNZs.7P,c\9O"/st-AR>yjS OHUaGzK{질?x6FNHT9<5Ѩos狤B5hh\&U 5 y z4gņ#2Yj@~BQ .N1գݛGDJIz⿒_HV;G (|pD|ePp9hDfJ[A5 fTeKfԀ0!=Wl-~ @M*(W L)}>d_I;DLe$&rH_ـ p ~<!SMɶ Z'm6ӶVfNQCH)dNUP T^?܂wCJNtswxg{@/]BxGa J |#QD|(5DիMr z_8)C_q"&-] Qdg0Iz dc7ϱϜL7FO~t[r\]0a"9"w9L`dTŸ`y>҂ Z.WJN球rX\PGXnժs\B6}mL6mɖhVWᘐbj &DH d=$s]aw.8%.'~#^S l+JrH:~ϕ,ٯX`f[A14TPJ4%+Tyٸb$Gxu E>3ȕX!V q Ƕ x;钞DfO|e…oc~O|<CXlu2vЀ죂5l\!f8K1^IӨ1x 'lFjJ=ˏWHy8BBHYWFdUIoG)d"iAcH>CQsKvBQ3lnSV6$±Wc0D{:dj&Mt&7V*mZJ#Lro iD, w^OjI! $DL$e?f~, izTdҁL58W3!he,kr1k#gWRc YIg%cvX]Q)E#V4Vh$$+x1hDJJ˒J\m׼Kƶd%c-l%#KV25uظˊƖX:y ZDwت5xV V,6d7ˆ6n6cYFalspwɖ,Kܸџe2֭~7΢7Ȗo()o Q+ p7EwA=Vl9T$>ຈS!t`#sȈtA۬`$}\4 y=/+GўY;';Kdg1}aqR;']h~.tv'z{v%p-u:M6 Ǣ/Bq#LŤ -b>N5](nS](n!Ӆ ōv noS}7 c JKײ)p?;[gPwРD_o*F4 TL4}vȞ8!<3*=6m/>~?'69 2Vpp,b)g;Hf Ü3$j\/d"2X W77y0"ǹaPzBc9b耔-H ,"ɒ5s[ AH֚60)BED0ێ4NB` ޒr $:ELeĢi^]bTvsHWd6ē8bc&EvFdwHkc) fؑ ƿm /"/dQG^9QXIp> )9+nr94iAp@e;MFS Iޅ9]\77`)("W6,N``(osa+ T}o3TWH L^ditRbO^<PՐ$A:Jd%}kN+dӗ T $q_^W1p23וݔ̕&[z9$ EYksѲtP q*753 C{y2Eu\' \Yc旯 vSE̚A>oXi[WA;5q%3I%NsZBJh+jİsA!W,_R+`\Bry} ho3~tD*h4[fGa ?^pHءCiv+fn8"\ЪT I%'NKX IC8dqz!BT-s"iyƃ0Eeq﹈ αRƥ!) UH!"z2$fq()J\%T5Rj*;0rSѰQ aO4āaSJRH;(/}p4\@ '=w  83.B њPZ3UF_,#{XZ90ń@!XEVĴOfIZn & }Y(4m1̤~RFkn-n =Ն\5)Ǣ[1nEAu֊ʰ4cIZ  G0حڄzk&t8NA \m씢nᨿRGm5pv #NL ~{ 0`Q Ywbd$Z?BER}!Τ3%O%"3.`5Sܽ {Dc]&!!1f >w4f6 }!A`۵Ly3.%}"yV&PmnhIELcP_iTHi25QfU_ڑ+c.1؜Ub.3ryT;@ \Bf?7v{=rIu&&$ !ￛ9^8/Z7.Z2^[JA6<#z hfۦiH+ qBHCsKR縍m4\ MCf{Y#3@B@' H-cHJR$zyS_A4[%ݰ@!Rzz >-cTqg?ɡ7d(I&p폵XHEI 0$LlKJP񶲒 T( D /td@M[mg'D{Λ :OMt]v(m)h!z3qRo\?1 ǰ4 V$:鼧"^̐d'$hͱV3>mG:h߰^&ejHs f-&-JLKk PζwQ[z@~I4oeeߤuj$L@iUw ȋ׮Iht$bVtks eh$Q),شIHzʼnIЭ촵,CcB^3 AY=H+g"7K>қ&!Vx{$LWRCeKZ p եrִRI;Q!i$LVC>(mkJ| M>!FyGפu`4Cۮ=ҳރ1d;d-(@ YVp~BM9^_2VMrكhDt)ބ[WjoB ڱZmDQ326oIN+n-VGӭػw7cm/tJjb[ቛ~XK=mZOy뽮+` 9@Իz@?%] }J$'@7H1`i9I/ڈ@w4Xxcv5-A`iG}Ai4fC A:lb+bK5>=q_$MLH`!1ȄƨLH3CWƙ ipjї=VGnoi]nIuvzDD7pOo~<~ŧ>?'2H` @ghţ|)M"E4'W<:I,+ @ N iyʳ{#iM[hI}ڽ (tUG+\"ضH#E*]":>xZȵbFJݣ)yt0-y$ub-y$ZvQG7Dث'm_l,A^e V=uZ(y!iu_ZU >T7Gǽ7x)|tGz#ALٱ5R!A{HF|óyD7p,mX d'd͌$OdOv/గZDO8@i`av!)$ Dg"/g+}y D}ch9( \Ȁ>SEP-R͈['q8=`UsqS%JJ1AL)nz:AQT6[Kzى6]Z%_ZVmܛH u Y MHj/61^ݬ?u&ZK:&7 NĊ,* wcUNYcHQ>zM,6C*rJsgv,7UѣZjʻPXG3.Y`ɾU j\OX0dyL-HO(-.(׶ZPMVEhz7em*@ӛS-T"4fhYwX \齩hz+e}E!ޛjYfɊY`hYZ}hz_e!ޗjYZ\aUfPͪ $4-ղ MLb4-ղ8UA}EQ;0MoK aK#~m494k| atqkW~HwWIIݻ{wҐ]'MdGSE8|47ZFF XAy2V^s=C"}m]$Vvᢡ59\4U`M u7ės- ^2OwAz7,Lj5lآ_S4=j;hFa/> jޏma3-ID'?v㾷%٩pxgS/L;ӴشpUݱfΏ> stream x3532Q0P0SеP01U0TH1230 !U`laT072̀X$sU()*M*w pV0w˥{+esJsZ<]86$͇]9>U6ݷi%Wm??͵/~/|}ww‡؎k[6sqmB ?"aendstream endobj 335 0 obj << /Filter /FlateDecode /Length 163 >> stream x]O10 @J. 2ԉB:gmyXց&7$h, Ÿ<񭼐U,2+7TUiB GMQ1 欎튺:gh*C in X3 4S>endstream endobj 336 0 obj << /Filter /FlateDecode /Length 4371 >> stream x[Ks$sGtClזІ->X>8=^6PHXPX $||6j5ߛŰpUkW*lrvu'Ut$ &m5?J)6N61SZų|$PJ7_)Iid 1?8Zi;1{q̐4'k4KU6tBt;MĎ ˍxK< gUPB6u^̮s!׷bϗblw:&)~RMaq&^m%hTZ>Q#Z2)ՌR5e~Az6TRΑ LXX ov=^M^)+(ӐFﲦdgLE-iȉRb1)J*T,k;:Ά8,m#I#j|HC2u > 2z@K<8Xtܼ> ׃B_`S6]7ʎ.`lzހylHTFX~j5Q lFE֩Xshx4fJ(V ojJWNP+Rϣ94C01Sz#U!Uٓl s6,hҀ)M`Lڌ'ї m^ Y7 0ʀr1^R2uy `qM,eU=^ d;k ZS8S7Nbzvo:IK蟅^jnF?/̇W `6ghgEA`qKbȡny7#3> ЎLHF8!'d.8x\RZ zu\pyrE:)צ&.m I1Bf.;cǚ ?8>h>^\v |'qxdmIetŰd?E0Oj0AHoc1FL̮t&9/:lxj!s͆l'_ip}v<ˈ.™J@D$_`.N},p2:om}j)|hUx KO 6 7[]4g큜B/ [ MS'شI#QŴ<%cRje^-;bH6G*ٸ񼑡b1)1)Vku1a% Y*m>:<^L}SXX*_4@Yzj/*۱ 1NX^D=!ǡsBZnw+e 6: Y*J43duhA悻d#߇U; ]?R@N>1tgoɗxŻm3vUe5(o٠H^p6h-dn 7=ƟsuT'f@+ yMJf!9L$<ȧ‡`u~WY|XY3Yd)Z E.?_ÂCꏮ+v!:<Anj0-k/4|2sV+q8U^qJ+B}[[Td3@J>/>yȆ>sҫ.XVxcBxQ3>L;CMB7*>-%u:r-,&l;3Ҍ"T8֙TV }$"0@M.$75}Mi?1[K_rEF8g<(9M^ڦ$N i\<91:*{l7zx@0 QRm&%uʉA6W C?KUӬ9**81>mT7 ca&omR‡ -It=P37˒ؙWT}Y2m:RQWJ%FL+H /<^ ͂$IMk1pftgг=Ϭҹ/*7UyCK3<${QvRki$vt Q{MOj'(|ݧpS T}"l9v2%Bj7#jl*54\: *E}KCyu hYKk9b  oAW!T i/$cnmN3jVc$\Dtcբ:_VeL^ `$z3,-IW0 VZ_2]mE̽}gV0*":mxrU%=Daͫ2ITƩg6sB*'`+!\/K'0ܪZ7xKlGX$CpmRd`9daix-gދ1; ? g܉ކ\ +,&:kRt\vYp)dߊrY|'lX|=4BnW>gZY|ވ䪘{7gEaLZ'’k.hg*jgS}$,R n  cqT}4HyG~hkۓaM Xj"-hM$ F,/~~"Y&%*&𫠸! ^}n 4Rpy'oBOeKVZn;9] $qa[AZ.~fr'טKNm&;*+mG}=Ⱥո/g`ø_hvNF Ӟۄv?Rbo"ð/?XlGl;f4 Ҝ&v?=xf hIZYq,xSHY=p~ntb2loz[הөo~2!;~m?wRׯp@jSE`Wx KkX endstream endobj 337 0 obj << /Filter /FlateDecode /Length 3335 >> stream x\YoehGܗk=(H&yfYl ( ?;UK&JsOꪯ3?W K?y*II[W'9: qqO|}^:$h4z}/c\:AJfa^AZBoe$Cо^yQ61qZTS6:`K3lTcLs]Pgq(ƛZP\'w(OG0חEvs8[#ڀwRU/τBL̛yc a rrq>ԻV#=IM_oa&~_(g'G_E~-gWV\O(LO(|{v@Eݣȯ@/f, "?{4}e`D+2մe 2(miCw^@,7BA_=t2pR)#.X6vq\" p^CfzNoMz^IʽANs/" gCOa:*`|Q*rqj\f-"+`/f}'. ,5:%jFXNUXaY@͚ӜgIp=j &`8)5%3 m,ˡ(APD~ˇ~"Qd_ 1.*c_]aB&y?*BƀO 8!I_g50h$JsEL/8aF ! O`=IcEf,TX?g[u|DtT貴2媷ħ`gCN6n. @ND@Zb&95t0k1GH !ijD$[vQL#C" mq_I- :\0^z >fU M+7V mcDPI>"b%Ә dxR!YH45oxڍ 8ף[2!#tA0~6 XWD_ATm`E- 6z ƉyldoR 3 <n &">,#$$5 Cqj19 pF ]yDW̤HɺON#6}샵wCGLwGy>^x5?л~$_!s_'HQ2l}KگS 3\c_N%rOsŝ6ye{+1:%Le%{s Y1+aвHdhkjPiߊ#BᜮFͫ2dEP83{{ m6nCkB=h:N\S97XfoZUQ 6 xayK`[ XŸY_FMZ)>)HJTIn2vv6؏aj&H8!MHkk @ϯ(Q3\<"lߖ68 `_q~A,aQ-Qy38h}T ZM)+GTs[f MȩJܝYUםD6:-UsE϶|$:סa'Q] $KG:AcCTJL 0HdOPYOI6dǠ4<|o' FA5g dD70T:T"̛temZ酪1MAxoKtIv Z\8Y-Xx_|owml1&״*g;{UZb]Omz$) f־K[EgI n\|Bm\5.aذ r3HrS2n Lh#4׎7/&$nzqmaτ)Jw I>"Rx_r.@>o!'o8DC]uz=|hpN 泹ѢSހu9nWfM91mw`'eQO8|LCiR_ݖ^&΀f㄰aګId}:k{9E|aQ)Sώ.vuv:?AɽZ]t.BZ5s2B[Y}w!g2\`ӳΒ?z,-րvY#KGZC9YLdjF십eőfu4hG@[xɗsC<^x},T&ܻ2}+ITvW ZK࿥ZاT,6\ \]}-H]-<~Kp0GGy A[TiH%&mU?Y\֠\gjko$?M5_.{0iOe .^@,/ b44sMlM\?{#jddaݱ;8RIDyNl{t(T~ bą8s]N/XYG" 'XDm/欇%9@fB+ {%abnMPl9+dr^$'#AѢNV MVL`u`<{ɞ:?p2yV2q2ʦdT~MB7"Ǧ/fY&D4\,V:SQ:.O^t_SZ5yG;S7־$BRܵ3b)v|3*i.5-|=?S^ 9 ">5*TZinl> 6rLn-&!(5Lj1[ЭPP";^MO5T{.H슪>(C&5Ch$)OH%qJ5yqv?껠:BBx%ѿQD4endstream endobj 338 0 obj << /Filter /FlateDecode /Length 4731 >> stream x\Ko$ 'Gw!IlZ5"k$06XW 6ۓs\ߜNq]Z; /FxzƹЃ˿A;gG\㵂k[rkᜐ0: x嵟17x=hi~B ?(Ǔ ti1.51QS `2:'2`/PcNkfУu7'jy`[~ rC5pV9V\QN cd:Po1N}ٴ͂븿h60: rPC$$@_U(xJ6zř[8? L  W drMߵ%׷aV*E4w :>"> o-TB+rhr͞d& >Qz>m`m|19iMGB(exM"l(φѷ?Frq&@'g\ JV|E܄URsI+*n'8 oLsfO֔\##G7*RZ|W/A<ؼ MhVs"(l6kϡ =~2 [l~2; ʫȼBLݜI'eR FV0yg/C _X#֨،o`q`Lq6?y$ܨG;r}AcvԽ`0< zE^pt}Y8~ )|[>'#mD!5b}@`@ۀƙ Œ@ab"1󸅿4 Ox wtwے|F Fr3|B{_39]B!yq'7VAzәF}[_YޞPc Bs_>@C=s^&2զH=\`/Adܵ!V(v7%*c)Qց/>U6 >3lCo;/JLdrSǫ,# ⒝!iawhC V m#/T?}3,ye+lr W9x=)~q% 󀀍O5_dKp o[ZKō=WCqv`95*rU ^GͪVp_GN (D!=).:{|ܽ3JCR%%Rm:S9 X?!#D}f P qu<8pl6wu)ܠv;uIVq;v.>jYͥj]`ԗ8ќ`e\ʙڀ$Ꚁu=T  NQB$y\%]̾-]X9QZQRcQ>cDf`VbRNZ!2W"zPxd{CS| 825 GHv>"^WS] "]'XJTTv&{7e`ƪ\5c恣%pO¸GR)6w020Va9x0PIC)t}Az`.ӧR)9(:TYD_bD9%{XXW!\$`a7h\2eLkJHoB^ qeg0oq4NNّ[.MV};E6Uc.+6x`uKs\z^h}y:kSX11[v=9&8!/'sCļ|@q* -kIm-$⊒T4-h"}Q uj&@<&o\RE1=R tѾNWqDEfx~SfN腘HJ{kTiv3_|LNۑXXCƔl )t~[S5N4U5˅X{J6ߴ<|h)Gma9h8nEC8(ކl8U8 p^5ĩC 垲!u_ v؎U -˜z]ç2O*(: 3Zޗ:?0tH ɡwHh6޽f߆'\& ڲv&+t@oY&G&+4C#`MD~Rʅ(B(\ٓ:e$*|B+*8rc|7u: nS>r0y% :Ǿ`-c 0=kHJK8$Y̔4KsL>Pz*ELN|OCYdH-GI9wS4/K7קJ~$YΗyy%cqPQ7%K,>87#(Dr &t@m`n15PE̚%+M`XhY0ʾ`*qWAy/ 9(iD$rsQ7 )[eQ|"EJArTX^m2߀Y(&QC(\0Wkzt}E)7ɾX4b>&iS$gݎVϻaf4k/P5j]#GW DֳNL94D@{ҳ;.i,dKI2qvendstream endobj 339 0 obj << /Filter /FlateDecode /Length 55148 >> stream xK5Ǒ%_q1!gGGӋ)@]oP Ecx)bkѿ}7,B7]"7ύp7sϏ==_WϷ=~۷?%W?~ /c_ߗrG+{Ͼ}[o~^cog֟˶~3:|?}|v=姟xO|p(AEG- k}E/#y9!O?IEyx\{uxirUg"Ώ_/0r?ⁿx9Cbnw~}Oy,Y~>~p!ӟ|s?l W vC\߸bA}:4E彦T&8ֲu0'Hhպyx_62M~#TAn4V(\ Bx4:WИw 3 ~LJw̞&Jbp繒 'P{~_߫7=J78x]+\yտU+tI9~9iη։o G|gŤc}c$eLR^a>x!+i\wo/~z~ҵ 2p u@]~j&YoP=幏+ ׿% wXş+ 娩z.zeg6+jaWa3|^ g[=`I }WQμN?_/O0]`} rR]LW&Q$:*iҒo=mIv|p)W 3o>Q$[bWBVУv΀<4s%g%8}= N4m>G O})~t:g0.}Yp !E/uiAW??&>ǖv3((ĆހߴG=gsޯu6?lb?.)v/rrR(_?ŇK?Ɇw{\=o..X1:(mG/NXq JJ?[{/~n(ׯ4;;v\F y`(h5<яw[K{QrHeҁ}Ƿo{[J[%dhQڎ[~cEK;T[ޗ0ZӪ|kʉ[OͿ{g`F\>(7 \Sﮞ<ΟB*9SxMGYiLɑ'X[^e?hnxG _V ;mݷʡ˛KEE8 鳇_?? c7W7붧w|UɰmWyJ }dg-K~˵ӻTvo__)!# _)S)rTd*vDp?u<ϐ0Qؑ{%hu&py\3~*Z- 8bK44; Ж+ŸDCᤖa d}$I2^pn;?~/ԃoRI}x>Fr+!\3J4kYћҁ~Nw(vMbSqPIǗʣ@L'e F s];x<;2CQ@ס#q<#aHG'MS)l6ʔ2gG)Cj06~FiZ! Fࡖi |{m3^ aH[4e9G'I 5aTt!w6愳$;-SBH?2%񂐬]ѕ2<h(b.(teJU=M"Rz{NuNӄ/~0NK<5i^ThzO<rOdbgh]6zF 1^ aH7ZTV|hBBP%ށͫfpyMá^17);3O+!@ʾĻ7mQL ʤMыvi¯Hi|vȔEsESH❵ACSd`EIz Nȳ&10Ư,JvPITl]Zӝ)(zN*!y_6(HxZ|_6CTBTCFcF/!C\bXT~OfꂺVvǰ<;4DIp@ Sgz4Č PQx<|E~!ݭH2w$:/d=E/Y 0IB>FE/}F~n/,[0aǔqX -k^\Q@wK< kIϊi fGMb\R>o'6 }L~@Aq%7JE2?2 n0LާBA\_y`-PI#k~cZ;92Y2uy-0H#,;p9{9zLST9)F(ĺ DݬmE3X01yhPeKV>x4bm*H+gqe4Ghۉi#k䔺']TI XrNl$HBp>ҍ%oT4\@gP)bD6X03?V7O6X(a,դsNck|vEԴ|If< 90҉rJ](?z}/CӋF!>6E}v&Pt+?\ f01q+ol}}dC鬏@XeB裥l1uCzhl9p*ĆY_0dDXCжӰtY : A5LJY0$XIt%9ѡGu! zd'!@wCBҘXc.1HYN)t*wfBtȎ s$MjQn:]#zlgzY{ 2CDY7(R*QIHHY/0|)N[,zT7 W$ѓ *x8#t/Y贶 D豜-rvUM")H-Tі@АO`eebl@MzuLѱC;,Ixrz`Sy>qY &C%NٛnLuCꌿ^S vNcЙ=^>]K s*SP$R"xd,4&9 E9*>uq{l}F?Wl.Uq{l]$Oe5hޑ 3[7j(,z"{a߹i#e"t Yف=JA8JG>eԋB]n8&NpMQqrO[MT8KI#dts _j_Z8GG h>Ӂh;9O[/( 'A=*6~Q@:D[j FS Ǚyj)lG7EB`#YCvΚ#CMooYT)G=iU,q&}O#(<`xR!$(<`]fJ=GLAo]4$*<`ιDJ&wZkNS ֧! /“] heQR`ݵH+Y^8: D]R!Ʌ`$.<`}syMM@,$֝ T>K O6X/(l#kI\88  >NGw) {kFʞ@z^R"JM8tub¹,S I'C]HJ-zsh~ aHN-~5PqkTj0 Q@7ƌNI^4W0 O2XO(Fwfھ$a`py eUW*oo4]q7i]+q*qVp.sh9[G3OX_( [2^uID5UǓ4֓! : _\# 4֕! 麻#O-R1HOXg(1!ZOэSð].g t% VO#~ec] IbYaQ)>J O7XG(_[+4]N O &%J;Q@cBSA]ɘ$,h"`>2znq癡$9 G2G'![5ל QUx:1D P9+Zu҃'ucC9BENJWS ֑! ɇj6tM]qer4ZפcO'I>*Թ ʹYۨpBV v193DTKSɁ YpNǓ4ƕ! 2MB˚fDhCwHqJ]J'FtJ9(zAcpl;[FsEc0(OX0a[vך&ɂE nШ'`pz"Tf5Itt _c7 O((f$t]&)%tM>qiv3 G)X'(1:TaPs@|¼Đ:1 Z$D*MpHH,(<`p;M@  ֙! hH? Z{% {Etݥ=8aG4h O/Xo(..$fC>QwݦITqfAQwDV%  \;g7"g1:2\&h+8ƣF)tsFj 6'kC&'1E"Kt?1~ A87GdRh9}6Ũ}]c.|Q=Ѳd %ds͈bew<Q@t?nrII82:$>1?hdq >R7 _F!tD&[o$<`.Tc$$<`xeZT#\C"p¼ҋL>Uylu!B\ !(7TosИ';CJi'?Cu+ղ4FIti&r` aHш(׶,ѳ0:3`Az & zkJ|bhCn+vH$!<* OX( gXKn ,ufr;TDC"[rԍudSRgO[?-:OX?0nM`ZZd? aHN߯j~¤IMgG9It} yPnwV`Dz3JUy F?L GCeT.EXi14Z ֟! LTk^1 O/X0$/ i zRd aH7P|=G]it}Z`VSuGC*dl*&Wh WPR47bbrkCrm;%ow>ÆK,yc=Ѭ‘&A c}"@\+3j~:3!OXw0$/y#T]D_@|5:!OXw0\qQ3Wm1!OXw01y>E~0e'q@Ͷl*FU{(C &:M“ ; h̄wdoGQ drh(*<`}TʚNrq^0A8gPmlbVRseJvԴlM'3CM&WY4cjINxZ4!ݜAƣ lzij> aHcF=T;>kTiCi+c@֤hd> 10 Ĩ8;)uiR;QyUW}m|Җn]2briC./Eo>OX zFNrr"ue$ȱ A86{_t%KAy :2|nGz~+J (DSF&E"4$DevmB&lRZ>aH7ՠl~^0. Gpf(/@TnO5 O)L  w8zf`"tZDubCeT}bTLn Q@αQZ蕤]%<`n2e '<`pl#~F[y5*QOxZardi5iJĠ$<`<pt(:>_! nh#( G' q;8o[CǡqRLaH׉t]&ǽˤ&`pnNUs ͉&-!dn\+olN~aHc!KJPъZ`^A8}] Tcb(t`=GU ɞRymtnbK#c,t`DEEmYUe{|l}n MڲkF6l<BP.qOe}L֭&[&zks@wC78uͶV5=aHcu4( :*6A8獮IZ;Ӂ٥catˍ)w\1=6Q@Cܜԝ00DO{,ln6ѲHz D]f'zp5h$i@A Z$I],g(ڣ_%4S~۵ch@b&:,QE3haa&sgB^8Gq O܊s= zf-hu0Q@aft2bTO4Q5=lD-D")n$\ջz7 {]O ﷔HY(DSHƠ# zg]nфqj$Aଓ@hL5Qef䅜tXc8%4έ$N/^=H: Ddp,`ą( P]̔ζP ^HȅY01}s7 ݰQឆ =aHc8AF9H !?[uw)#107%p\VچC#xbmn2$<]rH2XӃ(rڤVȉc<0Q@7ph$HD0ŷN7#nr$ F~z !]qH8anѢa 8 :ȩܴgD/uX0$AS8M&~qÚDC1|[2rhD0X(2ە*dֽRi(ƣk~tЮd[E9k~t-R/*qĚD zC7Yt^\aH7mc_EϺN fZ!gX2(e4e;4,FYM7r"(IM͂y+ )x{!,S00>·BS2a4ۋ Y0k~|A{ضƕ)x{!L;jF*Y)|{ !,ܖfct-UVR0o'6i ha[IJB"c%C8D/90E e5>ǐ;3c+^,cE9v0ED/90%5R˪fj%xIIяPXgy"mAi9+)zN*!+"Kx^ aHk|mSErpb?cW X,zrpbͿ3R#ځN>K)xN-!YS%}tdIpA#RӦe oh sR;\4(e_q,dsrdIh/ tQt~o]\=9vZ!Ѩ{/n ӸvR! FkR&2vR! i,>7p-W68kJha?xAҵKx"E {i e􍮳gxVo pn[bh~ PAҵZ`a/aS!H72Mڪ2gv (ڲm~(ky;P[/<ó{;Xt#ORTi|ó{3ZtCqB>Z"8gJ L-97ٛgLB*L ]^*]1gLv ȣX7)L,!)-HT|Nْ}CKߚ{a8 g(_'dhy4tOEߕWt,z3dn) ]k_8ه0ߧ|4i sߗM4]榱<D][i<*eۈ)yt7L>~?0BOIz$*c萲z?u &MUbo Gqw¹?:Xw~l3_߾-_AOo?AO8\GnT(o}~ #|{0ɕwp\0_8EBݲ?>?eڻtFa* X!4OѩQ{r~i~|%}js~HR?yfjc-Zm,OndRư[}dHzO/i <=U*~*_jZSàe Rasެ9O7{j>7yk\?"WTd!UGґh>|b,R$wDY5IpѽALzQn<ʕ$*c_(g,+[{ *;wYA&ٞШiw($[bQaHTěDH4FI;j_"@YƉ[̆%. rE!)WxL=+4cQ@7|Ex==gv` &^頗ʺ6gv Hg0#7l''=6{v.! : & 'J?Be-22Q6ϓ aH WWu_ A ȅ9ߚVWiTA"nwg9niMH=tVeX`hgtAjA1zz !Se5q(:2O/6fG3[揓fM;䕪7- A 뷃 GcP/8Z˂0$?jI/-ҋֲ IoKE+[CkX+'^(H>u ^0&Q@KKaY ! ր sЃ/{pna JtXl 4(Êd ދ֨ HaFȭYA5.<D.g$$67٫j;9{;!ʷWg]_٧prcZKE/`rkY$$QU&_zcȭ]Ai%祄c^Q@xZ*;lk)$D=se^taHh勆l!܋Z IRgc.$5ު'U xE.jX>9|B_Plnh˸C!{?ul$vн]rw.C Vw>GthID'UX+( KKOFE屒_C-{8McyYb 10VwۥL]-YÅ( \7vc&kt-v>,2gFj2hU~B #Ldi0wEKaaD8ѵjo#.I( xZGAffV} l=2G 甉VB[|OCZ0$]2MD둨/CTY̴Z0$RFFX1DiI>J~[JChG/`#TkY*˫|d]RCzLZ+0$-Ô0Z(6aPk#yD,x4Sn! 蕳'~-!v׎PMNڍ_CH씏7dWo&Y@BX95C'ۊL,15bKor!3zliDt@Y xMI,5h] ~<0.y$;uzh}4yÞod=?pNjև IE+ߊpn]F@2&%/ ;1egcJPs~1#̉a=} ~4^jLkR0ړЍF 'c>10Z:Η;Z32ҼG vm;9QGֽ Fwl 3ݣA>xC}=ʶQ@O!B#{=0PfFJ,Di"*ֲ1 Tꑥ5Z~$YE!9O=v aH*bSM3z\it6ъP'UXNu8Ӛ/hq Tj|1 !{yxLksƕb8 4u&Y !hD5(HLjxh}~_Z=޴aHȣꝋQu5ME.;[i BP.{:!aP&id\MA΍']u#9ݑ /E4i\9:ep+;Ѫmp;;Di!ǭfYPu5zeи,# F*b(b&E౽6CYhR"qGA.Amzlt[W( % FEgCG!ILT05sz=p;Z;0$o-uۥOLZS0$6R3"*ebeuCV.zwHF A8GѤ뚏|zqBu沸^31Ǧ֡ EO \b95rG֕ FXh4:!RDni_l:3z,j]4̡MmF9]KCmzcݙrA8Y: FR׺!U:h^Vn`=6G OnQ@7 PKd'7B yBt2.[!I%xz(D>N$'lf)YEZ5=O ݣμJ"uR[ YI|QLZz=(EC8{=5 !(3|M΄쑭5YѼWu8WQ 7Ƿd! I Eµ};Z0(_;lT$y䑕=5 Q@wՑq)D.ۻ+{;i A|X-;;8 "&idn'gKU,u== aH̖PSq= Q@7YƍF7!_s&UK~#k{lDph\5a}ph.dEVD6kt=tb#sϻ=.aHK<УY?@ FiBz8rCt! Hv*cjzr$C茩C0(> x+NT5jCQM'&ڙ( m?ĕnm1Dy !J̨N4cpd0/T1yqN !0Jy}3s.L~:l@݇Mώ&k@5W[{>kgḋVb&#c;Nkfp$%Fja\A۞wԺTɩQ@ZmӞ0$- K£S{k$!БÊ]iz;yvj Iaݍ xojc@pwvvمqZ;5U*=:%v I ZUFO!r6W=)T>HHF؉( -6Z`uEy0$턕y>b'u[lr#E @wy-kIE10$=g:gDʽ+.yb=kcaH[YiuOc5AI|!HZ´l-qR4lڷ0$ecn]*":gf H7 8"TւV=;caH5>hZ*r,hϖM2y.SOE?م7 47󚾦* fp&}AKZ+'*iG:Y7! IsvhuR77 IQ*ȯ,0 fA 'H58Φ)HKxFV xk^Z'c}|K||g}RUBWIN}ivzaeAаoTrz)3 G?v}M隝/Orw I"JWw~B8u)mc?-/.pR󖧟3my6-_W?~zMzp ޒ|ihdϾӯ ]jgO?{'|,zpPFH  {[ Ǝ7 hVsO}u;r?E'nU6_4O‚ OM{gObHrk`&osS+NF~ʎw\R7YMdK~b]{A!ӹSZ>]2~^ɘ>{|Oхuv)l AcES19Y-ݷHp!ߗ=4ZF/hዊc^?ŵeJ};J\]#3O0]qP =Nna?U3DSErSdG~*;xkF1V2a\n`JͺL9xѠ[A>*V+}xn>`A[ieWyh{%/ $^6Jwad ]"xxFC'w#Rd`bL/㌺%ZӁSˮ phM^iZ]40KW v=DΏрt,Uxlti3bdkJ!#iB+Ԝٛt@pӶMtܾc˙'Npj:|O.qnlagh+Ֆ9M79 I$&YgGmi-:zdQvt\-iݹB_KyItm(xi47&UӍ?YЛ Z`A>5*7Uf{l!ɣ2ӿN>.Nlo-ه0>|Eү GJ=$R\6cLuuXSi(Z\MhFC!jc4ϊ(A:η,ԓ7H*"&C!飲pJt&XES;uOE(qq H(Ŗ2ƽ(jFBu;V4ԅ lrV W}ٻ+CG-@.rnb1x;\Y!}8Efݎ!u3LiOb+ݸC  F³&tլk =C9Ǯtb#/Hs4Pꑝh+88vV! I(EQV#֭iϺsM;"}U% ɘE5侞o0NMLJ4E3%J= 4{v NIQ>RO4yg,iZ'XG 2p q*=O;Eb:?~T|Ğډ0$}TO瑱\=?zvb! /ZW]Xj[9Z%{O&~Y[OKUЙVk5^S aHNlOUuq'Kl #vN! ɑ{ʫ-ibG*>bٕ! c$"$K*YT>ec񂈝VCD#Nd9i=d p4^ aH7<*(XeDT "vZ! hX? D#+OkbIB hNUee j0u")xN+!]dZb5^ Q@=xJbEf[5}MtMWL Q@GikC.X8D/Պ4?i0Yu+Ka@)*z!i4]$AN/PQkXLQыx! IG}_VZ*%sggmSrBR-{EHvfNtcc^ aH:+oqoyL`t _O7EE/Y DBRv-KBN<-{-!]'&腻Z@J1HJf.*)}xsH>C´g K6g=TQL! w H _%@}UB12fGݓBSc g*7)Vc BDL%4XU8n/,[><% GfFOlmHsޯˢme;tģJDv4f;vڣmbPU3\Sr-TV @N r×[^p9l/[Ã0kռ|JjN<Q@n⥨Dz*#)b{Dujya/BН4褋M yCt@8ҋ?"AʰkԺR[c:Cvcִxc]?G=X,Q%|*=I\^N'wELⱆ5>CwET-08x#yjxc4@Ai"!'&b1Qx?5MS7D}6:F'z&f( !%$J[l#z4gcSn@_wMtpu'Sb%,ZH"%JzDg}.ۭIsvmG> z4g -ǙB1]>IRxBAx㼖nXta:c|ӥUƉ%9 =Q@UH>Y|i㺚w%]d)U{:n2c4uM Zm}< z\gtUlk܉ =3~Q@NIODq>OCYO(It4 ĄYG0[>[H)AzDg dM.^Ԙ'IK eM:~nze`m@ҰOtTǷHam@X/$X+tpuGvxٺ DuyN5od9ꉑ=Z6A8G?e{{MNВ=Nx=g UyAz>3g{|lkܩiH!d$4үݺƭ|3OC%[( z^),YGw {$>OtQuVED[0(ݏoqƙ=2.Q@7CvdUM|qCLO=lEu⵨b(38XEMT̫4Vwb#U;yp> A8.#,UWO֥! H޸*NՍ:  dnaH v|Ak .<`+o7!QHפ-<`ԛX8..:T MO)hA]88 a2zEQ#䃸qAdSm&mٰMGet3S[֤,~%O Ə! 躜uE `fdN A81:/ ϔO Ƌ! hl:xڟUk S 'C N2-+בj Ə! ?^^2lV aHW>iKzh@l8t #Ce1?ќtp> aH=圤%Em-7+OXw0E'Tui.sZ9{(}acp L&7Z6䏣nKCsoW<'o@>*·Nd?5TN O hً 辒,t3A\x \FˮeTptu1jA`:S=0x-kØ!-7Gis-37Kf]ii!Q)g NY(q" $ubCM鑓.>Q9B#fRbb`ݤӁ UGI'<`}*t=IucK%Mz ֕! 躆9#}mttiP$(<`n ]LJ/HS6Sb|ᑗduhC^,pt>N aH= .h`^ )'n[Cek$4mJҒQx85D݈&VJ <}c]!6AҤub@^Q@b^2.znl>Q@>_wtFqauQ^b]R vz`slQ@ק~aKk1j O8(a'ǵ$! ?S[Acp0>Q@2]:qL,<0-8$#hܓucJmi"+<`]@._ľjAUx2D JCӾ#ړqfSS;mw$hm7 G,XW ^ȅu3XEkRZ Q@coF]rxT\ aHW.҉fNL+5Smzj}s-5cS7N6֙! ۨ.$@I–䠑Z;jOXg(S)7mgIx3!Q?e͚dᤀX( ̶jIcxº4!]ZilDh[[/A'GCwSW$G=feo'GCҟXѤ)ndֺBYZL> Q@G7Dx^uC1N Q@;ץ^v=e6i!GX(]&Z%жt 'tKCR|$~].he$ aH׍6tX 䟲u@h|ODN2[ x$9 ODXo07mpi>4C>J_9W#"@N?/kDHuP+GG)'tӕ2TDA!-d&)yE!H7ҝ׉{fh Q&E;kO֝! riwje”EfCr{)%J8 O@X0a;| ν5έ&)[ YHJ 6*uG[Z d~ aH}\vq8zoMa9vix/F( 砐j(GGSjj{I y::5!]{A~ˁ&1)tSNųVNb:֫! r]B2{^kRF y:4!9D(8!OX( qHB^=!OXW0 J}Xԣ%Fh)t}t`"FhIgx"º ![:;Z1 3mg;* OEX_01sRz&+sݧᛐ44.993 O@XO( MJ?G[t*S D;j ]}d rcV. Q@ FOY!NyQex º4!]Ӷ:2<a]tTd:Afx:5Dp5*@/"jDozIex:5!]/LR>aHC&ٌ]l{"#c(t@lK)rwl@ҵ7Օ,'8: !9k&M:f.&/}쉶J6A87)G iTAf-'xVB3_ +Ƴ,Rw$l@aZnky58u^N10ky=d33I iXks~kRZR;QCM &'WJRee=71O idz6ǵ>@ =6aHCÍsV3U7qCW g,tZ-vA02r 5 lY}У:k~䝼nFYُl1>>I(G)Z0t )LvԵC/cI}xFGj;GtK Fےe!>GrC {JRpL=/'&h!9d3* =3NQ@rtWJ]̃Y0) )УQ e8٢nɖnf.}YI#8kxt]|$9PJ}@߬ACz8/WLl<=Q@Q'Vԟze$AAP!]wr cm-3/} }ȱ"/wX0${ b&AEFb;AuFDF05>sҩڅT6)D;O]<昵- ih`tV'1aBP0kW^@7G Isx|jc5W2MI1<nSUB/z? zP-b]Q@C➍4i}GnwFrqD'\ EVغ^E<;P~EP%¢BPG5#yqitAo];7fpzes=?}{qe1D/Yۃ0 -61"z!%);Y"L! wvV! zQ`[Th ^s 10NM6P3jW!za(!]7oPqc(œP[)V9E&-P9;I~+b˚&0;tӋrp˚/ة05u+MPHㅑJR/ =wϯnoY^\چHBʵ 1F*|2F/)0+Geth6,"E|BKC aX`4/Ls 107!ʐxE;O.UIy; *+73tK-<qDyAI;|5Á:czNi A5o\[pu=tBǔ깨5(4 !(QzЂiQZ9vF! 貁F 7@#Qq=CQ@7zU69{29cv 6$'<7Q@vAњފ!M/W}39XZ>i#\6iȶVۧ `Aе3%Õ NY+NNьբd&Lގ!z K^WV]~ؼ.iFw;atS4晒}Cl=( *Xy4{"n?y!,~:&ho-т0e:VVQ[yd v+)^hm%g0¹z:*KуzcP՝K gЙmTxk˰65^xv>oj3@ҍϣޢ5jy3cb`OjhBqyc%OW%+'K4yC c=$щq߅byp$Aw˥K7xmJUKۚq{ptSiSݵ7XЁGK溔g =<}[ſM˃W~'xK%=>=>WO?3rw=ڔw绯 {[ _K~|zidyaG+KZD |i~Gj\Uo|i~|k.526\`H‰LmX|i~w\'tT:8Áv>wRZO%>I?=)e[#?N0(b(TV xW+z|O/+mmwE}R}RHqPӺ`CiYBK}˿mO++W`+ v gb-_oRRAMyZ>IZ˷ɥvCGs;f=0PQ 8¿t_&X9J;#hjq?]ƽ3%SpZg%f&^YHe+<4[+ Vy_gRI ?P{K[iB2-9 _coH'0$|GM܊2XYd ^ aL pݒ v+G m>xmAy,$}v8\ߌ+a-y!N 낹.PO+q2#7MQ_Mk6|ҍc1ϣ3G r͑H, ~+i>!]2%|5Ɵfћ+' 2%0ee&&{U1_LC10D52\ljّ0'H9y@lͳ#40givRǢ{R()7Zb!@ D%UgsLx|䏓nSζّ(dL&=fd5bHA ط tWυB6t;NΔߪm=;}]-qt44yLL`AoI2mǒ'?}7YUH"[/IH۔h|/W -#"iH7G*$KҲ"x?Zw]B 5EH g~ fꐊ-T]vFRD K=>ꥉ4.[&$Dz0 MpGhlLX5mH4EOM'_ذ.QiHJy+:Jep_L>AЍ\WKlo4aD@&./pDg3?^Tf|U&D[!"YPz]u90>z8r+ߕ(C8cxb=HC2iY5 %  gJx#aN&DHVvI]u=_߅AnOHC҆oSFI)'Ne$,K fyG5 hQ,袀95٣.TmG.MQ0 q&t<76-M(E8Hzƣ< (.sz̗ٵ'/㰉,`At! AdIsdIT8Wccb3?s^7a,X^`A<~!/I]³QPO6v~8~OϷgRF1'L@9OHC CrJ)>\(y@B}H9H.S"!_a#}F6FҐ%Q*׭Nm85iY@+&9c"t$u۳dj7:+'?\°!݄x $yXaO/]}sA8({@< M3L"뱥g5MK2V\mM @iH󝜍 9({@|Ln+qkbg d#.{OD?4A {@МFtixl": Ŏ!#bT@{7: Ğ47N ) 1: Ş!=+ )T.p"'R04̺4êȥr^V֣ʉ!ui*ss%ȇH~u-2ln4!EY}cJ.mӭpD dwwF9z B[ rJȣrT' ! E0!vQ F]k=gHC&> }_>''" iH}L;Oq\荦D4!mV0@]W-2ȌHCxNC\4y:˽Έ4'5!#՝b 417*,! ikq~䤱)b$Q$wEQ"͐t9:S&٘U fHC)fl7G+OJ(R9͐/D=E[ʔAEǓiU6^)5(7ϐtIgP2(8Аs#*LU4"(8ϐʇcbꮄ/uMd,EEœ 0" (t⨤tڮo^HH6x@|1+SKʖQxpT$*YU6IJQ]DҐZC;ytG[@xJC|ArUSM뱜tRӮ޽0ZXRCMnA!5rG9IOj,G&hGuQBq,~Brw\&:(8ѐt twJw# 90Sxv-edP$qrK! HiiHs})l:b&ZGҐn<z:huY Fg!i lu=W iȉN_cvR\ 'ec' dm( {@MG6!({@Ѝ^>Eh >{@ 4׃/xK(~@̍Vn;c°!jtL!|a: žt7M߯^8nQ4y_$ߪ괙PaO!d\&PGA3uuΎj[(E8o4{w Ґnb'F-EВc7? EϬ_`A$~-M"y*60g*HKߋNHsim1F1n$赈E ( iHJ &OQs ,.&F1Rpnb'Zz?0A0p%t#GŒvY@7sm8Gb`AЍ;+5C*7a0 q i>" E ?(y 4kp]P:gtcyI!ʅ1Aě dUަqe<3^LBBMxڊqݤ 3AI87{[gc!$'e< tLA& V sn(*'LB !!D[ȧuea0QY@7 inIvo}t#.Ii"L=AЍRK14DNc‡3@ Պ9\ST^"L=BMd*SKwos#pg01& in(p(yeoDZ.N.\?HAkz7EGOdxzq_ƕ{UzLt>2;~$AzБVY@7NO,c]t~A̍D;K#>ӑ>ݗ^xΑY@sP #mҐn,CZC٨P`pϑY@թ#(C1eЁu907"t`]=HCk,^^A0`VBy&r`n"wKԈ.0.p^~ /RFðj>qpQZ7Sn"J~;&y/gft,G0.^ Ixpxڕ.O!dDlG"Ґnfb/X损 Byvql{od\] BMbH~"OgҐn %bHхO $,W\͎iɁ+"?'Ґ(ӋPD"6r_ ;)F9$ehAFZV4f̺j'*\lTP*ͺHCqB":"L#v?$Ec -#uu$TyV[\?ñ# jy@CF^\.2۟>,o_?}賸>x'H]VoۧLJ~?'| z^6W~TEVOWo(w|ϷC#>?~\JTחd8_;EROq>BҪZXҧU٫8!ש={xΏEhiBh?북|u"փLuF]]W1o|iizu߾~wrqlU¶_FJ,qP"sZnOw: o'ץSjY*7kg5d߫T} ⲫ*+|'wrT^jSaSsSqw-CuPLIM,*Yl\~۬d;g"wT7Z WS+D.*Q9Զ]\0-p",x|aV 9u[$R|d[2Z^)kfm];:+Vz 8+ ʕZ{ ,3^Vd!xGu4 Z NJ`뤲8+fҐQɺ7i |(M/~o#J?! O>)F7EҐdEyq03b8+D!yhD4ғ_00w3,4Jl+ V]E6 Ґg+U—>~8Ê?! 1I\zȚ[`JDOE݌Υ*Aj2iEG Ґ3Y5p@4=uKTOW\ _kFƙ4*+*mm.DG ҐQ=. nNei8/9Wo_d' i:(.WE2 "iHQAR ߯jDZٽ. 7}e|lTl-HCyE%xpquc/ ߏ!zM@6sݸR{,tQt70W*Ӧs4S iHSձD4zKFGS iHWd/ #㈣~b! hZ½RbqDQ?X4ҋQƕVs,F FB/ԓ  GrQN {^ W OXӖ9BM4kjAK~Z! {٭3 ޒl'ҐnƷ+g>9/5m$Bt [.g941x ' ­Tγ^+d-m4QZPќ+[Y"Q騁hEf?G}јlJ3B8ԣMSfJ3BR5'N,t]p5q Y@ue0ȇ9d6oW$u1 iHsl:*ٍjt1 iH7؞~MCl|R^ElfVHܪ8Rqpʱ񅑣\q8~; i> 'g?{qiHLg=]G !ݿ7<7@qj1$Pj-!}7 *?w#Wq}% h@'OT^K;Aןo@A.Q;lLBKUJ)[CHAtͦ*r_6Xd,? Ht) *%m›d#9ʦccb vwn9J290wJE.u^G^1 'J iz Bg=%EA[dR0\U> {I2a/ i inG8`-R^МA]N</g i~hsQov6EѬR\vu}c!cN2\`8<<5 f~Ui6EҐfm&yj@ (4N羋C!E3r`0TqP6E6D3 H™̭{AUdv]%DzL^dVzi|EI8$B$DM#GPcPe$D^=)(=s%*!20 oӻƽf8 4߆;99&)8u"CՍ!eL_tɝQz\G 9Ɛ{_.$GҐ'mEߛؘ\CHA)8컔x94LDA!.GQRPfuԯ-٦uںVTDsҐ(ղn3J@8x@΍8*%&ydF[Df4[L'DC1wOo띷1͆I1" ϐ^*)T AFVDҐU2|\=H3xBCҰ =ھ !gKYzi#-"( Y@VJ.3>hH7xJC\lcN.bă'5!u_F&ˮ*d͹׵]_5e5!pPJpXz%lB,FxA6_ufTB$ig;yۘD3d\:.>f<ʠHx>C|fGa=2B(9ϐtV);viY@m=Q'1Fl%F uB5$EE(R7$4Ndh\++"iiH"B^" &7wo }m]{8aG ByE$C|AG׮*1.^teT?d,hҒhkHH86CiJ`<'+")iH-EYhGȁҫ+mv&FVDSҐdB5ƴ&(,"YiHCB^ʌ$*quEeFEҐf~ǐ@N\&ǫ2J}޽ԶEcWd@xv@Ѝ⤣3iuE<; i!EoI!GYIHCUs%?h3" !,BI-ysSiE$ Q fH',Ep" (t#GP=0PitEC32nVG>Th" ѐ4dX n'3!Y_#(MeE  ǏW?᳋Hk1DQҐˊ<\BHC9 ,h#MEBl|Y0Ě(x,EhS#nDeL4(x,nMup5QY@7"j?t Ej0Ґ(g_cMGANQAW>}MM>YrľEeg~4?/;WSZh9e7sS}!~FkG)!MJ/z >;rV/drC]rߺ{Ã4HzQv1z%{4@={ѲNݏ7n;r Kj*<){$WEҙkƷާvA>$wWy_vP-ZԸ{˃$eI0m>ܱMHp}GTzõ uב+ Y@u~I,8 49q͟sS I87^b'98?4au St`ㆀ.=K)W *{94wtY@8#ع Q}879974\{%w2Nos 90SgZE/&;ȿ,6)S6HVq{ I8C^&\6 D"E'$L'hcjv, iH{ݮtń_`K:ܜBЍSagѺT-oK9lђ*@Q4Rtr;Ѳqu0s 90,zQUЋl%~B! hh{;n<܇PHC#|'cÀi Qȁ{3&f/ iHuIo_tLz qDP?^jwR=lj(,o81Pa$Gd~ iN*̱#2|=` RQuP&L(f4܈!pJP܈!ݬIIٖŐ#|?^4ר'jͬ,ߏ!DU\pS"gŒ7\dN hR2MZ\dMz#io~?yi1Z[dI~ Dqscj4+n"S?$Le4*ƕn۴;0,|? C`ɋ&EZSn쓶.魩*0}g,)ڌ$) f=$܌lX7q\6 ndƑ ^?d݌.IQ F2AQⲽC}.҆sol{º%ʋJ#֯>뇺^D;33k~УOoF>?_nl{|R~-Q.o_}BҖ]rP%Ԋq1(-oG|Ш ׫\ ]}|huJI\j׃_?E X~ɟ2{gOmBV[m;9鲿<{zΟʝ f~ʏn 8FJf~Or#[c3cOG餳dL9 ϛϟy:SS Lᘬr4ti+:)$^n6^H;]Ny8;*u@?ȿjϦ?H[>_CцaӫI}59)>.Dy?ָEu8>&rZb=Ig`$} l%Oz5LŢs<fsVZkTjb[6aS;Vtd7u`/\U~㮉d=)wۀG pʠQ4\L:RC.)jz㕥K4  'xL-6AVi&zFM#@A)Q\Ъ#@PТYkϻhEU617 f1V#69sOu%b|NyPZ0ZNv iH7_pRY`f1"4Ս EőhF5Y<4lE#-zϳ>Z ;^tc$9yڴ-ȞxAV)/7T?!AN%ȞFM`诮[e!MSm9Zɏ!j9Ys5T"{iH򨕳rVUq2{óT]'jtȕl`-HCU6]pWkY}+Mtu, mEd~ Imd%^"2y?Zt^+oܭ]hsx/HC!*裺/HCYͮ/Wt`Fd!}܅ N>)JHXآq|X[ԦǻD;3=7Gt>8"QHC_`\7Q#lڛMh FL=$r7*<.i+XA<( R*F"*-C݀fj-O4q$d+(Cވ~R! hzSA뚇#oDL?KMz⣺ca6߀~V! hJe^;{GL+d{;!R4leS??4͇ЩD(duwytjm'WN\zȅW*q&!&ʢT>w1ץ!Uf:4QuD.M+$qt! )D69F'y?4LTL]7?މS֢M,\+l^&r!~V! Hvf :t}fhMh"/gҐ9ҕxRݍne6.S逘@F1+!2)FCu)qk.q@Bڼ3 V?mpϴptD[wJԕt4a|B܉v7\NHCR7ʹ#>6vda|BM$Wbf!1#o􅑟 iH:hK!FO\λ񅑟 iHx{*c7((qZ. /\k咶eys1 ǓV ¯7\3AH X,R"dY/0u! ) .ύ;P.$Ea. ޷m,Ґ+{aWC.; fU4hQtx+;ۃ$^큦A mBہSvI8:Ǯ"rqU{bqۑK6 90:5CMG3*ÎNHC߶D #gޮ4!4Tizt؁7Y@*Hޤ/M6}#GMҐ"FR6I%;yvk.ō>HC&Ԯkrב;iH +2w1rPxdo~fbd=רz6|U9~uڑGI8czFz耗ZvFZ4 Gz!󢝿rt8D=ALKۗjyLmK:AМq K6%m7?}}PW>e{dѵG~į7D(t8@H>H"ee(xx4$S滔O軷Tj'jtI& ! i9-f*ײƄ(tx4N%i/_ZEon] +P9݃bL@BЬ^./NRgBL>AҴIe_sÈqQ& "! )9J6Nxz@osP32ę( Hp&! #ߋXy}I"MES 'ppqJhm UEVle5C#n#w\maQ44$}PfхWD|U:(y@дl{;{p:o4.t*b,};o4-Ҩ;8[P-pzn񒛵=% c8b?H¹ @ykp0 tm9HK硫Ql%k:4A,,Y' cUQ2L4B!J^3IZ5FrK]c,IDFV9[fZU(9@T;{II6F1SҐG;Saҩ(y@;]LRc.dh7xeKr $ᨑ6Cc'1PyiH7/=[6E: Ş(t^@/xbȁ~^ϊ/:Ş#4'R/1:\5yC]tCgۛ8?R _4({@<'72w|K;({@>2v*l"&$w^#v-G L uAs9nPaH/_<|"_Q ܀,.$^N&!1*iHs_SVcd KLx"d6^%kE l)("YW9>á5 uQ 4Jw .zMIY@݇νS٨4a:$4/UwCqj6 Qnq[<K4w?E/dl]U P?WBCPew/}Pi謺Cd$E$GMZaOg_Y&N8٩" ̐tso,4y :˧F-"!Gj č4$KQ> ;JPnčc dуX,rF|!ˊcPϲR{=Ġ#Y@U^?f>H 8*@ Je,ۦfOHC rb%Ya7N?DҐ7v;TфhZRGHHx@Jw*-DO`HaY"m`˝tɩUCYiiHC݁tѧ:r8 HxCR\jsEJ]40!ޑ{bQk6~L Xl85iNO]u^1v|TnX!\HCYWlorUR6,s*`y` Y@nJ c[ugM\ئ-^5Ck!\WjGE/Drp.eU؉b$W1k.?KYHC54"vtLR\D­!͏.4CM_rp=) 9"΅;Q4$a5.'Eĉ11֓pՓVëpaQ?IF~MAd,^uJ 2|b'Nn !8 tw<61 Y!8 ts#QpY(:v@ |,̚UkY@\D2Զt7 stiUV>(z&@a!choX hOnHzqҦ("@MiQ,$4$ţ|pphI8zdoSV^HW%A6VM5!tEado,7\1+Kު Il⊬1Td3ԥx2):S_#lqٸ@E(x;4~߾tY`O%$SdLQqfI8w;ݹaڮ x,k Z":.e PXzzjG>[ $LdFc]2uwN[!m^eiiH^9`h'C.$h6fD*\`||保AAPM |S {4ooQtczϦ/h);"#G!zVhL#O ԗBN#_p$ewɣ<HC~41'q!\7SNA¸zc, =ztI8D^oTKa_vg5~2| ~g~*c(#/m ҐPR'ޮކx z4$Mh'#m RPi!ܷi=%tTFB%#gҐdW6)6nb HZ9t;w]~?/$ P5'r-~^ Ib%_$ E-sPU 7HCB#xfaxȕxkQqؕ0D !~|[MI@NZ: \HAS[b02Y/&"~N I<okTi"/Ґd.NrF*]@xmŹEEetDY?1$6k2ifH:./RY=1uf鈯~^ 险^:t#ȁۥ֮ޖxduX?+$@xX\DgҐdv)o+#y, ݇99s+ `uX?/p&݆ Mkq dr e d idP uy$s2KҐw"~Vp'Ґd0;r("x١:c Q@?K^쩝q#I8zy /r?b@1qjh%14$]bh5Et'"=GHC^ld~ IfHC&s/ihA** z=g23kT)HnX743>HCz#/ 23>HC(5k۲뮩y}liLA_J+T}4h=S_q~!=oޖo?Dഉte߸=>`\㯮i~,\ݢ6%:Շ+[s Wl:̟G۟>,oߖ?}7Ȭe{| (3ݖx?}OI~5ţ!)02e(X?7뇯.}5_籽~Wq]jzܸ|/}Ys~':uTKTO/?'mYvFmy_oO? I!Gؖ?M>qYwO)?}гY>OXv?_vǯh o5_ϯyOKBxe8>?s\J} ß*cç{jS?nvy|38k4?|oc¯E#U({_~ˏ;0\&cBn3|~ᳱ|0ӷ*y}@&tv4)N3qܨ[4>7e{Bn?[3iLOgR E}tweGѯ~˯qRZ޿A^_ڰ'TE5^ISDr X?UqѸy@_\svendstream endobj 340 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2354 >> stream x]ViTTG=[n" .G% FQQQ M#`1F. Ȣ(L"*jC4Q'.gK2q}=əzd~9ݺUn3Hf1K%m9`!Dojɱ%vSl {m ?,fv`ظTEAFv3axwͪ_4)GjG'tщuR4)4OZMIMK_*32*:fAlܢ :Q'h"h DNh1Z yS"_49h"G<4Y>)pQ"Y0g,<-R-NYܱcyC6A&(wo_b].r~oRt]<%6 F)o_9}sUkὂ̏T)= g gC1h,C<+OG}ALϗ :%3D.ns 5sYϫWzni`Es1?kLOyv^~Ϟ؍& 9zfCa! mvf)=yԗ$Hqw(zOH-=S0́@6qN{G  6o\8"W{Ù+``.V7ܠ{i:pab{*Xk`Zhpqh!lvby2tXLHWWdςiAsJrp:jLU΍;7l!oo˚jjv]*snPTm?\[j8R7 s0hH[;LښmUOu[|L54#Kѕ!iGܕ]U<'5G}KM*岹4B;3ę%IMDdBS\auv0FrzSEh$kdd:hsd#7#+_)LJ(V )59 q$3\س|ǁ\uz9i2cη`}_xped脩aޡNVW^(Qlo,zkٶ'7Tt֝LS$ I#0} ejL82ݽҶ=C;:G7Nٺ9|CyuL9&/ᡄ>Miqr2z-3P9qc!)ZUm.+ xߎe5W!٨ Y-$V#a= r8PNvF>#'; |tR5f1Zu#eM[| ̛9[eKoFdW 2iٽ2C<=TU'-#VA_p1űاǺCf< @o J^#kQ-O.+Xx4_^3Fʣ=Xkiiޖ]לnkb~:Vv>0%U=U[;$HRXpG;UMnDdWi=+&n$k #<a@8ڃS~h}^$P?dOB}Egʋ[1gyBGNlԝ̺Ez7FMQ%<*ZF7<}yz$5d ;At#59iêlϓq -1Gؽk*)&1j"II`{8k 0Zn7pkW{ _Xװ.lMMѰsS|SE83e|i1 U3<¤Iu2JHjf|_DA|!@< I@FwQ(tꤳan_5QS,f*/6_l>"&εkі{=2AД՚sKa:ȵa4.d%WmUt?g5j5XbpT7ο; *^- p t;oɪys)ȇzT>rsuimn\p``#f{d;8V]&ЎaOę8Mr'.d~l<{p)dg̼d/KpK} )J2p q^.{g)RkWYÂmPT\TT^X\\ThmU{Wᶒ~ 7endstream endobj 341 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /Filter /DCTDecode /Height 386 /Subtype /Image /Width 644 /Length 23645 >> stream AdobedC    %,'..+'+*17F;14B4*+=S>BHJNON/;V\UL[FMNKC $$K2+2KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?Z( ( ( ( ( ( ( ( ( ( ( ( ( ( ( )"'e_P]ҠȓQV;|'hFÓźDlW,Xp"np3G5Heu9|JCEsX$ bs}Ү?1IT.>ه+f@xi~ 1.OP\O3^P2I86$dI?Ljv\I4Ni&s~5BGe%?繠ZEFط/+c?\b F|U'nWn qgEL11N8ƭ+Ŷt..F ی~'Mծu J7}G4$X8ں9.Xnxǽe\il2 ީ2X;xNUigZ'OĺzyS< 8q[Z}wG\r;Si"C+ ak7TW쯉Pd8$qUt[`~AO=^' ≱c8Q^y'IlXn/e9@`N;rWEo-)˧a^}::*k.[Mў5QEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQE△|GhwLE"]Z6_ `,psTZ#Bq3/sf 5%iIdYd ZݷtZ}r?=CR5УķiAXbw ~H,N+0a I"?J~(MW]D+fkק94ƛ #r&}> |`Q?ұift<QD5K O S&_:6f>g3@ iJ2W$Tk1/9ykFP[R' E"{yGw/ZˏM$5Ƴr͞V(DRM;cq%J?+VΨ2{P(4]2>+ ~jfd υ#VsH@ 2 ]Xeͅ۝lncm8H9$GZ2D9dr0|OiWiwKo pK>fqBDYD}Nֵz IdTM@QԱ*8o.2 <ԴNQxEY#d`Y[c]# ga'LvL~~Zn幕Uبܤ)++HK㔫m@0v jk;;Ot"\xs~$G[Mx %N[`*^4˫AK\gMI$cs$FOr8DAh-)&MJ8d?ܬ]^@u 28WjV"Š()(hڥȗwp$f i~e0~u\-u "IB}>o4sVhNmPq})fubAf+k|,⻴ݾZs^ǀ ꏆf}@$]΄>8`(`"(P?@Eg GBE J&LDʐs\vLtU3kpc$UQPiG}JPS|Ʀw*]^4rIی4-rhsiOo+CˬUSH6kes 87S hQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQE!6/vٕ^y܍2ج_~GI^NA㿷[B Xz7.c2EȘ FXt?nV~9tOf?8Y睶DBqsSEy%Qϰy"IEPEP\nR8#V˜m =Gj5[Ĝޚ0uɞ0ïQڮV%es‘?ն䭨K6{a$(A_k"Ck;\)0I],qE VT\ܞ۹;jcT[K9@=VȁC c}1sY0\]ǹBno^jD[wu$zRcrԴeAr#\`{itA'qJ紭xLccNGH]ݑʄ2_mi]\[DՇ._K!ybW!!_~IelWZgXHR7'~~52R.U1ЬtN[(\TgR}2x\뎟kxe\mo5Y - v5&|BQZ+$?,l6k/A׮,8d`ֲȱ6ARx ?H !lc=Ecn"*<#9QRo{~Oh+[c_[C6]~eJce-i;2Pp~^ҷPծ#I;iz&G,…tVf ԮYϕg0,ś+R[Zt,fΟvki_9$~tA2CXF+o5ϗ Ofc3ш֥3\&FJ8OĚkْmm`SasXkV-T:X|F2@~t%-WP6\N{qEZ)<HܿLIV }SH!Z7 | xX+)tt-0]{|'mn~%iw0Xhdm1s@.rIl9<HȬ靬W%sak}\ r;Ǒ]s<_Wz%#JZ((((((((((((((((((( 6tZ-ccۥi[&9GGPMm0sFѸ# hVfCŌ#} Z$g%۸[s쎬AZK[4{cǙ%*@;)j8̅ IHDW1<Дy cIRG?=S 98+ZX#e?PhJZm 2K  F]89-!84n=vMtXd E>Z[I08 gGZ6υNX*/GWqE$S\Ljf#T -Z/yYr̮U+'>.C2 i.O|t"E[=R^R\2cXɫDCq@̎ב˪F]\t.mkv;HC/.у{[wW,TWWZ[q;%.{2M6Q,fYճ'8ϡM0y <),L92AiO$9!qQgL` Z+o.y_+3eS(힦ػ`n8Q@Q@cj+ψw[v 1Jجk'6q6F1"~TEP])f8d|N|׳.ٯyyrpSf $~P i#[ ;-`G_(Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@kAsؖ$t\|\}3۬\}|pWC5KmSXnRCKAC@Nc)9& p0PkBUi"cngO5+BcERZ v 4IwM&ࠝS=*Mr6ǎrsע5qInIʳrqi8w [sPcW u{:C7'%c:S %cA՘?:v,s,fclwgfξe @;zk(rq?~uw3k@@bNk:׆[mUX8`2xUIY#Rn8K TOqOjֵ>[9Ll d+qQz-f7p σ}[ +IᷳD>iP;wJE5$Gpv8b2;s=BHnV;w*z뎼`&kZK~EL3q(n-K OMgV.%Ԍg|54/0w' c*YxN[==AgoR}iϩ7V%۸a[##h*ї봜$ķ,{VL7'Qug튷yamx0V'! Ws֩$pԫ)KWX=Dq[8+ϵ]A%l@^={WE[ԒBr]k{d@p2~As7Vav<S8f}'?ҟPIQD`2=g[[xG Ƹ߇?벫gu?QH((( c^<\]IpOKL{mU?[ZGCe#*M.t6V] ( h~k+̨2T+>㛩%,-R 9v|@QE0 ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ϵ֬.+6 ז(T鞢+R`G@?b<u@VXAy?-\ qW눵Q$Сǃ;!}Wo@akٷtk2n: [ؓȊX/+O&ܨk 2 VhRT0fiRӜcТ7cW>DzQđ!eJ*T*[HMWC)fhQvKHXg"Idp#pGN'bjRSJbNr5e]pdUWN'Q8j4*9Y[6MB8r-19 ~,HdG`+#TSu;W3\J+WJ*ڪO$q_Z+|$i@y8#*-GXklDZjI#Gj sҰ^yj\#9 [B$L?7?E+1Icf\/lgb2RkF ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( &\w_Jd"\ˁ+Pj^!͇'$NϷD.ۦ77%}}]%-^ucqn"h"R.-?QZ!}NEEXP\lh8#s0}«r?3BZνsU%=)̀ #2Im@ޤ~zqҜf\jOeo<Z۩KbkhRcUf^?J,e U~x]Co1 )nݎ? nv>$t=) :;T|GvT *'18Ɲ"|`:d kHaI\VƸ冝mAH5+Ҁ:KEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQERR@Κgo~oe*"T|YmSHVLٽAᶅ$W*8ީky5m+˦M$#mֺ6mјk6 .#at*~B7, pmфe.e"#i48kء- Ԗr @#v<=iMiXI)ٚ*2zUMNNsR}ėޓFLQw==SMt[p錐` gjq*J>dRiKA1[jc<3 쎃jZ71b,szYaĥ.qqCјGNH#nARymcN =3\%71ڇ)F5@M[czKQ2G2M%ögP})|>'?LIrPO:ج˙K8) pO ݁UHT=ҢS[ݱ+? `?vl((EQ@Q@gx鬴KX܌(ȭe]2nsx ƀ4-`[kh E5x9]WTMw$+@t^GZ v{vH(Xc ?@j? Y .ݱsZjQE((((((((((((((((((((dE^x^}g&Prnnnu>qPhW+{̼3QER慙C,cx۾u2?Z\ >a%\j4I6Xl Xԝt;X@coaoUsUx4=klBxҺX$YI 楮ҫιH 3{} MJYs$ FYԚO۳$\`ް{/Ev5p}ׁI횓'q%A޺檱&F/=k26Ļl};f@b[prf\;͒Óի9TĊ'J MGsҥpa I'<޽$,ޅ)q<f@ۈ=*1K`ϭRg &eힾ4-'@ FAi)PG#9 aUiCA ,W'}𱓆$=q溭;(_83QI9lq]ٸR;LAc2^_,PD ǀ 96V9FRܱPxsOwܧs5[Ace a "U iQivE.κy?lsiTTɰɦ,ʘ,ZnE% Y=6tl$lyQl@7ܸmC].̩ cFLrW n}}3u4H F$w:U+H:ncq-)]FTھvZ A|"<-Y~YN8<"!PTɨσ7W.f}3Ҡ$8 JKbkl'ꌪ;l'M"mAsI:Ztd]jycTlxjuWkH`br9AmGb2׭#9+;i)}OBqKRv8]Sqַ-t>체"cgR+ ~Q<ʦ*j\g~ui#rm6hR"A+ȭqXH$Sg8 %+DZ FG`u&KQ{c;ϛo$A9̭'wqZ)I%'T۟dnQ!'c~c렳%#׸fc*Vy1YMjʒEo"ѷH!qjP1r@TVu %!9 :]@A70(3F g'=/Htu p? t{hp9vh8W8 sTMkaom GjCK}kOK;csF+v9D%MB^2$tl{0mSQIx3ԭ8nBޖP0cr;sVg:- c)xBOlU{N{P[ FșFT}5闉{iaԬաV?tұ4z#mݸ8xiyvWGKhppyV#dz ÈO?Jm㑊4p|N<}*JQ6A&<ͻ#VC:-QAF^~{)_TK!Ԋ?uؗ~em~d ( jLvHvw GԊ+7LUU5Ԭ}?*bQ@{ }%-QEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEOW^uDOcRʚE閷(rD>棺j,qYcV*&%rl b;;?chnh XqUt6kRWK]cFrOqqsrV'Pf]3ȶKyAvDt֜e1qˋpu8?ZVWdv9S'^7 OҮt1jOC7tmʹߓ\Ρoݳcn#WKqԉc>F6 rC @OZ}PL\ON}z7Jw~.1mfm5mr o>''`0?CY:꠹e{ mb<|g* ϯkiD[–UA)efwsXI4FM\1HҒhfjHC H烚m889 jg] V)hdM$R*9>w'ҲA j>b>9\?PxkKRiK!^F\1F8nhD,I!˄@C2$/P"9\è?EIs{w9&plxULq*ic,ۗj#';芷S tϷך@zag<~~0 ɒ5Cg~?JJ ߨ9RXsާSÀ3ש?v?x dnPRUP7oP8'II*El>bO>5ro#Η$LN';yZs{9?BgȔ6G-zV="p8LU>;(R.WʺթXc˜TN籆\n=GWeH}kJK['}#*GOcS84ڹxZ>IXpF?g$^ 4>V׉u?jmgYԂHd8l'$$ {(gg?y>e AJzF#뚧v0MiQLn~;u`a9*6qϵmLڳ慁N8?f\ mpͼFwsN6J; 0urO=zfFLg˪fr +.(,W8(eFEJѺȤqPݎSQ,$FsV19 g6S[xTigrV8Tqx).꤭-%o< +FjVO:TassRέ3ΠCMV%9H^=OD 0EI>d6;hG Jtt꒤1~_LV!e&Tg}@.]` ~a|kHt$HԀ1Xotk 2r zg"AHנQE ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( jVU]^I5!@f'@}Qu;nJkw.VqnS5b֝.4A$ٴ }@_YMq ŹX.#1șp{W/[J2䷺xD`?97AjΩ9blgGv`Xv'@ӳiZmƱZF+P-l}ӥI閺u-gŠ[hgKfNq[+Qel!M6 ;}sUa=O`- =Bŝy@sMQq#Y._XVΐN vH[q^M%V&P<UDS|EQwooQ>DЩrB(rqڭ0 A㊭E5mE?3x>EP6\Q~Un̅P021D )izy@Ҫhh-hL5ґW9,7Fx?Φ:ji>c\c},Eeie\Ot7OȪ#ڧ -0$Y9o=o%?:drdi1);$ro̘;xҷig@%Sz85 E* ABڑchOj*V!B/6OJ/|Lߍ:ﱖDmiEKQH 8_nwBZ{^ 7oȿ?kkk6׺Y-D%J1߮OJK{Xc$TB M{q}j5;SVVC8{ 34e#m3ڠԵ]2ܙ JcRORJY9Qާ#M6q9?Uwg6%gGk{h|[:??t4Vv (Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@UkM6}s |gӚEr>&n%ҭmH}NAA/'`#h\Z]&<͹1GQ@Us4sC ʍ-k`JχBӡV 3r@gkF(fzwFEWѯ) 8o.u #ZU$SgdtyxeG] ,I8s{%USת9[9D8`H?J qu= g"6w*>Nqlxr FyeMC(p}WteKbIGOǵ\{ډ+%h I &IFc$*b$#%5ힱ zDC"r]N95˸ !x=EZ$ޤ{k=$9qU'sӕ٪KRi>QM60Y!rpGl֔[]CgJ ҫr ŸZ7pYҕ]UTŀ瞵;˸Ŕ`4".Cp&BGsM$~'g Bq񭄅H8Mʡ²\W~Y=p3~=Ͳܦ 0k>p'$72.V5ZykR:WX%랕^ky6o,g}r!,+&vEhojZ1kCԟs. q 63=]> m?o}GP'>|WZe )m3Cc?gtY 988glߵ.0zdhiik%%.dO׽<6NQ%y5h 5-X>mb_ Ӈj͎ {6eGJȸFј #=+5}9`/4I"]DwF s:d toI}3Mug9c#=zOCi9I4i֫camjv0}p1VhQ@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@VkeKEeXRuu_rEo.9[pS/4uRVЬ0FD UG%QEQER@V'P:tpK>ݽyffLVx׃ZR[fITaa5OF/m[˝3{A}EhH݉c2ޡy'iB18U6JgrH}nx/a٣y˸PKGT]lLF1jUn.TTv csPeG"y If qӚgE&c5] s$ןҺ|AP\$ӥ$:3,X’$~ s*~^t?q7=jsEkf3DP=I)[o~knHH)̍8Qɩ4N=H GwwlVKxRIoZɢ٩o#"f.8+D曢Gieğ4RTVǦ_VI}ٕt/Zlm+dHAD es?@k>?6R5 RWZ͸=9 Lj@,:pW)&>0ANJ;>ΤߨfO#Hfcw5cgl{[Cm}9kLjfފw%$K9cQS{[ 6u9Aו@Dqd|?"ޙk+ZP=nfar+Z85T`*Obb((((((((((((((((((((+ŚeJ HV0(ؒYBJVd=7[Jla?LGq^m#}Lm"_$Gpɠ b)Cw IpսN>XE1$݃Oo jЃr<Ll!mwm_(ȧ1s]41GIHƀ*P~hVb DP7sӢ(((kڵ @i8ƶsM$"d#8?0x`kaX*R1SYGU̜Rf0dt#"fi?>Ѵ6~qc8,X[F}Ukyqb;vc׽&.dWQjJw)V(e U62rץ2'N5V7Îx*`X-YSJ0EqYU2BǜgY,{|1jaO98q*x7z֩> D xReRoh/|IRKEMLݾi=1}Mm~4|H{wB}s;UKDXUH@ # ЩIiooJTc~zzgw-mIj+9pt4N޹SoໆL3.q#h0OQN$(+m=YhVxy3afנbʅ% ]KRҭ8"S+\k".-DV'*3rz [j+K"ryΉE.$0eylqEXaCYo-I dFG߮l>k}b rr:m{Mմټ=w%άӢa?8'(`˕֫tg'}c50SJH{R(PeG:ԆOJnPy}kM ͂JbtN".ux[vvj2! 8htVVv1ev>sGrikۤE^Ԟj8ܞ ^DZ(nO&ˎ^d mXZ,J$T29p3.."渕"Y݂rj:c nH7Z׬td_4q H{?L }gSe0}B>S\שcե~M0LwHu0: K "MX6߀ߢ] 6) IQMKL((((((((((((((((((((((((((((K`ltR0YOFR?P+fbFK*(cԁ袀 ( ku*2B)PFӶ#/j%3Ze}jj0~w 4ky Y82| C!cIc'ᑇkI rH$h܌ S#ҳ2JCFpBꏮkٙA3Ѐx޿6̤)֓*={xX`"BSdLçzN*Jl}K֌t2d3Uu-JKνbBp3c?JW5JtH`s9>{ԛmy,P=pE7EUX|?qL^!. @QV#4M.*`nnS?\1*U:)*3<+2Ҡ=qRW=3G.>sqd*=P4J͌L1$)tNwӖd?vs 43^^$,*o3)L[+ֹte-#$](CF-6FwSpjppZqxRnp^Xq#һӚZ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( (ڄ[\Mk&6d67:f,μ?`f@| }\[-յuZkTGdگkO V &?ju}Wzm$QRN\̠ T@QCNVEHmvcfJy'$gKIG/YpD Go]LGJ2z#RsQPHyM=h3wN斢F犥V^Ԕ܂#T X(%Ms>!Ym|=N+D}? :ԋ6g•.g8kh- H-HbAH* <:\QiTE{m)h(((IІjڛNdQt;"h ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( (*jxu^4dB}nzW-Es+/>ҰƑo[y3y1*s'1Z52-N¿[BeII#;e>WSmM<H2U-OV6ҭ s{"Pz׵WХ]kSӧzW+_rZWF_N=c^SZfmцww;qW)h.dQE ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( kJX`2Q@[ZCh cRrp:SSEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEendstream endobj 342 0 obj << /Filter /FlateDecode /Length 166 >> stream x337U0P0U0S01C.=Cɹ\ `A RN\ %E\@i.}0`ȥ 43KM V8qy(-xǡ7oݺu;GGBS! 4 endstream endobj 343 0 obj << /Filter /FlateDecode /Length 163 >> stream x]O10 @€ЅUqP(/ СY:ߝ|]"hcU- ee`Y8Ixwr"<]yUn!tf/#(D`d՟;FdTu()J747I3 HSendstream endobj 344 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 323 >> stream xcd`ab`dddw441U~H3a!ܝbnn߷ }=\19(3=DA#YS\GR17(391O7$#57QOL-Tа())///K-/JQ(,PJ-N-*KMQp+QKMUMB9)槤1000002012ٛǴwdZtI95OnjwoesgKwdwKO뼦@]&O6sRd?ӿ7-I<< vendstream endobj 345 0 obj << /Filter /FlateDecode /Length 162 >> stream x]O0  .eBSe> stream xYKoF o#T[t~r)(zh%9$^'6]'~ _r88#i,q8|#y-ZKW~V w+R:;kDrNwVtR$N zwXvZJSw٪mb>m: nRN{"q)XbnlH&۽k1!Ke=s y9p*(<Kv+vKw*׌!/dߣI]Z4QJ s$qSݡ|AxPa^ﭲZH5p~5dg&K~lC=KRR2!808 ^;.zJM;ggq9ĢJQ+ꜽ8x_pu}oH}=o-RTƥp&;#%4JOMFn2c/|vAyztTAו󟅫$w.>{ ͶWdOuu@(J;2f=O* Lm1ѥޝ fƋhMvA#{޳gEKm1Dݎ#'M4q #4$ګ&ɡpٰmTv 4PTZJHihX3 %Λ rL*G)v,pD)Pdt)T 3όC[Fs2ɫ`r,&Mn=֢ Yג3x&_CFqkT,fC yM<-Rd [\Ľ}*Z o:( QoS:(lJ5뷵6gڊ`koE|ΐġ:QM!CP55e b 'ލgsO^0t"@j,_BGb#jGqus/l EG,~RgHjSJX* C_|On^ 䠺q\'Ђ#*C W@PhBmC(vq.&m|;lM˘USs t0;L*)S5zbS3Vk &k s"ుlx51klJo' :RAfŹH$u q3I&/+ţn dE/cO1c+9n"?ycgg1zo&2V me/J&<޵^,餝y @N4J "P]bU2;*._of1)<_sH6?OhK}Q7XK8`ɪ`c=w, .' ]!W U/[ŖAQ໰}c?Ԕ2@+ jfEUMF t ^X~zݽ^rIĖ6$8 d;k.~0f& IҴ>' 8w* ͤc{|OSSp,9.·}0ߵ8vff}R,t[ hX f׉a|zڀXqoشڱ6G&>4$-'۝}>󏋏%V*k0EB}^~V*C>.\{t14>s3G8Dm6Jҭ)Vfu/6Q#kO,>8w^WJ&T!^Hꢟ]J",M9b4ggvWƂ_1\3dlz +c3)=]N>NG}c(dB諆1%EY<|jSJ|,piFإ$4B[)#u86h5NS3¸_n[c7ʬ. (!3)Mjendstream endobj 347 0 obj << /Filter /FlateDecode /Length 1829 >> stream xYIo\7 ϯȼj_i2==xfvl'E}ImCI(P2EǏ˧%n[ӂ?.ӏ %WTF,7 _:=2j> Wk6*wHb\QpW3&nb8ƵgL(>K>RZZ òOJw3T?UݛbRc̒k#Ũ O J ƸpN6n*})Ƚ&Ι^ĂnP=sJ'2xt;ͽ`4!QvWVAcLs]!bކ%+Tp\TgP:h%^t6|rvH @,gSX)5z3ܑ+Ż`7TBA >J!=6g et^b C.ohMagÛKo$X)lZ*-zU7cq؁`UEgyQVp]!. z-1f,9.9T Qf*sx$E+j+ v)|K',g)FENí{'@Jx%EI᎗Zx pZ͊vx?6BzFHGF.8S")`=ZCER$\ӇpGynZEgXf*0=X6Ji}lFeMڣȌV% [9ϡ]`?L@SQTGa/[9AnZmȔ"~7\Ͽb]LNmCPB{uL*#}Ky[ ƣH&AQ~iV×UfH N|̈́=y+_F ! ](ݶP"- g5 *yOjɁފ6?Tt>R 7]ᠠK S@wVluw{}vJe]K1R7ۖѻ)T,FX/7׋8O.5袴Kc4(qt*Y#:k,u5GG3;Hco1tiEkB-P#iQ.JCo#mn}q&D-~4@Gen1=M/m9*pf zY"d_z)*7=&G0}YiVAK=7PI} q&zpS}L\Ck̲dneeDxf'Ce$im-M^g9D ޘljs(,[׎:A՜9Sm:G"_.y,a BkDi#}MA(pKr cH#NpمqE- ZigÏ?}Q5,A1ͧq{Yva]ۉP@ˊXBQ3'U /(ZVaaz' ʠ-ilJoB^+e,E K A~_> stream xZ[~GʫH "M1K;Y3}o9$ŋ$nP,#S|C=.HI_+zdTݕ[HZP\J.Whc \Qd)iOTD]2gf voGMOW4)G91>nYD`b%#*j4HCp=dĺH襴w _n% c[J݂,u "(VE(3 xO;5$)HB$RǧcVeJqjF}^guU-(- ^qKlⲬ4gU {%{80$MT7ws*Bop%J(9RRL~qxũ4sݽt.ny8b}z)`2u8vL)utlf!Y&(s~8:_vP"USpLE}7ۨ~]ߛ]-2|߿j1yl4pM{ז %b2Wޟnހ֧uiOw>mfO}=P .m +V碙w3Ei9@؟Ny)]s8PAHOwa{#Mמ76a=CoRgsS~ 'MM:xyPzM} ;}&ep:m]Tqj^&= o) X:;e*~s=ɦǧ(NKtϊOs#XxJ?/$҃;H#y8i!Uά9*>:IjA*fISϳ@>K)+Em?!0Iye!BRI!os yĨ` Ε6$2t>\ Z64Я+N_m)5Jut?smhC?ZKd) 5W} c#JY$MSr0^O~XM$Ōq֦O("qNh9d 4}ke;1J )nBnIK>4!qԏaŶ䨙V 7.]7BRB K>Vs9ŵxb|DeGXٴL6{]ƃM`@YMs.rD?5mQcO=]Y;"q˷$˷y8[ W!Aݤ)Lo  m2a3}L3j K禨k3hUf} 3F9[&ʴ. &iulADqB-yT a3jR^@錪|ys$L3,|p RzMs*8W> hpI-K u06Ka@?g0Ӡ: 'y* Ӷu !LrlROcX|lS} i21k~xiqE9E=OO7bs*%4{|~ /v=)(Lϒ6>4>,?F15PBK||ΝDXkpI^R-_e7ʓ۽3i(p3z텬03b_NXJc^y9Җl/c ӾB˘imIj6x#S>3լpJDg^IOBFZqZTLW?PoS LbdsBH%TkE"'* B@f~.i0j9+> stream xg%8jAk<>ϰP 0H>ww'EtX#1rV/G `` i!7`w8A87A`ϽVv35Eb%8ǹ̸c@{A2s63K"5-PP<2$T/+.4?X^ 8z \v;΁V/j;=m>-~r]+3w__}eCuC-=xKs[( ~C*"(vFq@U۩%II[`"5k@*"zC䔪UԤv ,}]ȱgD c| |cZ`M Ø5ˑ x~9]N Z&jT0\f*ri0'2(S!'BO~mi9РQoO ]{M1vN &aN 6g  fWui:'*l*nQb-|ԼVW(E D>r55)HywK[8+ Lج*$xQe:`Jfg(Sg&*<}YxS3P-CsC2j e J%n6F_"&5xX(oTpHXzrVq܂S}Qɨ <ޤ GJ57  4=Jʫ(o}i[~,"9I%g!gT#Tpos9(ӹmF1z˔K NG0U1[ ]TA9Rc,'[)G0 0#gIPa;!`AsdWVdmLY`L܉HGB7zZuSGݞ3u]*uy,B8+A1 &t55Fppm49f̻Xg ϋ9*<z9UF*#{RѾzlĺifX9a#$\9l-?fuT6I%4T4p2\Qr%^Z^—o~m7V$G_0fu5FiB HZiT-s0 x1摦r;_#{􌉊TS "dɪf9F妟 ft,7&e:i\>sUdrQQy#L>3BuoyO&R}Dxg 1z 7MѾELC^ʐt2OJޏg/ -jJeYE x8Ф~-&}+~֫M7F¬" tWBpPrʱ< UWhҗ*C-RbV ="jW|z{Pˏ1W/nos)Lt.&GG]BE+nx/̣q:ѾJZ3e9f11<0|""%tU˙8^U7;" X[&i쟃 <qTN+Tn|Ty^%'hyDGY}9#kaq )JS13YI}oJX^ޣƜ̘ ہ**D_iV΂XZ[;̥(S)fEH dZ Ko/rv9^ jM'GÈգw+սqJ)b,R*=-Izjo#6kCE졍 "9qvu^cj=[`zf+9OcYntFHAJzË5Gd(0KQyϱfs7OFҹ^:6h$]\~;|9SczGnfofpa? oW7g{j{Ǘݠ=C,UH$ǧM#gAr8lHΎ>V[?ij&y7{?<=o7B)i;xҊvzl}]o= ж&oؠckW?ڔjX|R>B؎Ӭ~𼙐´$! zYXnONWU8qi#"Z)bMб9o +B>jSmgSت?єž1@&peЫ[E\z)͔bT;雉CfL4ӀE},>UJ6,v"G vƋqH-wJ\ oļQECwb]EOUxnC"TE8} UdmKWh-$O.?As8۠a{W!:͐<9-ˊÐv<ɨj10F<-^4pFL Ô7!攫+@(~g ]mBfXsقN(px4߶ZD{D78ncI!Pa,*VAeL҆ 7JܹEi"Ay0,CG+\4VGW.JP~x/QР\r-BGfrE(zҴwdې01VMʥ>u/b"o2(D6&(Zn!iv*>4jLݍ\G6=Nx˂"uSko+n$1V u?͚z MCqP<ܪ >X>endstream endobj 350 0 obj << /Filter /FlateDecode /Length 4978 >> stream x\Ioɑs#|G_M Ø؆s->}Hj"j{GDfVE.UOR"#3c" ;3{{3I?Ww/~RҚś; [9vwgNV_=dbq/CvRq}UJx A{B8 G_`ѹSV!Mև_mA!aw!RHC+7 k #OyHMzb9Ѫ0,ad4 %%.rMXfSzB F^8Qb4aMKiaLf hwޝ ܻ\"'W?wo2_R뙱tK鶃nߧm0, tY8eF+5YA/Ar;vqu)B"kFT%3iHN1 >bg]|-rt+QeC 4kYV|\ ?# X̿??- KMƉYkY z;\伂\P6/7 _RރYߚDH˭Mw%m|f&&fw@&][V led.i(Cq$@b OhZ"mHf`RkuRm&}Qn:Pyg;+ZI1PRK6pނ7"5 G*(Hbbg .#LF"AW٬Z!M)0D !w䍅t(^N_~}-jYa4<^muKi9hWNu?F'9 5z6М53ɳE$ʢC`Cn1k݁L渡OKm;pty wiq6܈"᝶D4Υ]!E0R0R-Or[=0zhn`Q7Muz-|:)Ӝ"hxĵY' "99A%xLʋW]Iw+p7iG[8֪&yHREJ; ^HZDJUW юS)H `>%yu93eRe6oepk%Lckrё򶭼ѶnqgN`:M$I __N$ypt,0 IVi{VGףFʆ3eY&~IMj“CRʽ A*4xl)<:m B*LLD![C+r1|kpdkPpS C(K GAU5o$쫤 {θ*P8#4Hwg>KuXvW6ڸ |•]^2I R5~`k(ռb -ݴ_!'V D(WiohDJB)2k@ʋL?Jr4YL'XhG1_`7[ߣq>!Y-0)PK UGvݿ_yp#?NՠW,Ar-S~b)/lY(_AUFH2*s S)$$3,#/]0'w,qN%4_@Beb {TxZ.`/a VFjC7 MIe[Yae6*ћs&#Ct~F>?}7}\;_C ͈#.Mvf,AKCY O(N>J2Xt3lJ{ I `6jH4ƯQ]sFj%n~|A0a~zUvU?$!XT\aWa\5W\sn-'T5v1iG(DȡJm(굂ue5^:X̑gW&>YEFS+E :5t~nDwz/ڷx^#E)[9Cki d4.3n!q q'G//mFEس+Uof>2 ,M>mL|+2-8IA@iGW.jc: ^ːNÞjMfR͛?F4䍭L3I31t]ǀfߌA !YѳHՎꣅR:W+ݗT#!n (q9[5 yFmQ)Y.cƅF  ٕ̹vGלB ډ6vO(d*׷ uđJ>j?{&C7ƇCMtښB:H5el) B~i*Q9jp']oViEc"<&FG, t%n$CabU ȭYZjeBuCuas]ؼa$äPI ;`"\l#zhЪ3k]vɋ[!r hR>jy%<.ϭel^v!w)eZၐt>\,p~'} Ja%P2u^ -elN QcN$g߸ s+-\l sGmQx{ۦfi[JZQ`׹iKk]EƳB+LI,K_6(153"'I94%q§2L6`C5%3à02r!^Ӵ^T]{wDݮeM̠d~dF޳()p0_$R/bA;n70imxn2\JX x7,9{ ɎT 3FU<;4!#]I%k4&Ջl(q  89)E,]W #.e#zT";(x02C)-ٞ]=&fG|ALA~tҨFB-%2763z(9EE<5#0$ A8z*HKsR{(+P7:pS}Q#5\m7ͼbu׷lSNr'mJu^ce{shOApkf߀gGY*j\br!.>t=v{$N:w`"c/97tұD(hMv(S-p̠鍨ȏi^pRn,JPZwʚ)|7Q]I S5jӌzTv l Pk'oڈFUo tڼOEDCf|*>Fn`v "; Gn4\ u2m&N~ X?1I O7AܝQ wV6qj;  1,ٷpM 2sđO?h"yJWw݁.GmoRfT<%Ѝz %,|Ʋio@~aG&\OJ]:Έpٌq`Z>7}x`>Gg?Q}cP-H-%s.~i{M\U߈s3%϶U /'XEYT6HD"AZ%眥7 sηY)-KQ F{;tu E(8B$b%4[yG67+N x&Z?q7?\MtڊE$禭U P٣1MUN>G=d.Lу<>sTRݵ~yݧ<!V0';!0e٫/"8Ym~#rʿHt>\c`6n LCvg\I&1t9UA>v@GA{^ i׷!Z P2gtLBo-a~Т4"_'hy"XՅ(rS6z ĦT޳ J+O> stream xZKo3ba lq! l89Y9%wEiIY~̐t@Gb=_1<^|]ݜ/??_Zq'_93jV/ ƸzûNh 'n~Qܩ7swZ cҙ7<_{r9Uc'3NGy Lȏ%s$w6Q &_ oN*]tɶ鍏8ƣhJz 'ifY?tM X]TX>?^HS+{M'(%g0;bgR''UI_qOץDƗ8R[aSyϘM^@ (1ػI7x#=Yo?/jyt-^ Xzi-4gʧN֣}v$]V28j%Y(y Nʑb\j#DKtO`Z(}߽!=.~wZgYr'ciRhߝ J5wûn͛DfVwgD ]Aix/ o6!zq5cK{h 1"q3a!w[o2%pv`t}:]+<rJYƎA8"Ž2aJ#mL5IcYF$  yL0Ё ՛ WR2J!2c7!bXB)0e>}ҭ@LpInjϿt7( ؓ_w[p t̨ǧ-*d| b & I>- $vbqNgbJPV_E(.g:A.GGLDo\ZqNfp Y{xe$DhvL? ogݐ t軧k,( 9.j:l "T!gn1it+\Pxy-x ΔHH&YpG3JRO9-% ]̂M<;`$e, 0!P&cXMfuy+?YV\ioP>v|6)MHznd2O}9 ECuQ,vq}:Ŋl9O/]vC We?|ME“! ݩJ1kL<WQ`q7,!e rdV e>ex8޻]VhUm/  |9[endstream endobj 352 0 obj << /Filter /FlateDecode /Length 562424 >> stream x_cו{?D싢tXmG#=/Z}Q"K$*HG7go$ YEu{R$ȅ_]/W//_*?_*6]i^}/j/qZN㫯~__^}ۗona̯}m{wLQn首^no_ \⾏ezOok_t{Rr.u_ٖq/Co|I%XF;x?/:ĤO^a43n|6ysovY^n}S tޔy2mǴq^o<ԇm}SkOߝo_~_Oe1ʃަe|3l>C>m_uܖNm|#>۸jzӟ߶??{Ć鲖[~VC>?5rN/ۿNv[(pg?_<>F)|>%k3 ~ao/G9;ݷi}6~[qwz|>ֱ>Rɾ_e{6^iG*_w>Z}yaܮqO^T7ݿ{.nxz|8ni /&LJ'|~~=[z;nm>^z# j'B r~r=B]\u|#Z^mi8?^ƞ=sNN0>KY}è7ӟ0Ο_iLѧ?u|Ro|'~3;0+n>:/gy~~{|fE,{aY*oʗ}t||nmݟ~?>~O>՟Nߩ?y>y^yqҴoKZa|~}|ܮ߷~|MƧ/cy?~?yo 6Sϟ?O5ou(ߦkZZzz\;;;K.v?xP:w/ٶc73D8?Ay|-'ץn^o8>ǿJa/7!kyP^a;Uo/aS=x3vƳOw.o뿇^b]|Zm뵾-j};8J*uF{C>k,%^|fnqSw:;b^o'=Cm~<y^~z9_}|qch/1t)WK}et1YJ_mӱZ>۫7X<_??ߗ9_//_eySTn\ OO~_VP_߿?|?w??|^??O^_t}w{w~/Sym?0Lߦkyzwxk{_^y׿Oߟh/dOh ?o -^?ӍOӇ]zoߕWxOkzO߿㻷?ᇿzPR㾵Ϟ{t+O7zBo?\񇿼M}>y>ͷ3߽Ի|YaߦӃ2X,}:p'/ pr7?}#;鷟 O_zߟW?~ͻ>c|_{W^~jN{Pv;O/%Ï?-/{|}ܖW?4/ʅ?/}r3<^/wu~5L\2oR-#?|'UHcT}嶞+T{}sS5o{ҝ+Tˋ^e ip[hVmx\ֱF-_WC]~lfiϰ׷?7Y8f)Ox'}dr_*6ȋͼ;Us5^G^T|˹⾞ӽFJ_}(_>Ӷr_W`@'W7e? 7l|84w镦ܿŬ{?O>r~};pGK\n|O=UyhOxޱܟ2]˥˛_>~o>~9Կ(~>|] b.!;-{k\e*O ~Y/c?~Qwono_@ǿ߬1Wg^[z%U֛{?iS>zsymP.(+d,to[n T>r 79wK"x&t}U-kzKyw| ׹\>\ڷuN2n[q[7eT._.k >8׫rƋ.lu,qyW2MX-Zy2T/1xu_|B[xȖ۵|_-ocςLrk{E<Eߦk⿝EߦZ<#}eÍۋoo@rx˻ۋopV#mױ}T Ks叜+Ε?ra{ȩzΟmðMr_].+ͭm[#|+4GOgUy/W\zYMI1ݦ>r퉯<(zV{Ȳo|׵ێ%-x+<}}Yŷfk}Q^^4\BY)_Ӳ}SuCo{v?*{y>ze5\/̮>n[c]k}9{5^|ız277ͼ[fn~s<ήJ?\6~1_u\oh{'MyKXfEz/е)n~7^^\|[xy|@>~'Z,Q.ӲxYq,LNdjS+]yCr?V~r-wN}[xv9Kq-TWwS}㰍ٕ'jz9~zX#=_y"ݫ\#jvs9GS3zsUʛs8_6V_V T73k߼ZnkL.Cy1!~diUlȹu=Uȋj,boӹr򲊏bȋ*>Suۈ[yZ^ꏱ߯?r_Ro/f<__O"'Z.n>2wkO?r~Y~N?M~x۫M?Vl _?Ew_TpXwm+o]m.}r{ezqyG6_?(OΫ,^]n샩)Rގo[Y.s׎wJU_6?˭[y^C'_.“IʓVdؓ;ןO*t~ɓniv{\,*[ W;^=8_7I_}K)Tž<1 97oMcyC'o:%CgˠDPY4UwWs>io(WTEHT>^ڕDyL'sJTDvǷk}ÝL٤L/_'fyxM9f2$Д=%Ur'm-{,WvT6\eD]}`M' '3I4;D[YRC0u+`+;VD~su/T u|G=QO_Q_H5Q:;V$5I['+Uӯ]Nwԭ^qgrŝ[e;jWك9+tG +tҖ}Lwp%Q;Trr]S9QCNwTrzŝ>;QCN'KtGU^rx7Y/Iszɝ6|G ;}0%wzɝN*َ9QCNrŝ^q瓖;+٤=QW5+tG;T5+K7+tG;{E;;}05QcNwX/WxW9-QcnU5|1QcNywTtG;QcyU/$QcI?>;ҕ+tG;}E+˲%w+%wgʾ,SζF鎪J,Q[+W鎚wXNg_^q|GM?$}r=wcLwTZY/4;jW+j~Yw`Krɝ^rzɝ~Y%w/TӯJV[CY.5 t~WTCW\po-_QsNW\0{;{=_QsξvsNW\/sWX'-w7I;{;{A;z~QvPV~v:i 5\ 5/c*f\/ӯJNT]tAWӯJN_z;ҕtAz;cz>z;{z ZvzZʥ\m jW=_PKξ(0 jM+Kv˕vє/J6KV.KV.K5P7Oz/[vEwg[+ tRNR//JNR.崔 l9-:;]Nk5ߴݴ셹t7ϢrOZݴ+CEYuv*.MZItIzUt92;ilR|Ғ/\fMOb/%}Kt9;}5kt9;OUEvz~EvzEv>iηZ.k쫲k{Vr٫i+v5vU5v1N[NV.Gi++7>I;v:<5v+v5v*z$N[N'kXtvm[?7Uz5N[N*;NO'mv*M_d_붗 t;;{5?N-h̷^+붗wvv>iM^/ӯJ^M׋մt;";M:i~-gEvkt;;}%vwTFKzEvr=擶|;";׋+W.׋tRNzEvQtR3\/CIi맓"TdRS0)MdI4NJ"+͝&M҄IMi¤4)҄)M4)ҤJ+MԔ& ҄IMiRd 7gI4aPS0)Md ҄IMi$+M4҄IMi$+Md ҄I&EV5I&ERXiO:)MtK7gI4q&NҤIV4IJIi +Md&ޜ&MҤIV8IJ'IiRd}1ҤJ#)Mz4q&EV:)MV4J'IiP4JYi$)MԔ&FRpsMi$)MdI41ҤJ!~ăќҤJ&Yi$)M;)M9+M;)M$|G5I4i&FkҤIV8iwTSYib4;)M41Ք&NvԓIMi¤41ZՔ&MҤIV8iKwTS4J'-jJ&Yi$+M|G5I41ZՔ&EVMjJ+Md|G5I41Ք&NeI9QMi$+Md4qҞ都4IR4J&Yib;)M41Ք&=V4J'-;-QMiYi5QMi +M4;)MdI41ZՔ&MҤIV8iwTSjJ=QMiC`|G5 IKҤҤAV8hwTS4J'jJ"+M|G5IwJ&Yib4;)M41Ք&=V4J&YiaG=$I41ZՔ& ҤIV8iWTS4JaE=|E5 w)M>|E5ќ4)Ҥ;n|E5I4i&Z eI7f|C5I4i&NҤIV4JPljJ&NZՔ&EVjJ&Yi$+M J5 4YՔ&MIKҤIV4J'fS(MV4J)_NMiRdIwJ'rjJ&Yi$)M<,KhΗSS4J&Yi%_NMi$+Mt95 &6c҄)Md&FkҤ;n|75I4i&ZԔ&ݚ&MI[ҤIV8iɗ&5V7+M4ӷIRIiRdє/4i&MIs4aPS0)M?hJnJ&Yi-NMib4۩)Mt;mVvjJ&Yi$+M۩)M9+Md|;5I4q.8)M|;5|;5IT}:iKSSc|;5 w)MԔ&NԔ&FcI{ҤIV8iMSS4J'}o6I7gI4qҚo4i&dI&F4ZԔ&=V4J'mvjJnJ'-vjJ&Ii +M4NJ٤r1SPiFJS*ME4#RtDJ)ME4tDJ)ME4tJS *MG4}oTJ)MG4tJ )MG4ՠtDJ)MG4tDJ)ME4tDJ)ME;(M74!/a,/^ uGuggbh4;._bKCp{,\>'~1'naֽfoKxΰvuX`ֽ % ͶugugXgugسugl`KB3l;j֟&kѵna/d-4֝a֝a֟$kJ7~&kɴ %Y ugXuggZ0BcuYwYY7Sc9Y ugؘugG,+wFsebNVBeddK"0!zX?Xsm`;Z_5 u海XƜlfú3 ú3#d%4ֽc K-Y ̀ugg,J0v_<_ܫzg,Jhʫ[x)Y wugXvugugN0h7Q5m{+\[[#F;a3sΰ0XhVV첺33d'4՝!1?OGl-SؓUwsx'4m/K&z3ؒ`UHUƞ섆3,3V PuGPgd-TV즺33d'4.՝!+1';JHߕXdTs5ΰؒ4TVL3d'4՝!aN8Όzz:cd>QŸ"b#AݣBE*"Q:EE2*"QGHEJ*"RGV*R:MEn*"SѰ:PEĆ*"fTGHSEĞ*"&UGVEĶ*"UGYEjk\EeJ+E"b "TXbEKq,5("b]"YPgE@K-EȴԊ"ZlEjK-Eh!ߊ"D\qEĔKj.E銆Y"]wQ!R׭zEKr/E("bh(BWD S LJ)BIXD S6LX)B$XDLJ"4c1SrLⱈ؏)BB"dGX2E(S,"ve)"] 3Eh!3S,"fЛ)Br3E=S,"h)BS4E!HS&-"fiP)B}ZDHԠRSP-"j)B%nM5E"b "dlPEĘMz6EH"bզa"mEM"7Eܢa"oмEM7E "TpENr8E(!]"qPQSLNJ˩A/\D J"sSN::EH"bMA"4u1SN:E"bb"vS3+ŝDwSN껈)B"xG`ES/"v})Bݧ_Dl!S/"~)B$O?5"b"tFP@Eh#Beo̩@AE!!_NTh0"vA=a4l!#T0"Ƅ*BRUaD -TXݔ8CEH #bm"41;TPCE#b"FQDE#bi"ԉt9%FQQ|ccEE!YTj1".*B FEcTDhͨA"45FIJQFE#b⨈:FQGE#b"ԏ@FR2HE(!#b <$PEF0RHE#"tJFZRQ>ͤ"dGIE' "TR*BKsJE(*]">T`KE,"j\*"u KEh/!T3"Fa*BkLE2T,3"jg*By2h+[fCh>9.F4sЄ90>;3 gF3s̄04 Y&4Ve?wF2aEfNcoXc4ٟ,&1i?ALc fi`&0s4~ %4%^v?9KjZr[v0,zB0\Kcp s-ے9fz8QK#i %5'?kj,ƒXBcaI͜ml^ s+ip%/дXV*VS4GTJj$*Q jl4%|Ɣ0g|R[GcsiΖnfӭ#5{uwܑiر?YG[IG-AGcHct4siΜnFpfJNpau#5sumƴ1: 6nsaU#YΓ920Ƥ%[: 4{FcHst4slγfKN#Yγ9{tbfNN#X0}6`9Kt_9֋0GxƬ1][\1Ks[9f0j-EcHMEJt4w\iX[Ejt4s a"YҕcӐb"%krP94gIWN0:'Ҝ5]9 .%R3릡Dhl>$Ҝ9]7 ${D#Hcul~I6Ri";D)DcH͔F"%cm?CjYm!gC3ۦCcvsi̒fLa!uӼ!179Kn !5&{zYBch!YuӔ!4FLiXC3Ƽ? iΚ^7ZeYs iΖ }P!5{o6Bjt4Ps a9!Y}0!ܖ-!1%9ko$9r4f~7lO)7Ҝ=7 œ70ٲ} 5%7o9 Ҝ-7 R3AAc1Hsl4/ciNۗ m SAAA#'HctX Bb$H^>kt4! ̱9[o29Ko 900Ƭپ9 |:\) ]%00"1 m=p`D#b#J`D,#b"xD`D#b&xDa(K#J`Dl#B, k#J`D#b0xD`Dl#b4xD`D#b8xD`Dl(`4Q T0"6*BEaD$T0"*BL5aD 'TPˆ*BSQaD !+TPˆX*BZmaD .TPh*Ba%P"CExaD !4T0""ĆPFPzCE8ɡ"4FPC5!<"FPј宅*BDE(!A "DP!*BxDCTQJDEH#b1"҈0GTQDE(#bM"DJT,QDE#bi"1NT:QDE#b"$(FHQ *EE#b"*Qb!VTZ1"把+*BbDLYTh1"V-*BbD,!]TDv1ƋP/*BbD `TQƈ1*BŨcD!dTQRƈ2*B̨5%QzFEKF5h!jU!QkT1"6*BۨqcD!oT1"P8*BcDrT1"tj|EtT1";*BsGE!xTͣ"DP=FQGE#b"?FQG5#B"$@FR*HE #b!"jBFRbHE!!="PDF$RHE"=҄IMi$+MdٟtRYio4i&LjJ&5I&DMiRdI&EVXi 4i&LjJ"+M9+Md ҄IMi$+MԔ&LjJ&YiRd 7ה&LjJ&Yi$+MԔ&LjJ"+MҤJ?'ٟtR4i&NZ.ٳ4i&MAR4J&Yib$7'I4i&NIRYibk_玬41ҤJ'IiRdќҤ;nI4q&N/JYi$)MԔ&FRps-5$I4i&FRYib4ďx0uRXi$+M$|G5I7g|G5I4qВ都4i&MhwTS4J'-jJ"+M|G5I&FCIÎz2)MԔ&FkҤIV4J'mjJYi%QMi$+Mdњ都4i&FKҤJ)QMiC`I4qҜ都4i&FSI{4i&Ք&MIR8iwTSpsMi$)MdI41ZՔ&EVMjJ+MdtҖ都44qҚ4i&NՔ&MҤIV-jJ&Yi$+M;)M|G5ў都4!Ik҄IMi%QMiIi +M;)Md|G5I&FSҤ;nI41Ք&EVjJ+MdI4qMҤAV-jJYi$+M+)MdF[҄;ޔ&NZVI{hWTSYiIKҤIV4IJҤAKҤIV4J'Ii$+MdQ(Ml|A5IJ'jJ"+M|A5I4i&NZe ҄AVجjJ&Yi%_PMi$+Md|AYib3)&i+Mcє/4)Ҥ;n|95I4i&ZA%[`Mib4˩)MdI4qҒ/4i&FS҄J1MMiД&MHJ5MMiIsҤIV4IJ-rjJnJ&Yi-_NMi$+MJ+M盕&EV[i%_NMiRdє/4i&MIs4aPS0)M?hJnJ&Yi-NMib4۩)Mt;mVvjJ&Yi$+M۩)M9+Md4i&MAvz:hd41Ԕ&NԔ&MS-NMibYԔ&4aRS8i˷SSvjJ'vjJ&Yi5NMi +Mڔ&ݜ&MIkҤIR8hη&5V=hɷSSXi$+M۩)M9+M$|;Yi +M4NJ٤.oegi*³4#4Y,MEx%gi*³4Y,͈,MEx"KSTgiFgi4YY,ME ҌTgi*³4#4Y,MExfD|"KTgi:4Y,MEx#:KtDgi:4Y,MGt#8KS tDgi:4Y,MGt#:KStDgi*³4Y,MGt"KtDgi:4Y|7Y,MEx#8K Tgi:4Y,MGt#:Kt>,MEx#:KTgi:4Y,MGt#:K tDgi:4,MGt#:KStCgi:Y,MGt"XiFJS*ME4Ҍ"TPiFJS*ME4g4i&FKҤAV4J'jJ&Yib4?і47ևtҞ41Ք&EVtLJ1_QMi=_QMi$)MJnJ-jJ&Yi$+M$I4i&F4Ք&o+M )M41Ք&MҤIV8i& jJYib )Md|A5I4i&NZe͘Pt4i&FSҤJ&NԔ&MҤIR8hyXNOl5ќ/4i&MIKҤIVMrjJ"+Ml|75 @S4J#)M|75IwJ'njJ&Yi$)M˩)M5+Md|95I4qҒ/'+Mj41JoVYiҧo|95I&FSҤIV4J'v҄AMi 4qҚp)M9+Md|;5јn41Yib4۩)MdI4qҒo44i&NZԔ&MAvz:hd41Ԕ&NԔ&MS-NMibYԔ&4aRS8i˷SSvjJ'vjJ&Yi5NMi +Mڔ&ݜ&MIkҤIR8hη&5V=hɷSSXi$+M۩)M9+M۩)M$I4qКnO:)ͧ%;K3">K󈒳4#4#4#4QvfD|fD|fD|%giFgiFgiQrfD|fD|fD|YYYG yDYYYGшgiFgiFgiQrfD|fD|fD|%giFgiFgiQrfD|fDxf4|=Tgi*³4#4Y,MExfD|":KS Tgi*³4#4Y,MExfD|"KSҌTgi*³4YGTgi*³4#4Y,h,MEx"KSј,MExfD|"KSTgiFgi*³4YY,MEx"KSҌT3+TgiFgi*³4YY|E%gi*³4(9KST+*9KSҌTgi*³4YY,M5xfDxKSҌTgi*pҌTgi*³4#4 rJTgiFgi*4Y,h,MEx"KShɗSrfD|":KS yD|1MY,͈,MEx"KSTgiFgi*4Y,͈,MEx"KSTDgiFgi*Jo|fD|"KSҌTgi*³4YY,MExfD|":KS ҌTgi*³4YY,MEtf4|| <,MEx"KShɷSrfD|"! G5zͣ"jHQ hP'!lb4D\b4ՐJTC(14jtݰHTC 1j#*!0b$hETC1j!!b4ՀATBhP *mP hP!|a4HՐ}J˩J*1`%MI8iηq% j5^ XYX$K۩!Kt;5fўn9NZ$[Kdl|;5nI7goI .qҚoF.i%A%'vєo/qҞoF/iO'mvj|̒o0N7 I[h̷Sc8iϷS4'vjc-11iA&NZH&MAs21wTFK̤4&f-NMg͙g%N h$ Mdt;fIi>Tu\oTJ3"VPi*B%JS*ME4Ҍ"TPiFJS*ME )ME4#B"TTJS)M54#b"TTJS*ME4#b"TPiFJS*ME4#b"RjPiQ4tDJS*MG4tDJS*MG4ݐTJ)MG4TJ)MG4TJ)MG4tDJ)MG4tDJ)ME4tDJ(M54tDJ3"VHi:_G4tDJ)ME4 #G4TJ)MG4TJ)MG4tJ͒(VPi:"鈔"T|GtDJS*MG4TJ)MG4Ҍ#RHi:"#R@iA鈔#RHi*B鈔#R&RHi:"鈔"THi:"#RHi:"#RHi:"RHi*B鈔#RHiFJ)MG4tDJ)MG4tDJ)ME4tDJ)ME4tJS *MG4tDJS*MG4tDJS*MG4TJ)MG4TJ)MG4#b鈔#RHi*"醔#RPi:J)ME4tDJ)ME4tDJS*MG4-b#RHi*"fW*M74tDJ)ME4tDJ)͈Xi:"鈔#RPi:"鈔"THi:"鈔"T@i!h醔#RHi*B鈔#RPi:"RPi:"鈔#RPi:"鈔"THi:"f44tCJS*MG4tDJS*MG4TDJ2GKqIv{G2olw)=`w4,b~G*y*͢uBf+"UE4Xi'WE4XiҬQYJ3f*"UA4Ti,RJf*A4kɕf* VE4Ti,RYJHf+"T54Ti,RYJ3f*"UE4cXi?o4Xi,RYJ3f*"UA4Ti,B9ƕf*"UE4Xi,RJf*"T14Ti zWYJHf* VE4Ti,BYJHf+"UE4Ti,RYJ3f}Ff*A4Ti bYJHf* VE4Piư,RY~KՕf+"UE4XiҬQYJ3f*"UE4Xi,RJHf*"UA4kTi|,zSW(gP+V9mK[iR+M]j*MV?_.ĥ4qi+MV@[i j)J߂V8ĥVB4q4u&mK[iR+M\JԥVB4q[iVJSZiVP+M4Zi =~݇Zi_&q4u&/=~]?UJSRiP*MjK4RiRiR+M]jK4y)P+MٗA4Ri[JRi $8ߨ*M}4u&/䥯_f+MjK4qi+MT4y).ԥVD4Zi!8ߨ*M} ZiR+M^JK_>&/}oVJ.ԥVDJSZi~jI~Q[i $}Q[i?o7ĥ4.ԥVyQ[iP+M^zoVJSZi=7j+M]zߨ47j+MJS߂VJ>7j+M]jI~Q[iFԡVn+M^JK4u&~jI~Q[i[JSZi7K>&/=7j+MjK.ԥVDJSZiR+M^ߨ47j+MJS߂Vߨ4qi+M^zoVT:J.䥏JS&Fm/.$ߨ4ZioVԥVJQ]JC4ԥV4u&?OԷ~&/=yu?Q[i}OVB4DmK4u)&=>=&=j+M]jK4y).ԥVDSi|V[i~jIq?P[iR+M]jKjC[iP+M@mK4yq?P[iR+M]jKjIvOSin34i+MV[i8mK4u)&=y=z$4u.8mK4i+MV4o۴&[iR+MTDmJS_x+M^ߦ4u.8mOkK4y~ԥVV24ΟVB4&/=i+MVD㴕.ԥVqN4qh+MJ_lkK4y~$z;_4鳕&:mK4u~$_4u&/=i+M]JCNuUD봕&/}ݯVo~{|$J_ϗ4kK4yԥVJRiP+M]jIJJSZiR+M^JK4ZiϾDjIJS߂VJS&FUi oK4y)&/}:0[iP+M^JK[imK4u.$J)JFUi[JSZiR*M^ߨ4q4y~ԥT<ߨ4u.$zoVJP+MJS&J>y&.mIߨ4u.JSZi~ԥVJyQ[iR+MFm)J~Է.䥏JSZioVuQ4u&}oVJ_CFmJRiR+M]jIߨ4ZioVԥVFmkKJSZiFmK4u&~ԥVJ>7j+MJ~Է&/=7j+M\J>.FmK4y~jI~Q[i oK4>7j+MwQ[i=7j+M]jK4yݥT:Jq>Q[iP+M]jKJSZi}D}>'j+M|[i'K_&Dm)JS_x+M^zOVJSRi~ZiZi~ԥVJRiR+M]jI4&@m&/=j+MVD.ԥVV8&ҤyVJ.ԥVV4o4V:J~㴕&/}܏VJSRiC_l+MqJSZiR+M^z܏VJ|jIvM[i.$JIߦ4䥏mJSZiR*Mz܏VVJ>i+M]jKqj)Jyk)JS[i~jI~?N[iR+M]jKJġ4yyVVJ>i+MuJ|>[i}ܯVJSZi~ǵԥV_4u)&}:}{U@Ui߯VuN[i翿uJ>_4EoK[i:mIvN[i:mK4yyN[iP+M^>.:mK4y~Ziʴ$wTEuJS߀VJ>i+M}\+M^zܯVJSZi|4W?cK3[- niqK- niqK3[- nif4-AҌf4yK3[AҌ oiqK3[- niqKs4- nif49[A Җf 4_,Җf4Y-"miiK3[EҬіf4Y-"miqKH[E,Җf4Y- niiK?s%miqKH[E f4Y-niiKH[Y-"+EE f4-͢߿~Y- niiKH[E f4-"lihKH[A,Җf4YvQ,Җf4Y- niiKH[E-"miiKH[A,Җf4cY-"miiK3[E,Җf47[E f4-"miiKH[A,Җf4-miiK3[E,z,Җ oiiKH[A,Җf4-"miiK3[E,Җf4Y-"li|hKH[E,Җf4Y-"miqKH[E f4Y- niiKH[Y-"miiK3H[5,Җf4~o4-"miiKH[A,Җf4>Y-"miiK3[E,Җf4k'[5 f4-"miiKH[Y-"miiK3[E,Җf4Y-"miqK[5 ҖfʊY- niiKH[A,Җf4k-"miiKH[A,Җf4Y-͢@qKs4Y- niiKH[E f4-mi8pP- niiKH[A,}?N,Җf4Y-"lipKH[E f4Y- niaKF[YvM,Җf4Y- niiKH[E f4kY- niiKH[A,Җf4-͢[A,z'oiiK3[E,Җf4Y-"lif4Y- niiKH[A,–f4-"miiK3[E,Җf4Y-"miqK[5,Җf4Y-"miqKH[EҌf}F[E-"miiK3[E,Җf4Y-"lipKH[ET-"miiK3C[EҬіf4cY-"miiK3[E,Җf4Y-"miiKF[E|cKM[g9ȕ  W\ir] W\irBG9ȕ W/tT\ir9ȕ Js+:*Ao4JJs+A4_4Js+:*A4JJs+A4_4Js+?4XiJ3f+ V\iҌa9ȕf+ VA4 bJ3 WA4XirJ3f+A4XiJ3f+ Uc\i bBGJ3 b9ȕf+ V\i_ b9ȕf+ VA4 bJs+ U14XirJ3 WAouTA4 bJs+ VA4XiQi bJs+ VA4Ǹ bJ3 WA4XirvQGJs+ VA4 bJ3 WA4XiJ3f+A4Xi bBGJ3 WA4XiJ3f+A4Xi b9ȕf+ Uc\i bJs+ VA:*A4XiJ3f+ V\i bBGJ3f+A4cXiJ3Ff+A4Xi b9ȕf+ V\i bJs+ VA4Ҍy(W14 bJs+ VA4XiQi bJs+ VA4 bJ3 WA4cXib&f+A4XiJ3f*V\i bJs+ VA4 bJ3Hf*V\i bJs+ VA4ҌaEJ3f+A4~ߏQiJ3HfCiJs+ VA4 bJ3 WA4cXi+͘m:* V\i b9ȕf+ VA4 RJ3 WA4XirJ3f*14Ο7W\i bJs+ VA4 bJ3Hf+ VA4 bJs+ U14TiqJ3 WA4XiJ3f+A4Tiư b9ȕf+ VA4 bJs+͠~JJ3f+A4Xi b9ȕf+ Uc\i zT\i b9ȕf*VA4Ǹ bJ3 WA4XirJ3f+A4cXiJ3 OrTA4 bJ3 f+ VA4 bJs+ VA4XibJ3 WA4TiưJ3f+A4Xi b9ȕf+ VA4 bJs+ VA4cXiQi,RJHf*"UA4Pi֨ bYJHf* VE4Ti bYJHf+"UE4Ti,RYJ3f*"UE4cXi,R9ȕf*"Hf+"UE4Xi_,RJHfSJ3f*"UA4Pi֨,RJHf* VEoJHf+"UE4Xi,RYJs+"UE4Ti,RYJ3f*"UE4Xi,RJHf*"UA4Ti y~3Yi,RJHf*"UA4kTi bYJHf*A4Ti bYJHf* VE4Ti,RYJHf+"UE4cXi,RYJ3f*͢F bYJHf+"UE4Ti,RYJs+"UE4TiҬQYJ3frYJ3f*"UE4Xi,RJHf*"UA4Ti RYv?Q4kTi,RYJ3f*"UE4,RYJHf+"UE4Xi,RYJ3f*UA4kTi,RJHf*͠*"UE4kTi,RYJHf+"UE4Xi,RYJs+"T54Xi,RYJ3f*"UA4kTis4Xi,RJ8,RJf*"T14Ti bYJHf* VE4kTibYvM4Ti,RYJ3f*"UE4XiҬQYJ3f*"UA4Ti,BJycJHf*"UA4Ti bYJHf*14Ti,RJHf* VE4kTiҌaYJHf+"UE4Ti,RYJ3Jf*"UA4Ti,RJHf*VEUE4,RYJ3f*"UE4Xi,BJHf-UWA4Ti bYJFf*VE4Ti bYJHf+"UE4TiҬQYJJMJKZi}si+M\JSZiR+͟/Ui 4u&.mK[i JSP+MVġ4u&.m)JJSZiV.ĥG+M\JSZi mK[iR+M]jK[iVB4j)JS߁*͟/UiϾVJRiR*M]jK4y(ԥVD4q4u.TJS&QKJS&Q*M} ZiR*MVDW/.T4ԡVJ$JJRiR+M]jIJS&+TD4-hK4y)&/}oVVyQ[iR*MzoVJSZi=7j+M]jKJS&Fm)JFmKQ\J$zoVJSZiFmC4yqQ[iR+M]jIߨ4u&~jIJyQ[i~ި.$zߨ4y~ZiP+Mߨ4u&/䥯J&/ԥVJqQ[i $zߨ4-hK4yJSJ䥏JSZiR+MFmK4u&/}oVDo&FmoA+M^zoV&/=7j+M}\*MjCJSZiFm)J~JSZi}oVB47j+M} ZiR+M]jKި.ԡVDJSZiR+M^zOVJ'[y?Q[i J'j+MV[i~ԥVJ JSJ .ԥVJS~$J~JP+MJSZiR+M^zT+MJZi<j+M]jKJSZiR+M^zT+M}JS_t+MiI~?N[i J>i+M]jK4y_&8mK4u&/=i+M]jI~>N[iҤyߦ4 JSZi$zoV[i6mK4u)&=i+M}Z+M]jK㴕.8ҔiItj4yq?N[i $z4u.䥏ujC[iVr`+M}\+M]jK봕&:mIuN4>i+M]jK4yqN[iZiR+M^zޯVx;_4yU@Ui߯VuN[i翿uJ>_4EoK[i:mIvN[i:mK4yyN[iP+M^>.:mK4y~Ziʴ$wTEuJS߀VJ>i+M}\+M^zܯVJSZi|4W~Q-:4yKs4yK4yKs4yK-A-:4yKs4yK󅼥9[Bǖ oioiб9[Boi oi [9[Bǖ oi [9[c][A oiqK3[A- mipKs4- nif4-A f4yK3[A oiqK3[ niiKs4-:4([- nif_-A f49[A oiiK3[A- niqKs47 oiqK3[- niqK- niqK3[- mif4-A f4yK3[A oiqK3[Zi҃[A oiqK3[A-niqKs4- niб- nif4-A f4yK3[A oiqK3H[c- niqKs4- nif49[AouliqKs4-:4- nif 49[A7 oiqK3[A- niqKs4- nif49[1o-nif49[A f4_ fS y4yK3[A- niqK3[-nif 4-A f4=- mipKs4- nif49[A f4_ Җf 4yK3~- nif49[1 y [- nifq:49[AҌf4xK3[A- niqK3[-ni4c oiqK3[- niqKs4- nif49[A f4xK3y{pKs4- nif49[A f4_ fˁcKs4-A Җf 49[A oiqK3[A- niqKs4- nif4-A f4xK3>- niб- nif:[A- niiKs4~K- niqKs4- mif4-A f4yK3[A nipK3[е-4ǰ|'cXha9}scXga9m82s ̗q9YVce !L2ǰ|ccQ958s S̗q9!vca+10<`a2.00e_a}9F̑^ƨQx9eU1.ǰArr 1-cT[al2FeJ1 -cY(2Fe%cXX(Q_9yeŕ1h+0QYeU(џWcUaS2FE111)cTSaL2F)eJ1 )cQ(Ê2e%cXP(Q?9d8Q;9dcM(Q5heL(y1%cKƠX2FdRcJƨQ&9d"51J$ǰQ >r Ց1#cFa22Fad1"CTE(&2FId/2F9dj1!cB(Q 9!d:ecXA(Qr 10Q1F1*c>ƨ{1Fc1lc<ƨxQ8crՎ/1FcRc:sQ8cqq 1c7a1Fm1*c6ƨkì1FUc1O4!oâ1DA1cT3a1F)cJƗq1Q8c%cX0(`Q|q ċ!j(] Qp1Ff1c-ad1b1c+ƨVQ8bRc*ƨSQJE)ƠQ Q8b1ǰNQ6q1?X1cT%(J&1ܸHQ8=b rՈ1EQq Cu1cT!a1D ˰@ y;_1ǰ>Q|p 1 cav0Da1LcT(80FajĆC\?^, <ƨ3Qfp #51J ǰ0Q`0yዸ.Q\0Fi1 caV0DQa !L cT((Þ0F9ajńc(%QI8!a :e10"QC0F1ca=sQ;te\(Q78`E1j0Q1`p{1o_:V0F`J1 c (A%8`%1*0Q

!/}oV쐇.<ԥDߟq7jC^zoB 7jD6D7j+D^v!"~6Eԥ>7jsDjK"Q$RDFmKaPD6Q߂Ɖ:>7jD]jH~Q(F5RԡVncE^JKu"~XjH~Q-[jQ-7K Z..|6^ԡ֋qQ/RF]jHߨmu.bڎ~d$ߨm-hKڜgFmѨKҨCmyyQ[5RF^ߨ Z6oԶ7RFھQ#FmoAG]jKy).=sԡ:Q;~6wԥD |.~ԥ<_<_m u.dRBM Iy?PBn KR=$@mKM"uM$/%䥯,E<jH]jK8RZGRH^zTI}DR_tIi$I~?NI P>iSI]j+K%y_$8m1KM&u$/=iI]j6I~>NNyߦm' xRZO%$zo[PRJ^JCK(u)%=i;J}ZCJ]jIK-.585iOItjRϷqڨ(UPJqڰRZVRJ^_ƕ8u%m^K/6ǵԥ&yNYfD_В~6ԥؒ봹>.5:mrKi.yC~6䥯uR>Mo/}֗D:m/z L\>i#Lu iCL]jKuSc-1q1uA&/=iL]JC*SY&ѿ-zܯӖ4ԥyN[gg~6ԥ:DW*o/'A^o|cqyqkq7yqW_qAr|cqyq_kc<8{/t : N: 8ȳ/t: /; ێ<8뎃cW8A~ cy1A\ ?q2 < @irg !: 8(c9 A d_'8 MA *dg! 9ÐA\ 4 oCoԱyAއ @d"=9vQHdW"y&2;A NEq+2c/tEq.2{A NFi3rG#7꘍ n Gq92ӑ Gq>r#8 A dG$"93Aܑ zoԱ$9S1ܒ IqN2{A|cQ2AܔQ JqV2<,e NKd%.yAޗ d&xb2A Lqg2CA\ nMqlr&87Ľ Nd''9BdW'8;Ad'y{2FA Pq2A P eFCA\) nQqrSk1o=R"e')I9ȣA\ ,ew)_ 2e)M9A\ < Sq2 A Tprg*cSġ .UTe*8V9kA ^e +y2A:F+y2Aܭ .Wq2Hە/sWi2󕃼_ .Xqr7,8bAe\) nYqr,~ߏӱgAA^ Ҥe 7-4j9ƫA [ݏ1mmA Һe -_1ot,\qr7.8rĕA e.t9SAںe.y2{A N^q2Hcztyr/| n_e/89A f&0_ fW089;A  Oai 3cAZ9 aqs18M b*fg19ØAZƌ4f1y3A > dq!3HctJfg2_ Pf2y*3[A Z eq/3Hc̠[h fq63<Ngi;s3 gf489AothqFsw4c8%? zÖڵ b9ȕf+ VA4_4Xi b9ȕf+ V\i bJs+VA4 bJ3 WA4XirJ3f+A4Xi b9ȕf+ V\i RJJHf* VE4Ti bYJFf+"UE4Ti,RY_ bYJHf+"UE4Ti,RYJ3f*"UE4cXi,R9ȕf*"Hf+"UE4Xi_,RJHf*"UA4Ti bYJFf* VE4Ti,z(WE4Xi,RJHf*"U\i,RYJ3f*"T14Ti,RJHf* VE4Ti bYJHf+"UE4Ti,RY(WA4kTi bYJHf*A4Ti bYJHf* VE4Ti,RYJHf+"UE4cXi,RYJ3f*"UE4Xi,RJHf*"UA4TiJHf*"UA4kTi bY~\i bYJHf* VE4Ti,RYJHf+"UE4TiּO+UA4Ti bYJHf*A4Ti,RJHf* VE4Ti bYJFf*UE4Ti,RYJ3f*"T54Xi,z+ VE4Ti,RYJWE4kTi,RYJHf+"UE4Ti֨,W*Ti,RYJ3fqrYJ3f*UE4cXi,RJHf*"UA4Pi֨J~\i bYJHf+"UE4Ti,BYJHf+"UE4Xi,RYJ3fJ3f*"UE4Xi,RJHf*"Tc\i,RYJ3f*"UA4Pi֨,BJHf* VE4Ti bYJHf+"T54Ti,RYJHf+"UE4cXigTiJHf* VE4Ti bYJf +"UET]i,RYJ3f*UE4cXi,RYJ3f*"UA4Ti,RJFf*:*͢7Uo}٫JJs+A4Js+A4|Js+:*A4J\iq9ȕ  WXiqBG9ȕ W/tT\ir9ȕ  W\irBG9ȕ W/tT\ib9ƕtUA4XirJ3f+A4TiưJ3f+ V\i bJs+ VA4 bJ3 WA4XidJ3f*14Xi| b?J3f+A4~xXiJ3f+ V\i b9ȕf*VA4 bJs+͠:* V\i b9ȕf+ VA4_4Xi b9ȕf+ Uc\i bJs+ VA4 bJ3 WA4XirJ3f+A4Xi b9f + V\i bJJ3f+A4Xi b9ȕf+ V\i bJs+ VA4Ǹ bJ3 WA4XiJ3f+A4Xi b9ȕf+ V/tTA4XiJ3f+A4~oQiJ3f+ V\i b9ȕf+ VA4 bJs+͘rJs+ VA4 bJ3 f+ VA4 bJs+ VA4XirJ3 V14XiJ3f+A4XiҌa9ȕf+ VA4 bJs+͠:* U/sTA4cXirJ3f+A4XiJ3fϿ:Js+ VA4 }?NGJs+ U14TiqJ3 WA4XiJ3Hf +rvMGJs+ VA4 bJ3 WA4cXiJ3f+A4Xi R9ƕfJs+ VA4XirJ3 WA4Xi| bJ3 WA4XirvNGJs+ VA4 bJ3 WA4XirJ3f+A4Xi b9ȕf+ Uc\igXi| bJs+ VA4XirJ3HWA4o WA4XirJ3f*14Xi b9ȕf+ V\i bJs+VA4 zS?4 4f7ĥ4u._P+͟?JSZiVP+M4Zi joA+MJSZiVB4q4u&mK[iR+M\JԥVB4q[iVJSZiVP+M4Zi ҔiwJKUD>.TJSZiR*MJC4u&Q*M~\*M]jK4y)&/jI?jI_UJS&FUi oK4y)&/MC4u&/ĥ4RiTJSZijI{|4-hK4y)&/}oVVyQ[iR*MzoVJSZi=7j+M]jKJS&Fm)JFmKQ\J$zoVJSZiFmC4yqQ[iR+M]jIߨ4u&~jI~Q[i[JSZiFmK47j+M^ߨV:J>7j+M]jK4y~mK4u.$zoVB47j+M} ZiR+M^zF}{~ǵFmC4y~ԥVJqQ[iR+M]jK&FmIuQ[i[J&.mKJSJSZi~ԥVqQ[i $zߨ4ԥVDP+MJS߂VJSZi7K4u&|ԡVJ.$}OV·?OԷ'j+MJSV4u.BԇBmK4u&/ԥVJh*MJS_w+M^zVB4>j+M]jK4yq?P4qh+MjI4u&/=j+M]jK4yy?P4ii*M}ѭ4u&8m)JS_x+M^4u.?ӷ~]VD㴕.ԥV4u&8m J~7`+M]jIJyM[i oK۴.ԥT<4i4u&/}ޏVJJS&JS8m)J~ԥVJ>ש&mC[iˁ4q4u&/}ޯVDo봕&:}$_4u.:mkK4yyN[iR*Mu篫mI~N[i:mK귗>i+M~&.mK봕&:mK_봕.:mC4y?VVJ봕.䡏uj)JQ=i+M}ZiR+M^_4q4yqN[iR*MjCu_w349[A f4_ f49[A oiqK3[A-niqKs4-nif49[A f4yK3[A oiqK3[- mipK-"miiK3[E,Җf4Y-miqKH[E,Җf4Y-"miqKH[E fvʊY- niiKH[A,Җf4-"miiKs4YH[A,Җf4YW4-"miiKH[A,Җf4Y-miiK3[E,Җf47[E f4-"miiKH[Y-"miiK3[E,–f 4Y-"miqKH[E f4Y- niiKH[A,Җf4-"miiKH[AҬіf4Y-"miiKs4Y- niiKH[E f4-"miiKH[A,Җf4cY-"miiK3[E,Җf4Y-"miqKH[E,Җf4Y-A,Җf4-miiK3[E7[E f4Y- niiKH[A,Җf4-"miiK3H[5o-miqKH[Ef4Y-A,Җf4-"miiK3[E,Җf4Y-miiKF[E,Җf4Y- niiK[5 f4Y- niiKH[A,z(oiaKs4Y- niiKH[E f4-mi8pP- niiKH[A,}?N,Җf4Y-"lipKH[E f4Y- niaKF[YvM,Җf4Y&oiiKH[E f4kY- niiKH[A,Җf4-͢[A,Җf4-"miiK3K[E,Җf4xKH[E,Җf4Y- niaKF[EҌf4-"miiKH[A,Җf4Y-miiK3[E,Җf4Y-"lipK>-"mif4-"miiKH[A,Җf4cY-͢[ f4-"lihK[1,Җf4-"miiK3[E,Җf4Y-"miбY-Z4|/W\ir9ȕtU\ir9ȕ  W\iQir9ȕ W/Js+A4_4Js+:*A4|Js+A4_4Js+:*A4|Js+14 bJs+ VA4XirJ3 WA4XiJ3f+ V\i b9ȕf+ VA4 bJs+ VA4TiqJ3 f+ 7 WA4Xir[J3 WA4XiJ3f+A4Tiư b9ȕf+ V\ioQiJ3f+A_4Xi bBGJ3f+A4XiJ3f+ V\i b9ȕf+ VA4 bJs+ VA4XirJ3f+A4cXiJ3f+ V/tTA4XirJ3f+A4XiJ3f+ V\i R9ƕf+ VA4 zߨ b9ȕf+ V\i bJs+ VA4_4Xi b9f + V\iߨ b9ȕf+ VA4 bJs+ VA4XirJ3 V1oJ3 WA4XibJ3f+:* VA4XirJ3 WA4XiJ3Hf +A4cXi b9ȕf+ V\i RJs+ VA4XirJ3 WA4Xi| RJs+ VA4XirJ3 V14~չV\i b9ȕfq:* V\iҌaJs+ VA4 bJ3 WA4cXi+͘m:* V\i b9ȕf+ VA4 RJ3 WA4XirJ3f*14Ο7W\i bJs+ VA4 bJ3Hf+ VA4 bJs+ U14TiqJ3 WA4XiJ3f+A4Tiư b9ȕf+ VA4 bJs+͠ + V/tTA4XirJ3f+A4XiJ3f-գJ3f+A4Tiư R9ƕfQf+A4XiJ3f+ VXiư b]fЛ*]g9ȕ  W\ir] W\irBG9ȕ W/tT\ir9ȕ Js+:*A4JJs+A4_4Js+:*A4JJs+A4_4Js+?4XiJ3f+ V\iҌa9ȕf+ VA4 bJ3 WA4XirJ3f+A4XiJ3f+ Uc\i bBGJ3 b9ȕf+ V\i_ b9ȕfп+ V\i b9ȕf*VA4 bJs+͠:* V\i b9ȕf+ VA4_4Xi b9ȕf+ Uc\i bJs+ VA4 bJ3 WA4uTA4XiJ3f+ VXiư b9ȕf+ VA4_4XiJ3f+ V\i b9ȕf+ VA4 bJs+ VA4Xir~QGJs+ VA4 bJ3 WA4XiQi bJs+VA4 }QGJs+ VA4XirJ3 WA4XiJ3f+A4c'ʕf +A4XiJ3f+ V/tTA4XiJ3f+A4Xi b9ȕf*VXiư bJs+ VAO2 WA4TiưJ3f+ V\i b9ȕf+ VA4_4TiưJ3f+ V\i b9f +͠u. WA4Xir~J3 WA4cXiJ3f+A4Xi b9ȕf*V/J3~J3 WA4XirJ3f+A4Tiư b9ȕf+ V\i bJs+͕͠ WA4XiJ3f~J3f+ U/sTA4XiJ3f+A4Tiư R9ƕf+ V\i bJs+ VA4 RJ3 WA4XiJ3f*1434XiQi b9ȕf+ VA4 bJs+ VATJs+ VA4 RJ3HWA4XiJ3f+A4Xi b9f + VUi\iKJ{f7ĥ4u._P+͟?JSZiVP+M4Zi joA+MJSZiVB4q4u&mK[iJԥVB4q[iVJSZiVP+M4Zi ҔiwJKUD>.TJSZiR*MJC4u&Q*M~\*M]jK4y)&/jI?jIJS߂VJS&FUi oK4y)&/MC4u&/ĥ4RiTJSZijI{|4-hK4y)&/}oVVyQ[iR*MzoVJSZi=7j+M]jKJS&Fm)JFmKQ\J$zoVJSZiFmC4yqQ[iR+M]jIߨ4u&~jI~Q[i[JSZiFmK47j+M^JK4u&}oVJRiFmJRiR+M]jIߨ4ZioVԥVFmkKJSZiFmK4u&~ԥVJ>7j+MJ~Է&/=7j+M\J>.FmK4y~jI~Q[i oK4>7j+MVDo4u.?owRiP+MDmC4u&/='j+M]jI-4oKo/}OVDP+M}4yq?Q[iR+M]JC4RiZi~ԥVJ\JSZiMIy?P[inKJS&@mK4u&/=&mC4i.@mK4u&/=&>M/δ$z4Zi oK㴕.ԥT rYJH-RJHf* VE'"UE4Xi,RYJ3f*"UA4Pi֨,RJHf* VErYJ3f*"UA4Ti,R9ȕf*"UE4Xi,BJHf*"UA4Ti bYJHf* VE4Ti,RYJHf+"UE4TiҬQYJ3f*"UE4,RYJ3UE4Ti bYJHf+"UE4Ti,RYJ3f*"UE4Xi,RYJ3f*"UA4Ti,RJHfs\i,RYJ3Hf*"UA4>7ʕf* VE4Ti bYJHf+"UE4Ti,RYJ3HfmXi֨ bYJHf+"UE4TirYJHf* VE4Ti,RYJHf+"T54Ti֨,RYJ3f*"UA4TiҬQJHf*"UA4Ti bYJHf*14Pi֨ Gf*"UE4Xi,z+UE:WJ3f*"UA4>ɕf* VE4kTiҌaYJHf+"UE4Ti,BYJs+͚6,RJHf* VE4Ti bYJFf* VE4Ti,RYJf +͢獕f+"UE4Ti,RYJ3f*"UE4Ǹ,RYJHf+"UE4XiҬQYJ3f*"UA4Ti,RJHf* VE4kTi bYJHf* VE4Piư,Ϩ,R9ȕf*"UA,RYJHf+"UE4cXi,J3f*"UA4Pi֨,BJHf*"UA4Ti bYJHf* U54TiRiTi~*ǿKZirTt*M]jK4/}4Zi^ܷJSZiҩ4qTB4N)JSP+M| ZiЩ4u&.JS&>ġSiҩ4u&.JNK4ZiNKԥVJNKj t*MVB4eZi^UחUD>TJRiR*M]jK4y(ԥVD4q4u.TJS&QKJS&Q*M} ZiR*MVDVi oK4y)&/MC4u&/ĥSiǝJRiR+M]jIJS&}}UԥVJ7TVߨSiR*Mzoԩ4u.$zoԩ4u&/=7TB4>7TB4>7TFrTt*MFJSZiR+M^zoԩ4u&/=7TJSZi=7TJ豿QjIQԷ.FJSZi}oԩ4ykZiP+Mzoԩ4u&/䥯:&>TJSu*MFJS&FJS߂VJ?ި_/7TV\ߨSiP+M^oԩ4u.$zoԩ4u.FJ趿Q$ߨSi[Ju*M\:&/=7TT:FJSZiR+M^oԩ4Zi}oԩ4ԥVD:P+MFJS߂VJSZiۥT:J>QԡVJu*M]jItD^u*M|'K_u*MDJSV؟SiR+M]JCjkC:.ԥVJSZiR+M4i^u*M}ݭ4y?PjItSiR+M]jKjCġV4:.@JSZiR+M^zT+M>M/δ$Si Jt*M]jK4yqן;&}NK4u&/=TJs}N J涿M7TJ(&Q*MV[i}NK4u)&=TVJ^t*M]jKqj)Jhyk)JSVSi $SiR+M]jKujCġSisǁSiZiR+M^zө4nt*Muz$ө4u.TD_t*M]jKu:.C?[$_Si:JS^?SKu:&~汿N}*M\:&/TDu:&/}ө4u&/=T:JoJSJSZisNK4y辿N4eZi_cNo@+M]jKu:>&/=TJSZis}UחU^z?Gۖ oiѲ9[9[Ѷ9[9[oli oiѲ9[9[o-1-7Z4yKs4xK-A-7Z4yKs4yK-A-A|eKs4yK-A-1- niqKs? f49[AҌ oiqK3[A-͠OmqK3[- nif4-A f4yK3[A ҖoiqK3[oliqK3 nif49[A f4yK3[A oiqK3[-niqKs4-A oԲ-A f4yK3[A -[A f4yK3[A- niqK3[- nif4-A f4yK3[A oiqK3[A-niqKs4- niѲ- ni[A f4yK3[A- niqK3[Q- niqK3[- niqKs4-A f49[A -[A f4qK3[A-͠Z49[A f4yK3[A- niqK3[-͠ƃs۟(oipKs4-A f4F˖f4-A f4yK3[A oiiK3[- niqKs4-A f4c9[AliqKs4-A f46˖f4c9niqK3[A- niqKs4ct=p-A f4yK3c- nif4c-1 f4yK3[A oiiK3?NҌoӲ-A f4yK3[A oiiK3[A- niqKs4- mif-A f49[A oiqK3[A|eK3[A oiqK3[-niiKs4-A f49[A oiiK3[A-͠uZ49[A Җoig-7Z4-A f49[A zӲ-͠[˖ oiqK3[-niiKs4- nif49[A f4qK3[Auڶ4nu* V\i bJJ3f+ V\i b9ȕf+ VA4ҌaT9ȕf+ U14 bJs+ VA4XirJ3f+A4XiJ3f*VoTE4Ti,RYJHf+"T54Xi,RYJ3f*"UE4Xi,RJHf*"UA4Ti bYJHf*VE4TirYJH-RJHf* VE'"UE4Xi,RYJ3f*"UA4Pi֨,RJHfs\i7ʕf* VE4Ti,RYJH WE4Ti bYJf +"UE4Ti,RYJ3f*"UE4Xi,RJHf*"UA4Ti,RJFf* VE4TiJHf* VE4Ti PYJHf+"UE4Ti,RYJ3f*"UE4Xi,RYJ3f*"UA4Ti,RJHf*A4Ti,RJFf* VEJHf+"UE4Ti,RYJ3f*"UE4Xi,zYJ?Q4kTi,RYJ3f*"UE4,RYJHf+"UE4>Ti,RYJ3f*UA4kTi,RJHf* VE4Pi֨ bYJHf* VE4Ti,RYJWE4kTi,RYJHfЇ*"UE4Ti֨,չ UA4Ti bY?N4Ti,BYJf +"UE4Xi,RYJ3f*UXiɕf* VE4Ti,RYJHf+"T54Ti,RYJ3f*"UE4cXi?o4Xi,RYJ3f*"UA4Ti,B9ƕf*"UE4Xi,R}Yi֨,BJHf* VE4Ti bYJHf+"T54Ti,RYJHf+"UE4cXigTiJHf* VE4Ti bYJf +"UET]i,RYJ3f*UE4cXi,RYJ3f*"UA4Ti,RJFf*7Z*͢*Ϳ*A4h4Js+Ϳh4Js+7Z*A4|Js+A4ȕW\iRir9WoT\irFK9ȕ W\iRir9ȕ WoT\irFK9ȕ Vc\iE[J3 WA4XiJ3Hf +A4Xi b9ȕf+ VA4 bJs+ VA4XirJ3 WA4XiJ3f+7Z* VAo+A4XiJ3CJ3 WA4XiJ3f+A4Tiư b9ȕf+ V\i7j4XirJ3 WA4Xi| bJ3 WA4Ti`J3f+A4XiJ3f+ V\i b9ȕf+ VA4 bJ3 V14XirJ3f+7Z* VA4 bJ3VA4XirJ3f+A4XiJ3f+ V\i bJs+ VA4 bJ3 WA4XiRi bJs+͘Z*A4>7j4XirJ3f+A4XiJ3f+ V\i b9fm\iưJ3f+A4Xi bFKJ3f+A4XiJ3f+ V\iҌa9f + VA4 bJs+ VA4cXirJ3f+A4XiJ3f+ UoTA4cXirJ3f+A4XiJ3fEJ3f+A4>i4XirJ3f*14XiJ3f+ V\iҌaF4cn۴TA4 n WA4XiJ3Hf + V\i b9ȕf+ VA4Ǹ Z\irJ3f+A4XiJ3f+ UoTA4XiJ3f+A4Tiư R9ƕf+ V\i bJs+ VA4 RJ3 WA4XiJ3f*1434XiRi b9ȕf+ VA4 bJs+ VATJs+ VA4 RJ3HWA4XiJ3f+A4Xi b9f + VViTi>oA4~t*M\:.ԥVחUB4?[K4qTt*MV@j)JS&4qT:JN)JJSZiЩ4qTJNKԥVB4qĥSiR+M]jKĥSi :P+MT24*K*MWJSZiR*M^JK4uc*MJC4u&Q*M~\*M]jK4y)&/jIjIJS߂VJS&}}U[iR+M^JKSiP+MjK4qTD4qTJSZijI1Ct_ߨo4u&/䥯:>&/7TJu*M]jK4u*M]jK:P+M:P+M:&/~Q\:&.J蹿QԥVJ^u*MjK:.ԥVD:.$zoԩ4Zi}oԩ4-hK4y龿QԥVDu*M^ߨV:J^u*M]jK4ykN;&/ԥVJ豿QjIQԷ.Ǐ7K:>&/=7T:Ju*M]jK4u*M]jK4y鵿Q$oԩ47TFJNK:>.FJSZi}N)JsN/.$oԩ4Zi7TԥVJ?ި.ԡVD:ԥVܟSiR+M'WڟSi ?&/=>TB4in4V:JsN)JS_x+M^ө4u.ǏC_TDq:.ԥVSiR+Mq:&P+M6J߀SiR+MTDm:VtߦSiR+M]JCq:>.8JSZicZiʴ$ZZi &/=TB4>TJSZi}ZiЩ4qTqTVJ^t*M:Jk}^4t*M]jK4y鱿NǵԥV_SiR*Mx~=*Mu:&/}ө4u7UZ_Sigt*M|ѧĥSikNIt_Si:JSZis}NC4y?4q4u&/=TJJS&Q=TԥV_SiZicNK4u&=[y}[ۥmiqKs4- niѲ- niqKs4-A f49[1 oiqK3H[1- niqKs4- nif4-A f4yK3[AҌ-[E,Җf4Y-"miqK[5 f4Y- niiKH[E f4-"miiKH[A,Җf4Y-"miaK3[E,Җ oiiKH"miqKH[E fǟW4-"miiKH[A,Җf4Y-miiK3[E,Җf4n-"miqKs-"miiKH[Y-"miiK3[E,–f 4Y-"miqKH[Ef4Y- niiKH[A,Җf4-"miiKH[AҬіf4Y-"miiKs4Y- niiKH[E f4-"miiKH[A,Җf4cY-"miiK3[E,Җf4Y-"miqKH[E,Җf4Y-A,Җf4-͚f4>7[E iKH[E,Җf4Y- niiKH[E f4-͚DqKF[A,Җf4Y-"miiKs4Y-"miqKH[E f4Y- niaK湿PҬіf4-"miiK3[E,–f4Y-"miiK3[E,Җf4Y-"lif4k-"miiKH[A,Җf4Y-͢ˁ miqKH[E f8yKH[A,–f4-"miiK3[E,Җf4Y-mifmY- niiKH[A,Җf4tӖf4kY- niiKH[A,Җf4-͢[A,Җf4-"miiK3[E,Җf4xKH[E,Җf4Y- niaKF[EҌf4-"miiKH[A,Җf4Y-miiK3[E,Җf4Y-"lipKh?-"mif4-"miiKH[A,Җf4cY-͢[ f4-"lihK[1,Җf4-"miiK3[E,Җf4Y-"miѲYtÖ]q[+A4h4Js+Ϳh4Js+7Z*A4|Js+A4ȕW\iRir9WoT\irFK9ȕ W\iRir9ȕ WoT\irFK9ȕ Vc\iE[J3 WA4XiJ3Hf +A4Xi b9ȕf+ VA4 bJs+ VA4XirJ3 WA4XiJ3f+7Z* VAo+A4XiJ3CJ3~~3]i b9ȕf+ V\iҌaJs+ VA4 oRiJ3f+A4Xi bFKJ3f+A4XiJ3f+ V\i b9ȕf+ VA4 ߨJ3f+ V\i bJs+VA4 bJ3-f+ V\i bJs+ VA4 bJ3 WA4TiqJ3f+A4Xi b9ȕf+ V\i bJs+ VA4h4Xi b9f + V\i}oRitcJ3f+A4XiJ3f+ V\i b9fm\iưJ3sJs+ VA4XiRi bJs+ VA4 bJ3 WA4cXibJ3f+A4XiJ3f*V\i bJs+ VA4 bJ3H,f*V\i bJs+ VA4Ҍats4 bJs+͠qZ* V\iҌaJs+ VA4 bJ3 WA4cXi+͘6-f+A4XiJ3f+ V\iҌaJs+ VA4 bJ3HWAϛ+A4Xi b9ȕf8- WA4Xi| bJ3 WA4XirJ3f*14XiJ3f+ V\i b9ȕf*VA4 bJ3 WA4TiqaJJ3f+A4Xi b9ȕf+ Uc\i T\i b9ȕf*VA4Ǹ bJ3 WA4XirJ3f+A4cXiJ3J=mh{yu㔙7e^hyq[y)Zc^|ʷF;̫'¼q KJR4./E˫?m{˫Ɩ'ZZ^8hcy) ,/O:qʫѨ)*nF[KѐSNEyu$7O^h~7R]hwy]ߵx,/).Esk 'Ӷ⻼ф7^pʽOiw}{'Z]߸//.o4һBZ\^S]hbw}㾼 '-2+mPwy5ݵ//.E#kq[^]i]h8wy珗n\ޅFncyNvyaVm7]hvy1۵g4l_hY8ڥhv-˳p.oUXVjW'Nvu}5x.).o4KX]hvy),4BUl{vyٵ\]f_icI86f7]xx+I8Ed7ڒ]x,O©.o4!~N0S`*"Al>` vEHkT! aCXH%ac"EJ T1,,B[Xp Ú63,RjڰHa fE*? bX F!bZ E*%K,RX:b Ţ獥bc"EJT-1\,RX|1c""uEHǸf,RXHYc"ōE8rQX1c"EA>~,RHdJ ƐE!kD bY6Hyd FE$Jư,Ϩ,R69d"AL(TQ),RKĜHEevEJ+o: TcY̲Hec"5J.P]0,R{YHf#"uEJ1Xc),RY,3Hef"o$E7U[]P+VJNK4uoP+ViR+M\:&.JS&Щ4Zi joA+M:ĥSi ǵԡV8t*M\:.ĥSiҩ4uP+M|ܩ4qTJSZiҩ4qTB4N)JSg?J;Ҽ$ǵԥV~4u.T:JSZiǥԥO}vR*M^J)J.qVD4-hK4Zi7[/.TglC4y)&.J(&>TJSZiR+MTB?EO7TB4>7TFrTt*MFJSZiR+M^zoԩ4u&/=7TJSZiǵԥVD:P+M:4u&/7TJsNK_JSZikNK4y)&/}oԩ4qTJSZi=7TB4>7TԥVFz鵿Q}FJSZi}NK4u&Q*M~FJSZikNItߨSi}oԩ4-hK:&.Ju*M}\*MjC:.FJS&FJS_x+M]jItߨSi $oԩ4-hK4u&/=Q]JC4u*MjK4y?QԥVD4^u*M|'K_u*MDJSV؟SiR+M]JCjkC:.ԥVJSZiR+M4i^u*M}ݭ4y?PjItSiR+M]jKjCġV4:.@JSZiR+M^zT+M>M/|?N$zө48JSZiR*Mzx~=g{NItSiR+M]jKq:.$\SiҤoө4 8.$JIߦSi oKm:.ԥT<SiZiR+M^zө4u&/=ǩL+M筕P+M[icN)JsNK4u&/ש&JNKNkK4y鵿N$ө4J辿NԥVJt*M}\+M]jKu:.C?[$_Si:JS^?SKu:&~汿N}*M\:&/TDu:&/}ө4u&/=T:JoJSJS>?Tt[]JCuj)Jt*M}ZiR+M^zө4q4y鱿NԥT:JҼoVirFK9ȕ W\iE[9ȕ W\iRir9ȕ- W\irF4ǸJJs+A4Ǹ|Js+7Z*A4JJs+A4|Js+7Z*A4J/* VA4 bJ3 WA4cXirJ3f+A4Xi b9ȕf+ V\i bJs+ VA4 bJ3HWA4XiRi XirJ3 WA' VA4 bJ3 WA4XirJ3f+A4XiJ3趿QKJs+ VA4 bJ3-f+ VA4 bJs+ VA4XirJ3 WA4XiJ3f+A4Xi b9ȕf+ VA4ҌaJs+ VA4XiRi b9ȕf+ VA4 bJs+ VA4XirJ3HWA4XiJ3f+ V\i b9ȕf+ VA4 ߨ| bJ3 V14XirQKJs+ VA4XirJ3赿QKJ3f+A4XiJ3?Q4cXirJ3 WA4Xi| bJ3 WA4XirJ3f+A4TiưJ3f+ V\i b9ȕf+ U14 bJ3 WA4XirJ3f*ͷY* U14 bJ3 WATXiư չV\i b9ȕf8-f+A4Tiư R9ƕf+͠8-f+ VA4 RJ\ii4XirJ3 WA4XiJ3Hf + V\i b9ȕf+ VA4Ǹ Z\irJ3f+A4XiJ3f+ UoTA4XiJ3f+A4Tiư R9ƕf+ V\i bJs+ VA4 RJ3 WA4XiJ3f*1434XiRi b9ȕf+ VA4 bJs+ VATJs+ VA4 RJ3HWA4XiJ3fkJ3f+ VXiư bmf m3oNKԥVJҷJS}4u&.JN)J t*MVB4Zi[JNC4qTB4q4u&JNK4qTt*M]j)Jw*M\:.ԥVt*M\:P+MSi zҼ|4/}4kK4ygViR+M]JC4u.$JɏKK4u&/TB4w_ZiԷ&/jIt_ߨoVJRiןTt*MTSiR*M]jK4Ri $!oԷJS߂VJRiFJSJ^u*M]JC:.ԥVD:.FJS&FJS&FJ^?ި_.JNIߨSiR+M]jK:FJSZiR+MFJSZi=7TB7TD:.FJSZi}oԩ4ykZiP+Mzoԩ4u&/T@ǝJRiR+M]jIߨSi $ߨSi[JSZiFJSJu*MjK:.ԥVD:.ԥVߨSi7TD_u*M} ZisNKFJSJSZisNK4y龿QjIQJSZi7TB4nu*M} ZiR+M]jKooRiP+MDJSZiR+M^zOԩ4u&+zOԩ4J?_/}Oԩ4u*MV[icNK4u)&=>&=TtgNK4u.$J?PJu*MVD:.ԥVV8t*MjISiR+M^zԩ4u.@ҤT[iL+Mq:P+M}4y?NԥVJ?_}SiTJSZicNK4>T@4int*M|NK4Ri=T[i}NK4u)&=TVJ^t*M]jKqj)Jhyk)JSVSi $SiR+M]jKujCġSisǁSiZiR+M^zө4nt*Muz$ө4u.:JSwgNKu:.C?[$_Si:JS^?SKu:&~汿N}*M\:&/TDu:&/}ө4u&/=T:JoJSJSZisNK4y辿N4eZi_cNo@+M]jKu:>&/=TJSZis}UחU^- nif4-7Z4- nif4^- niqK3[- nif4-AwniqK3[- niqKs4- nif49[A Җf 4h,Җf4Y-"miiK3[EҬіf4Y-"miqKH[E,Җf4Y- niiKH[E f4-"miiK[1,Җf4yKH[EiK3[E,Җf4>\Y- niiKH[E f4^-"lihKH[A,Җf4Yt(oiiK3[E,Җf4Y-"mif4Y- niiK[1,Җf4-"miiK3[E,Җf4,Җf4Y-"miiK3[E,Җf4Y-"miqKH[E,Җ oiiKH[A,Җf4-"miiK3[E,Җf4Y-"lipKH[E,Җf4Y-"miqKH[E f4Y- niiKH[Y-"miiK3H[5,Җf4>7[E f4Y- niiK赿Q,Җf4-͢O'-͚DqKF[A,Җf4Y-"miiKs4Y-"miqKH[E f4Y- niaKF[AҬіf4tזf4-"miaKF[A,Җf4-"miiK3[E,Җf4xK[5 f4Y- niiKH[AҬіfA4Y-"miqKcY- niaKF[EҌf4-"miiKH[A,\'oifmY- niiKH[A,Җf4-"lihKH[A,Җf4Y-"miaK3[E4Y-"miiK3[E,Җf4Y-"lif4Y- niiKH[A,–f4-"miiK3[E,Җf4,Җf4Y-miiK3[E,Җf4Y-"lipKh?-"mif4-"miiKH[A,Җf4cY-͢[ f4-"lihK[1,Җf4-"miiK3[E,Җf4YN|eK-ͿմU\iRir9ȕ WVir9ȕ WoT\irFK9ȕ W\i+14|Js+14h4JJs+A4|Js+A4h4JJs+A4ǸJ3f+A4Xi b9ȕf*V\i bJs+ VA4XirJ3 WA4XiJ3f+A4Xi R9ƕf+ VoTA4 V\i b9ȕfЇ'f+A4Xi b9ȕf+ V\iҌaJs+͠Z*A4nTA4 bJs+ VA4XiRi bJs+ VA4Ǹ bJ3 WA4XirJ3f+A4XiJ3f+ V\i bJs+VAZ* VA4XiRi b9ȕf+ VA4 bJs+ VA4XirJ3HWA4XiJ3f+ V\i b9ȕf+ VA4 bJJ3f+ VXiư b9ȕfF-f+A4Xi b9ȕf+ V\i bJs+͠O/˃Xibs۟(W14 bJs+ VA4XiRi bJs+ VAZ* VA4XirJ3 V14XiJ3f+A4XiҌa9ȕf+ VA4 bJs+ VA4TiRiҌa9ȕf+ VA4 bJs+VA׿:Js+ VA4  b9ȕf*VA4Ǹ bJs+ VA4XirJ3ҌoRiJ3f+A4Xi b9ȕf*VA4 b bJ3HWAϛ+A4Xi b9ȕf+ V\i bJmJ3f+ V\i b9ȕf*VA4Ǹ bJs+ VA4XirJ3 WA4cXiJ3f+ V\i R9ƕf~f+7Z* VA4 bJ3 WA4TiqJ3?RirJ3 WA4cXiJ3f+ V\i b9ȕf+ VA4ҌaJ/*͠*(]* V\i bJJ3f+ V\i b9ȕf+ VA4ҌaJs+ VA4cXirJ3 WA4XiJ3f+ V\i zJ3f*VoTE4Ti,RYJHf+"T54Xi,RYJ3f*"UE4Xi,RJHf*"UA4Ti bYJHf*VE4TirYJH-RJHf* VE'"UE4Xi,RYJ3f*"UA4Pi֨,RJHf* VErYJ3f*"UA4Ti,R9ȕf*"UE4Xi,zo+"UE4Ti,RYJ3f*"UE4Xi,RJHf*"UA4Ti,RJFfk\i,RYJs+"UE4Xi,RYJ3f*"UA4Ti,RJHf*VE4Ti z,RYJHf+"UE4Xi,RYJ3f*"U\i,RYJ3Hf*"UA4>7ʕf* VE4Ti bYJHf+"UE4Ti,RYJ3HfmXi֨ bYJHf+"UE4TirYJHf* VE4^JHf*"UA4Pi֨ RYJHf* VE4Ti,RYJFf+"UE4Ti,RYJ3f*"UE4Ǹ,BYJ3f*"UE4Xi,RJFfU bYJHf+͢qrYJ3Jf*"T14Ti bYJHf* VE4kTibYs&WE4Xi,RJHf*"UA4Pi֨,RJHf* VE4TiҌaY bYJHf* VE4Ti,RYJWE4Ti bYJHf+"T54Piư,RYJ3f*"UE4Xi,RJf*"UA4Ti,RJHf*VEUE4,RYJ3f*"UE4Xi,BJHf-UWA4Ti bYJFf*͘*"UE4Ti,RYJ3f*"UE4Ti֨,RFKYtS[/ymhh^9&4ĝw03/?[;m34)3af^e4˄i (&I2qEd´Ǽ8̉1wb^9%bN;Lfןu*;'ĝ6)09%LKė m//;Kuw]NKIt;m.q'ɥΤęR&>+%4ĝRwRZ4^eY<o%m,u'%L K|+57ĝ֕Rwę8ӲRwV^9]L:U$ĝ6ӤR&E%LJ|)goL;m)u')| )Y(u絾:ĝD:X_PN Ji@)\_ONIyi'aN| 'aM|Ω&u;sI`wKNsIymΉ%q:'ai!8ԝܜwc}n5~Z44ğ$w}}o^9usI Y- qad29Q޼Ӟwc}oNLjK;M u繾7'$ĝt:svgmoޜPwymͩe#9{;'ԝޜlP涾7'ԝ9 ԝޜ^g ۗ'gĝ\ߛ N:AM+AF2?7XߛSO@wk}oNj;9i ę:ޛoYoUw^O8ۍol7v o7v_m7v o7v-ۍ8ۍol7v o7vyqyAn1n|eqyAnAn|eqyqhnAn|eqqqm1ۍAn n7q1ۍn7vcAn vc8ۍAn v n7vc}}An vc8ۍAn v-ۍAn 'ۍ n7vcAn vc8ۍAn v o7i1ۍAn n7qqnl7qqAn vcFvcAn vcx1ۍAn v o7q1ۍ n7qqAn vc8ۍAn vcq1ۍAn n7q1ۍol77jn n7q1ۍ n7vcAn vcx1ۍAn v n7vc8ۍAn vcy1ۍAn|e1ۍAn v n7p1ۍQvcy1ۍAn v o7q1ۍ n7qqAnOc8ۍAn v o7q1ۍAn|e1ۍAn v o7q1ۍ n7qqeqc n7vc8ۍAn vc y1ۍAn v o7q1ۍ n7im m7pq n7vc8ۍ1n GpqAn e1?Nvcc1n vcy1ۍAn v o7i1ۍoƘ6-ۍAn n7qq n7vccAn vcy1ۍAn vo7?on n7q1ۍ n7vcƷY n7vc8ۍAnvcx1辿Nv o7q1ۍAn n7qq n7vcAn vck}Ơ Fvc8ۍAn vcy1ۍAn n7R]y1ۍAn m7p1Hۍc n7qqAn vc8ۍ1n v_m7ݰs4XirJ3f+7Z* VA4XirJ3 WA4XiJ3f+A4XiҌa9ȕf+ V\i bJs+ VA4XirJ3 WA4Tiư|,RYJ3f*"UE4XiҬQJHf*"UA4Ti,RJHf* VE4Ti bYJHf+"UE4Piư,RYJs+"UEo* VE4Ti,?,z bYJHf* VE4Ti,BYJHf+"UE4Xi7ʕf* VE4Ti,RYJH WE4Ti bYJf +"UE4Ti,RYJ3f*"UE4Xi,RJHf*"UAOUE4Ti RYJHf+"UE4TirYJHf+"UE4Ti,RYJ3f*"UE4Xi,BJHf*"UA4Ti,RJHf* VE4Ti bYJH WE4Ti RYJHf+͢rYJ3f*"UE4Xi,RJHf*"UA4Ti RYs۟(V54Xi,RJHf*"U\i,RYJ3f*"UA4Ti,RJf* U54Ti bYJHf+"UE4kTi=Ui,RYJ3f*"UA4Ti,B9ƕf*UA4Ti,RJHf* U54.uBf+"UE4Xi}쏓+"UA4Pi֨,BJHf* VE4Ti bYJF V5mrYJ3f*"UA4Ti,RJf*"UA4Ti bYJHf*VE+ VE4Ti bYJHf+"UE4PiqYJHf* VE4Ti,BYJf +"UE4Xi,RYJ3f*"UA4Pi֨,RJHf* VE4Piư,Ϩ,R9ȕf*"UA4Ti,RJHf*VE4o bYJHf+"T54Piư,RYJHf+"UE4Xi,RYJ3Hf*"UoTE7U_JJs+A4Js+A4|Js+7Z*A4J\iq9ȕ- WXiqFK9ȕ WoT\ir9ȕ=]ir9ȕ WoT\irFK9ȕ Vc\iE[J3 WA4XiJ3Hf +A4Xi b9ȕf+ VA4 bJs+ VA4XirJ3 WA4XiJ3f+7Z* VAo+A4XiJ3CJ3 WA4XiJ3f+A4Tiư b9ȕf+ V\i7j4XirJ3 WA4Xi| bJ3 WA4TiqJ3f+A4XiJ3f+ V\i b9ȕf+ VA4=Yi bJs+VA4 bJ3-f+ V\i bJs+ VA4 bJ3 WA4TiqJ3f+A4Xi b9ȕf}Js+ VA4XirJ3-f+ VA4ҌaJs+͠Z* V\i bJs+ VA4 bJ3 WA4Xibs۟(W14 bJs+ VA4XiRi bJs+ VA4 bJ3 WA4cXibJ3f+A4XiJ3f*V4Xi b9ȕf+ V\i bJmJ3>PK9ȕf+ VA4 bJs+VA׿:Js+ VA4  b9ȕf*VA4Ǹ RirJ3f+A4Tiư|#W1mZ* V\i b9ȕf+ VA4 RJ3 WA4XirJ3f*14֟7W\i bJs+ VA4 bJ3H,f+ VA4 bJs+ U14TiqJ3 WA4XiJ3f+A4Tiư b9ȕf+ VA4 bJs+͠ + VoTAwUA4 bJ3 WA4TiqJ3?RirJ3 WA4cXiJ3f+ V\i b9ȕf+ VA4ҌaJ/*͠*Q{}4?/ j˥Siҩ4u.Ҽjyq*M]jKĥSi :P+MVB4-hCԡVt*MVV:JNKԥVt*M\:.j;&.JSZiR+M\:&.JS&Щ4Zi ҔiyVi^_ViVJRiR*M]jK4y(ԥVD4q4u.TJS&QKJS&Q*M} ZiR*MVDVi oK4y)&/MC4u&/ĥSiǝJRiR+M]jI)8YS)!5F)FAyZ,z !gRxRi $!oԷJS߂VJRiFJSJ^u*M]JC:.ԥVD:.FJS&FJS&FJ^?ި7NK$zoԩ4u.FJSZicNK4u&sNK4u*MVDu*M} ZiR+M^oԩ4u&FJ7FJSZiR*M^ߨSiNK4u.$zoԩ4Zi}oԩ4-hK4yz{鵿QǵFJSZi}NK4u&cNK4uef>_u*MFJkNoA+M^zoԩ4qTߨSiRiP+Mzoԩ4u&/7TB4>7T[iR+MFJS&mNoA+M]jK4yzw)$zOԩ4u.DJSZi.:JSRiV@|4>TNԥϟT}{鵾N$ġq8u'.NǩK8qNljKԥvԎNljKj t:NvB8eqq~[I?qR;N^JK8u.t:ԎSqǽѥvԎqR:NvD/Q:NvD8-hK8q7[ǩ/.t4ԡvNIw:N^JǩK8u'Q:NvDWt<\_ouo/Ye3{= qqBg8=A g8y3{A  qp3{= qps8=A g89{A g8y3{A= qi3{Z8Y= qiH{E g8k="qi腭 qiH{E g8="qiH{A,g8Y="qa3K{E, qiH"qqH{E gǟU]E,g8Y="qqH{E g8kYr~:4Y tG{E g8="qiH{Y="qi3{E,g 8Y="qq{i~3E,f78Y"oi~M[_="qi3{E,g8Y="qqH{E, qiH{A,g8="qi3{E,gkY="qpH{E,g8Y="qqH{E g8Y=Π/qiH{Y="qi3H{5,g8>7{E g8Y= qiH{A,g8="qi3H{5g8Y="qqH{E, qiH{E g}="qiH{A,g8Y="qi3{E,g8Y=Κ@yH{E,g8Y= qiH{E="qh3{E,g8Y="qiF{E$Th3{E,g8>{E g8kY=qiH{A,g8Ԏ{5=Κ6yH{A,g8Y="qi3{Eg8Y="qqH{E,g 8o g8Y= qiH{A,g89{E,g8Yt_'qq{5,g 8Y= qiH{E g8="qhH{A,g8="qa3{Eqis8Y= qiH{E g8="qcg8Y= qaF{Eg8Y= qiH{A,g8=qiBgM{?qrys;A8s;A8/tqrys;A8/s;A8/tqb9煖s;A8/tqr9煖s;A8qBK9 vcqE[Ď3 wA8q3Hg ;A8q b9g; vA8 bĎs; vA8qrĎ3 wA8q3g; -g; 7 wA8qr bĎs; vA8qrĎ3 wAv"A bĎs;Πh-g;A8q3g; vZ: vA8qrĎ3HwA8q3g;A8q b9g; vql3f7*wA8qĎ3g;A8q by bĎs; vA8qrĎ3 wA8q3g:18q b9g; vA8 bĎs; vA8qrĎ3煖3g;ΠFaĎs;ΠZ: vq bĎs; vA8 bĎ3 wA8qbs۟(w18 bĎs; vA8q^h8q b9g}s; vA8qr3 v18q3g;A8qa9g; vA8 bĎs; vA8q^f8qư3g; vq b9g ;Π.?NKĎ3 wAtA8 RÎ3HwA8qrĎ3g;A8qư㼐;Θ6-g;A8q3g; vqaĎs; vA8 bĎ3HwA7wq bĎs; vA8 bĎ3He3g; vq b9g:vA8Ǹ bĎs; vA8qrĎ3 wA8cq3g; vq R9g~g; -g; vq bĎs; vA8Ǹ b/~u8 bĎs; u18qqĎ3g;A8q3g; vqư bmg-g*18cp(Qy17coƨx3Ff1,7cnƨیQ9Ff5clƨ،A^s s՚15ǰՌQR3Fv14cTi(F3Ff 1 4cg QyǙ5h3kfƨ̬AY.Yf̚ߣ41J2kPd ȬA5f b1J1kPb ČQY f "55H0kP`(AY2De cX^ Wk^0pD5h.c\|15.k[(AmYزeR5-cYoC_~f *D1j,kX֠Q`Ys[!5+cW֠AZae dcXU ASY2FEe ʚ{5)kS֠QJY!e:d5(kQƨABY2Fe 5'cJ A)?f%&kMƨA4Yf䘿w`drԒ5%kJ(A)YP2Fd 2T5$cH Q Y>yd ő5h#kF֠QY.YdD5h"kDƨAYr sԐ5!k^뫣%d Bu5 d$5( k@ƨAX1Fc 5(c>֠{A>:jK<ƨxAX1Fc jĎ5h0uAXбc2T5c8 qAX1F}cyc č%hk6֠lQXYcD57%HcT4 hAX1F5c b1JkP2 dcŒc$5(k0ƨ_AXz1b Ś~>7 k- [QX>7lk,ƨX=X,AX{Zb Z5(k*֠SQX{XHqŒڰPA>yb ʼn5hk&֠LQX{X,Ub45HcT$ HAX{f1F)b J5c!֠BA b Ě!k֠>A|a 5w%k~C֠9Ara z1 k֠5QjX{iXаa2T5 k(1AaX{`f=q5H kP(,AWXUa45'!* k?ɜ0F5a b1J k~/ K(#AEX a5c A=Xx0` q8XsS7xx~o? j9Iq鴃xPZ~[>(~R B\: !.P!Щ #jHoAKB:)%ĥ &5'ԡ8tB\:E.5)ĥ҉ uUPB| q鄅ԲPi qąB N^(ԾP(L ߿/}k X}\+C]jfK y).4ԥu E&Du"EVDu:E^zx\:".T?Z'Vԥ֊\^uEjK:͢.5ZԥVD:ݢ.5\$zI.}֩-hKy?Z`ԥ&Du"F^ߨV:l͡7d~kNɨ)#/e䥯׹7\3RF]jH4 5j$5[ЮQ6ǣkNۨkK:yohQ8RGhQ9R;G^z)nuZG:y?Z'xĥS }$ߨS? oKu H&D: u.7ݥ:>Q'ԡ֐uH]jItDE:Q$SED0?Q'j/q$/='䑺>RHsHHcN%K$u$/%ԥThZI@ZR_wsI^z &ZL4hRZMcM 'q$sN;K'y?P'ԥԀՄ涿OQnE3(>鄔B-)78RZSRrJzx=`$i*uQ.8RV}I+VԕRW%$zoI,6RYR:Kz)-iM-u%/ԖܒR%ͥPK㷺8R%8R^RK^SK:%_SSakNIt[_b}ӫ)&}NK1u9&/=$tL]JCC?[#-$_f:8S^?:>h?_h>&.H^t2M:P餚VtjMjKXOkKM6y鹿N'ԥTġq8u'.NǩK8qNljKԥvԎNljKj t:NvB?vu_q=׎Sq[ǩK8u)'ԡvԎ('?..ԥvq $ʟ}^jIS߂vS'}}uqR;N^JK_ߘ8u'/ĥqǝqR;N]jIS'}}uԥv~}%vqqR;N]JC:.ԥvD:.hS'hS'h^?7NljK$z8u?u:N^z8u'/=GtԎSq=GtԎ?ZjI?ZԷ.hSq}o8ykqP;Nzo8u'/䥯:'>dlSm&ͯ8GtDu:N}OqR;N^zx^z8q8y>ZԡvtqR;N]jIqR;N]jK:'mNI?ZԷ'/=Gtt:N^z8q8u'=GtԎu:NvDu:N}8u'}N)Ԏ趿QԷ.ԥvFSq='t:ԎSqsNǩK8??Q~:N^zx^ڟq'tB8DSqR:Nz/T;N}X;Nz/8u.tԎSqMIqnK:P;N@SqR;N^zT;N:'y8u'/=tԎSqsqi:N}8u'8SvtqR;N]JCC_tDq:.ԥvqR;Nq:'P;N6߀qR;NtDm:vtߦqR;N]JCq:>.8Sqcqʴ$Zjǩvq $qR;N]jKujljCġqsˁqqt:N]jIt[_q}ӫ'}NǩK8u'/=tvԎt:N]JCC?[#$_q:S^?:h?_q>'.^t:N:tԎt:NjKXOǩkǩK8y鹿NԥtGk  qq3{A= qqs8= qg89{1g 8y3{A= qq3{Z8= q8=A g89{A qp3{A_ qq3{= qps8= qg89{A g8/qi3{= qqs8=Ag# = qqs8>i  qi3{A= qqs8= qg8cy!qi  qq3{=Π6-{=qqs8=A g89{A7qg8=A g8y3{A e= qq3{= qg8c=1 g8y3{A _e3{A= qp3{= qqs8=1 p3{Z8=A g89{A qq3_9{A  qi3澿N= qq3{= qg8=Ag8m3=Ώ-g;A8q by bĎ3 wA8qrĎ3g;A8cq3g:vq b9g; vA8 bĎ3 wA8qrĎ3Hg ; -g:"uA8q,On,BY3g:"uE8q,RY3g:"uA8q,RĎHg: vE8qaYH wE8"uA8q bY)RY3g:΢Jg;"uE8qQY3g:"uA8n厳Hg;"uE8q,RYs;"uE8q,RY3g:"uE8q,RĎHg:"uA8q bYHg: vE8q RYHg;"uE8qrYHg;"uE8(gE67RĎHg:"uA8qaYHg: vE8q bYHg;"uE8q,RYs;"uE8qQY3gh,RĎHg:"uA8q bYHg: vE8q㬹O;uA8q bYHg:A8q,RĎHg: vE8q bYFg:uE8g:"uA8qQĎHg:"uA8q bYHg:18q֨ bYHg: vE8qQYU bYHg;΢qrY3g:uE8cq,RĎHg:"uA8q֨Ď涿M8q,RY3g:"uE8qQY3g:"uA8q,BÎhƎ3g:"uE8q,RĎHg:"tcq,RY3g:"uA8q֨,BÎHg: vE8q bYHg;"t58q,RYHg;"uE8cqgq䎳Hg: vE8q PYg ;"uEXq,RY3g:uE8cq,RY3g:"uA8q,RFg: -gMߗr8qr9 wqr9 wZ:A8qr9 wr9 wZ:A8BK9 wZ:A8BK9 wq^h8BK9 vcqE[Ď3 wA8q3Hg ;A8q b9g; vA8 bĎs; vA8qrĎ3 wA8q3g; -g; 7 wA8qr bĎs;Π;wf~a7Ďs; vA8 RÎ3 wA8qrt b9g; vq bĎBKĎ3g;A8q3g; vq b9g; vA8 bĎs; vA8qrĎ3g;A8cq3g; vZ: vA8 bĎ3 wA,b9H"4g; vq R9g; vA8 bĎ3 wA8qrĎ3g;A8qq bĎs;vA8  b9g; vA8 bĎs; vA8qrĎ3 v1rÎs; vA8 bĎ3煖3g; vq b9g; vA8 RÎs;vA8qrĎ3 wA8qvq bĎs; vA8 bĎ3He3Hg ;A8q b9g; vqư "qrĎ3 wAtA8 RÎ3HwA8qrĎ3g;A8qư㼐;Θ6-g;A8q3g; vqaĎs; vA8 bĎ3HwA7wq bĎs; vA8 bĎ3He3g; vq b9g:vA8Ǹ bĎs; vA8qrĎ3 wA8c?^qrĎ3g;A8q3h?Î3煖3g;A8q b9g; ucq ?Ǻtq b9g:vA8Ǹ bĎ3 wA8qrĎ3g;A8cq3覎F:? Kqt:N\:.ԥv_q uԎNljKj t:NvB8q[ЎNǩC8qtB8q8u'NǩK8qtt:N]j)Ԏw:N\:.ԥvt:N\:P;Nq J)ӎK:NW׎SqR:N^JǩK8u)'ԡvԎ>I ?..ԥvq $ʟ}q $JǩoA;N^J)Ԏ达Q:N}8u'/8utt:NtqR:N]jǩK8q $!oԷS߂vԎ/8qhS$8y?Zԥt<qR;N]jIqR;N^z8q}8q}8yzstt:NhSqR;N^z8u'/=GtԎSq=GtԎ?ZjI?ZԷ.FSq}o8ykqP;Nzo8u'/䥯:'>tSqR;NtD_u:N:8u&/=~Qo/~dqqqP;NjK:.ԥvD:.ԥvqGtD_u:N} qsNljKhSSqsNǩK8y?ZjI?ZގSq$z8nu:N} qR;N]jKֻK8u'c}NǩC8u'/='tԎz^u:N|':'}N)ԎS_x;N^zO8u.BԇBSqR;N^JǩK8u'՜Svq $8u.@ġqP;N@SqcNǩK8u'/='mݎSgq}8q oKq:.ԥt<8=g{NItqR;N]jKq:.$\q㤹o8 8.$JIߦq oKm:.ԥt<qqR;N^z8u'/=ǩL;N[;NvoKq:P;Nq:.ԥvt_v8t:N:'/=8>.:趾N$Z_W;N:SqR;N^z8q8u'/=t?^^F[IN䥯u:.~,Ku:'~汿N}:N\:'/tDu:'/}8u'/=t:ԎϱS׎SqsNǩK8y辿N8eq)ַ豿N7.:S׎t:N]JǩC8y蹾N:/}8]Rq^cc9Sc,Cc93cypNp^ c89c4yono^ӛc9FÛCynn^ƛc89c8ymme9Scyml_lhc3Fckh^s 5c0m1֌Ѳfe1YjhT3Fc8E jf4c11Ҍєf4pH3F;1ьhhC3Ff4c|gh<3Fۙc8V3c9oJg4hf63p23F1ýeh-3Fcc-ePfm}<1ɌFf&2p!3F1njC\h2F1ZÁ[hr -c4nmM[e-ckyZh2F1ڴI-Zhr ,c>gk1-MYh2FCccXe6,c4a>C~e+h2هە! Whr g+cZmV^Ɠ1Z`e*p2Fk1íMUh2FCcnکLeV*h2D1BTh2FcNqʘ MS2e)cKY1\(e6)p2F1E0a c A bxB b?1D1)b[A>7A#? X$1I b8Qb f%)La4q ƉA9O (PD1b#A)S bxT bV1 ׊A+qb1bA7FA-rp1bAn/^|1b 0a bĊq3vA d bĖ11ㅖ19c{AX41i b8Qc f51l zl b8mcƃ3Q̯%p b8ȉc FA9s bqK Al;r1ㅖ1c 6=ưz b8ch-cAn?~ b8c @ b r3 vA !o[Ɛ\C1 b9Ad &Al"/DA"E02edAn#G b9>2Hd AL$cH1 b%9șd; \J1 R+Xrk A%Lr1d2 GA&MNa:9d ֓A' b@Ăr6Ad]+A(Q12c21 הA)cS)2IeA*XU1 bW9aer[sߦ b^9}e X bdr3 u1 -XZrj2 זA-[)2hr VA.]rx2 A/X_)_1 bs FA09 R3H%Al1cr3=fA.2d(3HUf vf b6s ֙A3Ǹ ϰ by bJs3 vA 5XjrV3HךA5\l1 b9ffA68 bt3 ǛA7orĀ3gAl8cq3覎|$ԎNljKԥvԎK:NvܷSq8qtB8N)ԎSP;N| q8u'.S'>ġq8u'.NǩK8qNljKԥvԎNljKj t:NvB?vu_q=׎Sq[ǩK8u)'ԡvԎ('?..ԥvq $ʟ}^PjIS߂vS'}}uqR;N^JK_ߘ8u'/ĥqǝqR;N]jIS'}}u-xhίjة8ݽ䥯:>'/Gtu:N]jǩK8u:N]jK:P;N:P;N:'/~GtԥvtߨqR;N:'/}oT;NjC:.tQǝqR;N]jIߨq $ߨq[ЎSqkNǩkK:5oԛ"4?Zَ?ZԥvԎ^u:NhkNǩoA;N^z8qtqqP;Nz8u'/GtB8>Gto_u:NhS'mNǩoA;N]jǩK8yzw)$zo8u.DSq.:SqH|8>tNԥϟe}{鵾N$r1cA@2 d# VA b9%deB029d{A"XD1 bBK*2YdA#XF162qd 摃G)a!9d ɠB- gA$Jr)T2Hd cA%K b09d 6M b6nep2Hd An'O b>9d Pư u(9 bGĐrKʠqZZ Ɣ\S)aOr &Al*9 bUĬ2] A*+cVʘ6-ueA+X2e# VYahrS A- bn2HA77] ]rx2 A/X_)| b3 7A0Xar3!fJ1N1b139f{ \d1 b9QffA29 b43m ǙA3gqaDF3f+A4i1 b9ȩf[ Śc\k1 ?Ǻ\l1 b9ffA68 bt3 ǛA7orĀ3gAl8cq3袎ωl w/tqr9uqr9 - wqqr9 w/s;A8_h8Ďs;Z:A8|s;A8_h8s;Z:A8|s;18 bĎs; vA7q;A8qư3g; vq bĎs; vA8 bĎ3 wA8qrĎ3g:18q| b?3g;A8x[Ǚ_Ŏs; vA8qrĎ3 wA8cq3g;A8.tA8 bĎs; vA8qq bĎs; vA8Ǹ bĎ3 wA8qrĎ3?ZK9g; vq bĎs; vA8qbÎ3 wA8q| bĎs; vA8qrĎ3 wA8q3g:18q b9g; vAZ do*vq bĎs; vA8_h8q b9g ; vq}q3g; vq b9g; vA8 bĎs;Θfa9g; vq bĎ󅖎3g; vq b9g; vA8 RÎs;vAZ:A8q3g:vq bĎs; vA8 bĎ3>PK3 wA8q3g;A8cq}vq b9g8-g;A8qư R9g; vq bĎs; u18_ge3 wA8qrĎ3g;A8qư b9g; vq bs;Π;A8q b9g; vq be3g; vq b9g:vA8Ǹ bĎs; vA8qrĎ3 wA8cq3g; vq R9g~gs3g;A8q b9g; ucq ?Ǻtq b9g:vA8Ǹ bĎ3 wA8qrĎ3g;A8cq3肎߳ b9g; vA8_h8q b9g; vq bĎs;vA8 b3 wA8qrĎ3g;A8q b9g; vq RÎ󅖎Hg: vE8q bYFg;"uE8q,RYHg;"uE8q,RY3g:"uA8q,BÎHg:A8qϿE8q,RĎ ?uU8q,RY-wE8q,BYHg;"uE8q]Gg: vE8q,RYH wE8q bYg ;"uE8q,RY3g:"uE8q,RĎHg:"uA8q,RFg: vE8q䎳Hg: vE8q bYHg;"uE8q,RY3g:"uE8q,RY(wE,Rl*uE8q,RYs;"uE8qQY3gh,RĎHg:"uA8q bYHg: vE8q㬹o;uA8q bYHg:A8q,RĎHg: vE8q bYFg:uE8q,RY3g:"t58q,RY3g:"uA8q,z;"t58q,RY3g:"uA8kq} uA8q bY?N8q,BYg ;"uE8q,RY3g:uq\g: vE8q,&wE8qQY3g:"uA8q,BÎhƎ3g:"uE8q,RĎHg:"tcq,RY3g:"uA8q֨,BÎHg: vE8q bYHg;"t58q,RYHg;"uE8cqgq䎳Hg: vE8q bYg ;"uEXq,RY3g:,BÎHg:"uA8q bYHg: u58qq]q+~vߗ zstt:N]jǩK8?_q q?:N]jljKĥq :P;NvB8-hljCԡvt:Nvv:ԎNljKԥvt:N\:.jlj;'.SqR;N\:'.S'8q i;|GI?qR;N^JK8u.t:ԎSqǥԥvԎqR:Nk:Nٗ(P;NttB8ގSqR:N^SqP;N^JljK$Jlj;'/ԥvԎ(P;NWp]: vE8q,'wE8qQY3g:"uA8q,RĎg:A8k.䎳Hg;"uE8q,RY3g:uE8q,RĎHg:"t18o8q,RY3g:"uA8.(eq㎳Hg:"uA8q bYFg:vE8q,RYHg;"uE8qQY3g:"uE8q,BÎh?H wE8q,RYHg;"uE8cq,?3g:"uA8q֨,qH;(鸳Hqg"ŝA;w) bYHqg ĝڵgjZjϢj??ջ՞\{R{r9ȵ מV{r9ȵ מ/Ԟ\{rBK9ȵ מ\{k1=|sk1=_h=sЅ מ\{R{r9ȵ מ/Ԟ\{rBK9ȵ ֞c\{A[3 מA=X{3Hg kA=X{ b9ȵgk ֞A= bsk ֞A=X{r3 מA=X{3gkZj ֞ASrkA=X{3zW{W b9ȵgk ֞A= bsk ՞1=X{r3 מAZj ֞\{ b9ȵgk ֞A=_h=X{ b9ȵgk ՞c\{ bsk ֞A= b3 מA=X{rtߨ b9ȵgk ֞A=ask ֞A=X{R{ b9ȵgk ֞A= bsk ֞A=X{r3HמA=X{3gk ֞\{ b9ȵgk ֞A= bAK_W b9g k ֞\{}R{3gk ֞\{ b9ȵgkϠh- מA=X{bs,מ1= bskϠf-gkZj ֞A=X{r3 מA=X{3Hg kA=cX{ b9ȵgk ֞\{ Rsk ֞A=X{r3 מA=X{| Rsk ֞A=X{r3 ֞1=>p]kA=X{3k3 מA=cX{3gkA=X{ b9ȵgj֞/3沿MKsk ֞A= b3 מA=cX{3gkA=X{ R9Ƶg͵ מA=X{3gkA=X{ R2K3gkA=X{3Hg k ՞c\{ b9ȵgk ֞A= bsk ՞1=X{r3gkA=X{3h?3 -gk ֞\{ bsk ֞A=Ǹ b/~u= \{~&+r4 hsNi ;au~f8Ӫu~sNi):?9A'iNΉ9q-'4|甜gs2NV08Ap~Gp~zY7qԝěvwnLMi;6emRmNMi;I6u'&LMW&&LkMĚgԝ0-5e۫LwZiN"MݙFghL MI3eg~SgNLi;M3eRf4̔e]9=C?L|3eNLI;:A&>=C'ĝvRw3tKis;:%4ĝ2:%4I-aZZ|,wZYu}uNc;M,eW\_8ӺRgsJiZ;)+u繾:Y'ԝTӨwTW0 *eWgoM;)uyw籾:g5ԝ꜌gZQu}uNC;M(qm}u9$ԝvR沾:y&lRwswN3;9Q'gh.;%q\g褒0-%egtIN+I Fe}N <wZG3NHi)s^FLHi;:Q$zޙ |zHݹzyЉ!e+tRHBm}N; q'?4'ԙw?NGI;mq̔"9#fs_=´yO)q#wԝv|ĎϴuO)q'dw9}}r8\gG|qyܜm#榍s]6NFI֨3_ͻ3Ͽ429E#4hĝs[S3NcF9)gӒQ䲾6cO~2Fi(Q澾6'a܂QwksEi;u>7]G5]ĝX-NEݹME62o0 ^QwnssjEƊ2ssREi; u纾7?93'Rԝ(Z(NEye.{sD<&\愉.w%m}oNj;Mu羾7'Hĝ:s޼;ky1ޜQw{sBDyww{s*Dm}oN=;'@ԝޜP沾7'>ԝޜwZ}{oNw3ug~>G脈!}}Np; u>B A w>B4?yCCig;:!>G$g}{~ ߿ԽeK2[%- nIqK- nIqK2[%- nId$nڒ nIpK2[%- mIpKr$%-Aޒ d$%9[Aܒ d$yK2[Aܒ- nIiK2[/lIiKH[Aܒ,Җd$%-"lIhK2[Eڒ,Җd$%Y-"mI=1-"mIiK2[Eڒ,Җd$%Y-"mIqKH[Eڒ,–d $%Y-Aޒ,Җd;x%-"mIiK2[E_-*mIiK2[Eڒ,Җd$%Y-"mIqK[5d$%Y- nI]G[Eڒ d$%-"mIiKH[%Y-"mIiK2[Eڒ,–d $%Y-"mIqKH[Eڒ d$%Y- nIiKH[Aܒ,Җd$%-"mIiKH[Aڒіd$%Y-"mIiKr$%Y- nIiKH[Eڒ d$%-"mIiKH[Aܒ,Җd$c%Y-"mIiK2[Eڒ,Җd$%Y-"mIqKH[Eڒ,Җd$%Y-Aޒ,z^td#4YOlIqKk%Y- nIiKH[Eڒ d$%-"mIG[Aܒ,Җd$%Ys,nIhK2[Eڒ,Җd$%Y-"mId$%Y- nIiKH[Aܒ,Җd$%-"lIhK2H[5ڒ,Җd$%Y-"mIqKH[Eؒіd$%Y-ɢ@yKH[Eڒ d$%Y-1ޒ,–d$%Y-"mIiK2[Eڒ,Җd$k.- mIqKH[Eڒ d8yKH[Aܒ,–d$%-"mIiK2[Eڒ,Җd$%Y-mIde%Y- nIiKH[Aܒ,Җd$%-"lIhKH[Aܒ,Җd$%Y-"mIaK2[E7nIqKH[Eڒ,Җd$%Y- nIiKH[Eؒ-"mIiKH[Aܒ,Җd$%Y-mIaK2[Eڒ,Җd$%Y-"mIqKH[Eڒ de}%Y- nIiKH[Eud$%-ɢ$%9[Eڒ,Җd$%Y-"mIqKH[Eؒ?Y,d&>L@ڒ d$k%Y-nIiKH[Eڒ d$%-"mIiKH[Aڒіd$_hْ,-?l מ/Ԟ\{r9ȵ՞\{r9ȵ - מ\{R{r9ȵ מ/skA=_h=skZjA=|skA=_h=skZjA=|sk1= bsk ֞A=X{r3 מA=X{3gk ֞\{ b9ȵgk ֞A= bsk ֞A=T{q3 -gEg@sk ֞A=|rW}  b9ȵgk ֞A= bsk ՞1=X{r3 מAZj ֞\{ b9ȵgk ֞A=_h=X{ b9ȵgk ՞c\{ bsk ֞A= b3 מA=X{r3gkA=X{ b9g k ֞\{ b3gkA=X{ b9ȵgk ֞\{ bsk ֞A=Ǹ b3 מA=X{3gkA=X{ b9ȵgk ֞/ԞA {k ֞X{Ơ'hS$=u'uN)ړ?ZԷ.ԥ֞thSZ{7Ԟ:SZ{}NK=ެ豿Y~jO^z^zo֩=ujO֞[{mNK=u)''>''ԞSZ{RjO]jK=yԩ=u@S'uNK=u'/'Z{ԞړnujO]jK=y?P=i.4֞:ړ{N)S_xkO^ө=u.ۯ_vjO8SgNKq:.$^S{oө= 8.$JItߦS{ oKm:.ԥԞ'$B[{}}NC=y_p=q=u'/'ԞړS'd}nujO}Z{RkO^zO֩=q=y?YԥԞ:ړ|Gқm n{g=mZ=m n{g=9۞A g=q3۞Am n{i3۞m n{g=mA g=9۞A o{q36n{вYm"m{q۳H۞E,Ҷg=Ym n{i۳H۞E g=Ym n{i۳H۞A,Ҷg=m"m{i3m"m{i۳۞1,Ҷg=y۳H۞E?*Ҷg=YmϠ_"m{i3۞E,Ҷg=Ym"m{q۳۞5,Ҷg=Ym n{]G۞E g=m"m{i۳H۞Ym"m{i3۞E,¶g =Yt-o{q۳H۞E g=Ym n{i۳H۞A,Ҷg=m"m{i۳H۞AѶg=Ym"m{is=Ym n{i۳H۞E g=m"m{i۳H۞A,Ҷg=cYm"m{i3۞E,Ҷg=Ym"m{=Ym"m{i3۞E,Ҷ o{i۳H۞E Ҷg=mσ7SE Ҕ秿k\=Ym n{i۳H۞A,Ҷg=m"m{i3H۞5g=Ym"m{q۳H۞E,Ҷ o{i۳H۞E g=m"m{7۞A,¶g=Ym"m{i3۞E,Ҷg=Ymm{q۳H۞E,Ҷg=Ym n{i۳H۞Em"l{h3۞E,Ҷg=Ym"m{i۳F۞E*m"m{i3۞E_m"m{q۳۞5,¶g =YmϠ=Ym"m{q۳۞5mϚ6y۳H۞A,Ҷg=Ym"m{i3۞EѶg=Ym"m{q۳H۞E,¶g =o g=Ym n{i۳H۞A,Ҷg=9۞E,Ҷg=Ym"m{q۳۞5,¶g =Ym n{i۳H۞E g=m"l{h۳H۞A,Ҷg=m"m{a3۞Em{is=Ym l{~j4+5Y" ~aҶg=cYmϢí g=m"l{h۳۞1,Ҷg=m"m{i3m"m{i۳H۞AѶg=_h,/ؿZ{rBK9ȵ מ\{A[9ȵ מ\{R{r9ȵ - מ\{rB=ǸskA=Ǹ|skZjA=skA=|skZjA=j ֞A= b3 מA=cX{r3gkA=X{ b9ȵgk ֞\{ bsk ֞A= b3HמA=X{R{ X{r3X{W}  b9ȵgk ֞A= bsk ՞1=X{r3 מAZj ֞\{ b9ȵgk ֞A=_h=X{ b9ȵgk ՞c\{ bsk ֞A= b3 מA=X{r3gkA=X{ b9g k ֞\{ b3gkA=X{ b9ȵgk ֞\{ bsk ֞A=Ǹ b3 מA=nԞ\{ b9ȵgk ֞A= b3gk ֞X{ư b9ȵgF-gkA=bZn מA=X{r3gkA=X{3沿Y=cX{r3 מA=X{| b3 מA=X{r3gkA=T{ư3gk ֞\{ b9ȵgk ՞1= b3 מA=X{r3gjϗYj ՞1= b3 מA=X{b3OE3gkA=i=X{r3NR9Ƶgk ֞\{ bsk ՞1=_ȵge3 מA=X{r3gkA=T{ư b9ȵgk ֞\{ bskϠkA=X{ b9ȵgk ֞\{ be3gk ֞\{ b9ȵgj֞A=Ǹ bsk ֞A=X{r3 מA=cX{3gk ֞\{ R9Ƶg~涿NKBKhW2b3 מA=T{q3_pR{r3 מA=cX{3gk ֞\{ b9ȵgk ֞A=ajϠ=V{3gk ֞/ԞA=X{3gkA=X{ b9g k ֞\{ Rsk ֞A= b3 מA=X{3gkA=X{aBKYڳHgk"՞E=T{,BY3gj"՞E=X{,RY3gj"՞A=T{,RڳHgj ֞E=T{aYڳH מE="՞A=T{ ogPj"՞A=T{/T{,RY3gj՞E=X{,Rڳ?Z=T{,RY3gj"՞E=,RYڳHgk"՞E=cX{,RY3gj"՞A=T{,RڳHgj ֞E=T{ bYڳHgj ՞5=T{,RYڳH מE=T{,RYڳHgk"՞E=X{,RY3gj"Ԟ1=T{,RڳHgm\{,RY3gj"՞E=X{,R9ȵgj"՞E=T{֨,Rڳk\{ bYڳHSE;w~ϥ,RڳHgj"՞A=T{ RYs,֞5=X{,RTYڳHgjA=T{,RڳHgj ֞E=T{ bYڳFgj՞E=T{,RY3gj"Ԟ5=X{,RY3gj"՞A=T{,B9Ƶgj՞A=T{,RڳHgj ՞5=>]j ֞E=T{,'מE=X{QY3gj"՞A=T{,RڳgjA=k.ڳHgk"՞E=X{,RY3gj՞E=X{,RڳHgj"Ԟ1=o=X{,RY3gj"՞AO՞E=T{ڳHgj"՞A=T{ bYڳFgj֞E=T{,RYڳHgk"՞E=X{QY3gj"՞E=X{,Bڳh?ڳsќ_HE=X{,RY3gj"Ԟ1=T{nuڳHgj ֞E=kT{aYڳHgj ֞E=T{,RYڳHgj՞E=_h=.=oOj}/ϗz\:.ԥ֞/=Z{~.ĥS{ҩ=Z{SPkO֞ġS{PkO\:PkO|\kOjCĥS{RkO\:'.SZ{ ǝNK=u'.N)ԞB=R{ʴQ{~$ʟq=u'/ԞSR{PjOjK=R{R{RkO]jK=y)PkO (PkOԞԞB=SZ{RjO^SZ{PkO^JK$J퉏;'/ԥ֞ړ(PkEj7C<}]'=u'/hSړujO]JC:.ԥ֞D:.hS'hS?S߂֞htjO\:'}NK=u'/=GԞ:ړnujO]jK=ujO]jItS{ $ߨS{[SZ{uNK=7Ԟߨ֞:ړujO]zԞߨS{NK=u.$oԩ=Z{}oԩ=-hK=yz{鱿QǵFSZ{uNK=u'mNK=u'/=7ԞD:'sNoAkO^oԩ=qԞtߨS{R{PkOoԩ=u'/]7ԞB=7Ԟ[{RkOF 7?jOnItS{RkO]jK_ֻK=u'm}NC=u'/7Ԟo֩=ujO|7fړ躿Yj/'/7ԞSR{}Z{Z{mNK=u'/ԥ֞ړhjObS_wkO^:PkO@SZ{?P@Z{ԞړnujO]jK=y?P=i.4֞:ړ{N)S_xkO^ө=u.ۯ_vjO8SZ{RkO^ө=u'8'eNo=u'QjO6S_xkO^oө=u.8SSZ{cNK=y?N=eZ{Z{ ?~kO^ө=Z{}ө=u.=S{uZ{Щ=qԞt=q=u'/=ԞDu:'s}=tjO]jK=y鶿Nǵԥ֞t_S{RjOzz5?jOu:'/=Ԟo/=ԞDSș_ܟS{k8'/='ԞD:'/='ԞړujOjK[OkK=y?YԥԞ%(7cn֠۬AYj3Ff $5(6cl֠׬AZf Z1*5kj֠ӌQYJfF3Df cg Ϭ`kgƨͬAY23?E_uM T12kd ɬA =f r՘5c5H1cTb ĬA >C0k`(AY3Fe ԗ5/ǰAzYed5E5h.k\֠QpY޲ejĖ5h-kZƨAhY2Fe *D5h,cX֠A`Y2ye ĕ1j+kV֠AX9]e T1*kT AQ=e rՔ5)kR QIYsGe "41J(kPP A?|d 5H'kPN Q7YlIנA2Yb2d z1%kWd R5%knL2Fd "41J$kPH֠ACG֠A6䲾B*#KFƨAY*2FQd $5("0AY5db5H!cTB AY 2Fd d 5 k?(AX1Fc ǚc u5kP= zQXc5k>׎C;|nK:ƨtAXαc*D5hc8pfc7֠nAk}nX6 lQX9k,AX9j QXEc5kP3(f2 e䲾6k1ƨbAX1F c 5c/|K/֠]QXrbd5k>G!jk^*c,֠WAXZ1Fb Z1*k*֠S)aXHb 5k'(O\' N&(MAX01F]b T5c$ IA sX5bb5HkP"(D! ?!HYAA8b 1kP >A{a0Da Ú6ƨ9ArX0Faްa0Da Z5( c֠3Afʰa $1( K֠/|5T?73E TNaKM uK?"CV?GfK q鄆tJC@5jl(P! q:Nr(PZqtNyK'=ԥBq>ĥRC]jK@ĥ A:P+D_v?Bϗ~DkKyGKu)A"Hԡ&&(Q"?.U.5Kԥv0R& 5M$ʟ{ًZ'%OԷ}"/%PjHt]ߨFJ)7fCEjKIq鴊DqV䊺^Q,Xj]_5zZ٢.[䥄..cNKy?Z'`ԥԄ?Z'bԥVt1 5d$2 e$S3ףqD:I.iԥFX5PF^)ui.m$֩uy#mN(‘{NoA#G]jK:.5t$ߨ:s;PkGzou#/xFwG^JKu#mN({NoAG]jK_oK:> $/7D: u:H]jK-!nuZH]j K!y鱿Q$o)"uH} E}˭[ϯ8a$cFPHoԩ#uy$/]7B-$74IR+IFNR$eN*oA[I]jK#\?rIN/$m}N2Cm&u$/7dnzuI|᧝7f|躿Y'jA/ %/7DԊRQ}RZRmNKK)u5%/%ԥԠhJbR_wJ^/*U]딕ԴRVmZW+q}%}NaKM,y?P'ԥV̒В沿OZnk3-B-78R\RKzz=`$)/u.8R_} 0Z`\4SZa%$o 16ScRjL1i 2uE&/=4(n,S]&ePL8:Sy&8@SZhRM^S#M:&L8>.5:X貾N'$zӣ&uNKm6u&/dvptM]JC_CFGIN':/}3+:'~?Y'}JN\:)'/='ĜD:9'/='ԢuNjK[O֩kשK ;y?Y'ԥמJ&@=T{qa3gkA=X{ b9ȵgk ՞c\{ ?ܺԞ\{ b9ȵgj֞A=Ǹ b3 מA=X{r3gkA=cX{3_jϿn54AĥS{RkO]jҏSQ{RkO\:'.S'Щ=Z{ joAkO:ĥS{ ǵԡ֞8tjO\:.ĥS{ҩ=uPkO|ܩ=qԞSZ{ҩ=qԞB=N)S(Lk߁K?jO_ǵԥ֞ړR{RkO]JC=u.$JɏKK=u'/_RjO֞D0QjO֞D=-hK=Z{]7G/.Ԟ4ԡ֞NIwjO^JK=u'QjEoj֞:ړ>Z?jO}OZ{RkO^JK:>'/=GԞړnujO]jK=ujO]jK:PkO:PkO:'/=~=Zo.NItS{RkO]jK:hSZ{RkOhSZ{>>Z?sNIQԷ.FSZ{}oԩ=y鹿Q=u'=7ԞړR{sN퉏;'/ԥ7ԞD:PkO:=u'/~Qo/=7Ԟ֞t_ߨS{PkO^oԩ=u.$oԩ=u.Fړ貿Q$zoԩ=-hK:'.ړnujO}\jOjC:.FS'FS_xkO]jItߨS{ $oԩ=-hK=u'/Q.ԡƝDOԧQ{rkOsfSZ{]YocN/Ԟtf߬S{]7ԞB=fSZ{RjOOVkO}XkOO֩=u.ԞSZ{MI_S{nK:PkObSZ{RkO^/VkO:'ԩ=u'/ԞSZ{}Z{\ijO}ѭ=u'8S֞tS{RkO]JC_CϿԞDq:.ԥ֞tS{RkOq:'PkO6߀S{RkOԞDm:֞tߦS{RkO]JCq:>.8SZ{mZ{ʴ$Zj֞tS{ $S{RkO]jKujCġS{}ǵԥ֞_S{]ԞDuz$ө=u.:SSZ{}NK=yuz{H=}h4+'$ujO]z׷ujOmN/ԞtjO^zO֩=.ujO^zO֩=u'/'Ԟ:ړSSZ{}NK=y?Y=eZ{Iַ?Y7.dSړnujO]JC=y>Y?jϗ~Ԟo.;<֞\{R{r9ȵ מV{r9ȵ מ/Ԟ\{rBK9ȵ מ\{k1=|sk1=_h=skA=|skA=_h=skA=Ǹ3gkAgk ֞A= Rsk ֞A=X{r3gkA=X{3gk ֞\{ b9ȵgk ֞A=Ǹ b3g@sk ֞A_3K(gkA=X{ b9ȵgk ֞\{ask ֞A= R{3gkA=X{ bBK3gkA=X{3gk ֞\{ b9ȵgk ֞A= bsk ֞A=X{r3gkA=cX{3袿b3gkAgk ֞A= bsk ֞A=X{r3HמA=X{3gk ֞\{ b9ȵgk ֞A= b3gk ֞X{ư b9ȵgF-gkA=X{ b9ȵgk ֞\{ bsk ֞A=OjcwR3 מA=X{| b3 מA=X{rt߬ b9ȵgj֞X{ư bsk ֞A= b3 מA=X{3gkA=X{ R2K3ޒ㼖%vyA;vDAS DbX67%|Ac3gkA=X{3g߶`9ȵgk ֞\{ b9ȵgj֞A=Ǹ bsk ֞A=X{r3\{i=X{r3 מA=X{3Hg k ֞\{ b9ȵgm3HמA7מ\{ bsk ֞A= b3He3gk ֞\{ b9ȵgj֞A=Ǹ bsk ֞A=X{r3 מA=cX{=߅H@ ֞A=X{r3HמA֞A=/ԞA=X{r3gkA=X{3g֥3gkA=T{ư R9Ƶgk ֞A= bsk ֞A=X{b3՞A=ԞSZ{RkOԞF?՞U=u'}}Ԟԥ֞ړ>GԞ֞S{RjOz֩=u.$z֩=u'/=GԞB=>GԞB=~֩=yҩ=qԞD:.ԥ֞ZS{PkO^z֩=u.$z֩=u'}oԩ=>7Ԟԥ֞tߨS{RkO:'/}oTkOjC:.ԞQǝړR{RkO]mNIQ$ߨS{GSZ{FSړujOjK:.ԥ֞D:.ԥ֞ߨS{7ԞDujOZ{sNKFSSZ{sNK=y龿QjIQ7SZ{7ԞB=nujOZ{RkO]jKooOR{PkODSZ{R._jOno'ۛ#zo֩=ړެ/}o֩=ujO֞[{cNK=u)'='>'='ԞSZ{RjO]jK=y/֩=}bS'}NK=u'/='Z{<ԞS{RjO]jK=y?P=in4֞:ړcN)SxkO^ө=u.ǷCԞDq:.ԥ֞S{RkOq:'PkO6?S{RkOԞDm:֞tߦS{RkO]JCq:>.ԞSZ{cZ{ʴ$Zj=y?NjI?Nԥ֞ړNCNkK=y鵿N$ө=>ړ辿Nԥ֞ړtjO}\kO]jKu:.wfN|=>'Ԟ?Yԥ_pk}NIyO֩=MNK:'mNKujO]jK:˭ǵԥ֞ܟS{RjOOVkO֞DG؟S{SZ{kNkK:.ԡ֞<\_/K_j._b۶=m n{q3۞Z=m n{g=9۞A g=q3۞Am n{i3۞m n{g=mA g=9۞A o{Ҷg =/l{i۳H۞A,Ҷg=m"l{h3۞E,Ҷg=Ym"m{i3۞E,Ҷg=Ym"m{q۳H۞E g=Ymn{i۳H۞Ym"珊m"m{=f3_mϢ߿'Ym n{i۳H۞E g=m"l{h۳H۞A,Ҷg=Yt-o{i3۞E,Ҷg=Ym"m{g=Ym n{i۳۞1,Ҷg=m"m{i3۞E,Ҷg=Ym"m{q۳H۞E,Ҷg=Ym"m{i۳F۞E g Y"m{is=Ym n{i۳H۞E g=m"m{i۳H۞A,Ҷgs}Ym"m{i3۞E,Ҷg=Ym"m{q۳H۞E,Ҷg=YmA,Ҷg=mm{=7w}Ym"m{q۳H۞E,Ҷg=Ym n{i۳H۞E g=mϚDq۳F۞AġS{ҩ=u'.NK=Z{NKԥ֞NKj tjO֞B=eZ{ |=_R{o֞ړR{RjO]jK=y(R{RkOԞԞSZ{RjO^J)ړ(&J)ړ(~=y)PkOF}=ԥ֞ړԡ֞:ړR{ҩ=R{NK=u.$JoS9_S[{GKIkO]jK=ysNkK:.hSZ{RkOhSZ{cN)ړcN)ړhړ^.NIS{RkO]jK:hSZ{RkOhSZ{=>Z_FړcNAkO]jK:.$ߨS{Fԡ֞<ߨS{RkO^JKujO|ܩ=y).ԥ֞D:PkO:~oNKooԏ^ujO}\kO^zoԩ=u'/7ԞSZ{=7ԞSZ{kNItߨS{}oԩ=#hK:'.ړujO}\jOjC:.FS'FSxkO]jItߨS{ $oԩ=#hK=u'/=Q?]JC=ujOjK=y?Qԥ֞DoOԏ?Q7~jO^z~{~?Q'Մ/'O7Ԟ_ړujO]jK=y?Y=a=y?Yԥ֞ړR{RkO]jI4'kNﻵ'/=ԞB=ujO]jK=y鱿X=qԞ8ړ湿Xԥ֞_S{RkO]jKjIs=Mԙ֞DtjO֞[{}NK=u)'==N?=`$ө=u.8SZ{}ө=Z{ԞSZ{$zoө=6SZ{hI?Nԥ֞S{RkO^zSkO֞D럷֞B=?'/=ԞB=>ԞSZ{}Z{Щ=qԞi=q=u'/ԞDu:':Z{ԞSZ{һF3_؟{hK=y?YԥԞY$<'ԞOKdړ?Y:.dSZ{S{Z{RkO^zO֩=u)''LkO#zO֩=hK=y鵿Nǵ:SR{PkOzӗ/~W*PӞ {^ƻeF=/Mx2^cAx2c5x2򼌧</y^Cx^+E,e<,|eyw1vee<9c8yos4.s0e9cyr&Nr"E<9{c8,kc891⼌8psp^_1?5#cyOppe<9c8yoo.oe9cyn29me9cc9S̲9c}1ټW6pds66/1\Á1׼5p]s 5/m1e1ּw5pVs W5/Q1I1\Լ5pOs 4pM2-1Ҽ4pHs w4pFYV4pDs 74/ 1\1ϼ3p=ss}u11μw3p6sV3/11\̼3p/s 2p-2í1ʼ2p(s w2p&2^Ñ1c1\Á1Ǽ 1ps 1/m1WgYaxs,c8yob$.b^ƃc9scyaNa^KCn!W0ps 70/ 1\1ܿc1\N]^Kc0to×^^^ƛc4y9]]^ccu9S]\^+c8r9c8qy/\[^cn9cm,Ӗcl9ÖZZ^ƛc8i9ir,Ǽ5xr ,p2^{}n1W,|lͲa9FX~e<_9c8^9ەt-Wp!YV+p2ެ1\+pr *p2!åxr w*p2^Ñ1ܨʋxr<S8nS^ӔcL9Ô.R*R!&NR"R^{c8G9kmQ-Q^CcC93 p˔c8L9.e(prs}1Z1ܞ'pyr 'pw217'ǬG89̲79sc6yMNMe<49;c43yL6xar &p_2u!mɋxZr %pXr w%/Y1\QxSr '%pQr %/=!56&97[~u r`0a -a+ fA 94 bip[ ƆA bo0 'Alư:0aA.= b|8a A @ bq# VAc!^h T")E bXH5br Ek &Ej%J bX.Hab Ej'N,RX>Hb "%Ej)R,RXN1bJ"*)V,_|+W,RXWbbo"EE-[,RXr1b"ŋA/֨_,RĂH c FErX1!cJ"Al3f,R8=c"EJ4)j,BìH]c"AL6)n PXH}c EJ81r,RX̱HcC"EJ:)vQX1c"EJy,RX1c"E*>},zo"E@,RY2d*"eE B,R Y21dj"A!D,R&HQdA"E),R4Fmd ֑E7}d EJ$H) b%YLHdC"EJ%J1,R-Y\2HdmXL( b3YhHd"uE 'TNr:YvHd E'R/`oB, e"EA(Q֨ @HYH)eZ ƔE)S,RPYFIe"EE*U,RXY2ie"ŕE+8,B_Y2e"5E,XY),RgвFe_PkزHer Ee 6E.kT]!awYHe"E/T_1,BYs ̚6,R Hf: E*1b bYF9fz E*2d,RY*Yf ̢ Ej3g bY>Hf "%Ej4iqYLHfB EJ5j1,BY\f "E79f}),RYl3f"AL7n(,R|Hf"AL8p!aYQYsK"Ej9s,RY3Ag"$1l:u_nuĮHag Eh;kwaYHg &Ej<y,RYγHgJEj=/ĞE=Z{4SAĥS{RkO]jҗSR{RkO\:'.S'Щ=Z{ jAkO:ĥ֞B=q=u'NK=qԞtjO]j)wjO\:.ԥ֞tjO\:PkOS{ z|R{$z?.ǯOSZ{RjOJC=u'QjO~\jO]jK=y)'/jI ړ(~=y)PkOF}=ԥ֞ړ>0[{PkO^JK$J퉏;'/ԥ֞ړ(O|UkOnIt_/~&=u'/:>'/GԞړujO]jK=ujO]jK:PkO:PkOujO^z}{~tjO\:'sNK=u'/GԞ:ړujO]jK=ujO]jIxh}AujO:~=u'/7ԞړcNKSZ{kNK=y)'/}oԩ=qԞSZ{=7ԞB=>7Ԟԥ֞Fx鵿Q}|oTkOjC=y龿Qԥ֞ړ豿Qԥ֞ړ^ujOFړsNAkO^zoԩ=qԞߨS{R{PkOzoԩ=u'/7ԞB=>7Ԟ[{RkOFS'mNAkO]jK=yRjOjIXS{PkO]jK:.${~D:'S{:'}N)SxN^zNŗS[{LCjkC:.ԥ֞SZ{RkO=i^ujO}߭=y鹿XjIt_S{RkO]jKjCġ֞4:.bSZ{RkO^z/VkO`Moδ$_S{ 7ړ_NK=u)'==N?=`$ө=u.8SZ{}ө=Z{ԞSZ{$zoө=6SZ{RjOzө=i=u'/ԞړS'筵PkOoKq:PkOq:.ԥ֞t_֞8tjO:'/=ZpjO}\kO]jKu:'m}NIN֞F|}N.dSSZ{sNK=yN|=>'Ԟ?Yԥ_pk}NIyO֩=MNK:'mNKujO]jK:˭ǵԥ:.ݿ.OR{}Z{ʴ$?:S?֞ړ^tjO}\kO^zө=u):}=_R{p3_o מZjA=jA=BK9ȵ מZjA=B=ǸBK9ȵ ֞c\{^h=BK9ȵ מ\{^h=}sk - מ\{^h=sk?h=X{3gk ֞\{a9ȵgk ֞A= b3 מA=X{r3gkA=X{3gk ՞c\{ by bĿ3g՞U=~ b9ȵgk ֞A= bsk ՞1=X{r3 מAZj ֞\{ b9ȵgk ֞A=/ԞA=X{3gj1=X{ b9ȵgk ֞\{ bsk ֞A= b3 מAԞA=ask ֞A=X{^h=X{3gk ֞\{ b9ȵgk ֞A= bsk ֞A=X{r3gkA=X{3gk ֞\{ zoR{ bsk֞A= QKsk ֞A=X{r3 מA=X{3gkA=cn3 מA=X{r3gk -gD-gkA=X{3gjσwR33 ֞1=X{3gkA=X{a9ȵgk ֞A= bsk ֞A=T{^f=T{ư3gk ֞\{ z/k֞A. מA=X{r{3 מA=cX{3gkA=X{ b9ȵgj֞rsߦ b9ȵgk ֞\{ bsk ՞1=X{r3 מA=X{3hsk ֞A=X{r3 מA=X{R{ bsk ֞A= R3m./D b9ȵgk ֞A= bsk ՞1=X{r3gkA=X{3h?3煖3gkA=X{ b9ȵgk ՞c\{ ܺԞ\{ b9ȵgj֞A=Ǹ b3 מA=X{r3gkA=cX{37=EԞ?͆itЩ=qԞSZ{jԞNKj tjO֞B=Z{GNC=qԞB=q=u'NK=qԞtjO]j)wjO\:.ԥ֞tjO\:PkOS{ J)OKҗړk֞ړR{RjO]jK=y(ԥ֞D=q=u.ԞS'Q2LS'QjOZ{RjO֞DR{oK=y)'/MC=u'/=_Qҩ=R{NK=u.$JoC홯jӭ=Ϥ.Ԟ?ZǵhSR{cNK=u'sNK=y?ZjI?ZjI{NKoNK$z֩=u.hSZ{cNK=u'sNK=o/sNIQԏ.FSZ{}oԩ=ysZ{PkOzoԩ=u'/:'>ԞSZ{RkOFS'FS?֞ړި/7Ԟ֞\ߨS{PkO^oԩ=u.$zoԩ=u.Fړ趿Q$ߨS{GړujO\:'/=7ԞԞ:ړujO]jK:PkO:֞ړ辿QjItߨS{GSZ{RkO^z~{~SZ{='Ԟ:SZ{sNK=ߞkNoԞDxsNItߟS{ 7ړujO]jK;yzkԧǷ:.ԞSZ{MI_S{nK:PkObSZ{RkO^z/VkO:'y/֩=u'/=ԞSZ{sZ{kjO}ӭ=u'ZS֞t_S{RkO]JCoՏ>m'=tjO]jK=y?Nԥ֞DtjO֞4m:'~ԥ֞D=tjO}=y龿Mԥ֞ړtjO}ZkO]jKq:.8iIyk)S[{cN)ړcNK=u'/ש'NK=>Ԟړ^tjO:Mٯ\WkOdSZ{RkO^zO֩=qO֩=y?YԥԞY$<'ԞOKdړ?Y:.dSZ{S{Z{RkO^zO֩=u)'PiI7YDu:~=u'/Ԟ֞_S{RjOjCuR{?jA=/Ԟ\{r9ȵ՞\{r9ȵ煖skA=/Ԟ\{r9ȵ\{q9ȵ煖skA=Ǹݵ מ\{^h=sk - מ\{rysk - מX{qmgk ֞\{ bsk ՞1= b3 מA=X{3gkA=X{ b9ȵgk ֞\{ bsk ֞A=/ԞA= ֞\{ sʵgoC ֞A= b3 מA=X{r3gkA=X{3?ZKsk ֞A= b3煖3gk ֞\{ R9Ƶgk ֞A= bsk ֞A=X{ bsk ֞A=X{r3gkA=cX{3gk ֞Zj ֞A= b3 מA=X{r3gkA=X{3gk ֞\{ bsk ֞A= b3 מA=X{^h=X{ b9g k ֞\{ߨ b9ȵgk ֞A= bsk ֞A=X{r3 ֞1rsk ֞A= b3煖3gk ֞\{ b9ȵgk ֞A= Rڳq_j ֞A=Y{ b9ȵgk ՞1= b3 מA=X{r3gj,gj֞\{ bsk ֞A=a"X{rVK9ȵgZj ֞\{ask ֞A= b3 מA=cX{^ȵgm3 מA=X{r3gkA=T{ư b9ȵgk ֞\{ bskϠϛkA=X{ b9ȵgk ֞\{ b2K3gkA=X{]T>T{q3 מA=X{3gkA=T{ư b9ȵgk ֞A= bskϠ k ֞Zj ֞A= b3 מA=T{q3?rR{r?YK9ȵgj֞A=Ǹ b3 מA=X{r3gkA=cX{3WR{4AĥS{RkO]jҗSR{RkO\:'.S'Щ=Z{ jAkO:ĥS{ ǵԡ֞8tjO\ԥ֞tjO\:.j퉏;'.SZ{RkO\:'.S'Щ=Z{ i'|KI\kO]jK=y).ԥԞ7Ԟԥ֞tߨS{RkO:'/}oTkOjC:.ԞQǝړR{RkO]jIߨS{ $ߨS{GSZ{FSړujOjK:.ԥ֞D:.ԥ֞ߨS{7ԞDujOZ{sNKFSSZ{sNK=y龿QjIQ7SZ{7ԞB=nujOZ{RkO]jKooOR{PkODSZ{RkO^zOԩ=u'#zOԩ=ړߞ/}Oԩ=ujO֞[{cNK=u)'=>q'=޿P~Kӭ=M?'ԞSZ{MI_S{nK:PkObSZ{RkO^z/VkO:'y/֩=u'/=ԞSZ{sZ{kjO}ӭ=u'ZS֞t_S{RkO]JCoՏ>m/ک=ߧNK=u'/=Ԟړc}N ړ涿MԞړ('sNo'/ԞSR{cNOkK=y?Nԥ֞֞2=?o=Z{~kO^zө=Z{}ө=u.:ġS{Щ=yӂS{Z{RkO^z}ޅM@=yOVkO֞D:.ԥ֞؟S{Z{RkO^zO֩=u)'ݿ=Y?JK ǵ:.돗^ujOcNoԞtjO^zO֩=nujO^ܟS{RkO^zO֩=u'/_n=>.S{RjOSkO֞DG_S{SZ{kNkKu:.ԡ֞<\_/K_j._9òmA g=ye3۞A o{q3۞m n{qs=cԶ o{q3H۞1m n{qs=m n{g=mA g=y3۞A煖m"m{i3۞E,Ҷg=Ymm{q۳H۞E,Ҷg=Ym"m{q۳H۞E g=Ym n{i۳H۞A,Ҷg=m"m{is=YQ=Y􁙴۞aڳ_W=m"m{i۳H۞A,Ҷg=Ymm{i3۞E,z=nm"m{q۳H۞E g=YmA,Ҷg=m"m{a3۞E,Ҷg=Ym"m{q۳H۞E,Ҷg=Ym n{i۳H۞E g=Ym m{h۳H۞A,Ҷg=9۞E,Ҷg=Ym"m{q۳H۞E g=Ym n{i۳۞1,Ҷg=жg=Ym n{i۳H۞A,Ҷg=m"m{is=Ym"m{i۳F۞E gg=Ym"m{i3۞E,Ҷg=Ym"m{q۳H۞EOǓYs۟(n{h3۞E,Ҷg=Ym"m{g=Ym n{i۳H۞A,Ҷg=m"l{h3۞hʳHSE Ҕ_OY=m"m{a۳F۞A,Ҷg=m"m{i3۞E,Ҷg=x۳۞5 g=Ym n{i۳H۞AѶgm m{q۳cmϢkm"m{=Ymm{a3۞E,Ҷg=Ym"m{q۳۞5qgmYm n{i۳H۞A,Ҷg=m"l{h۳H۞A,Ҷg=Ym"m{a3۞E7n{q۳H۞E,Ҷg=Ym n{i۳H۞Em"m{i۳H۞A,z&Wj3_=kYmn{i۳H۞A,Ҷg=m"m{i3۞EѶg=Ym"m{i3۞E,¶g =3,Ҷ o{i۳H۞A,Ҷg=m"m{='۞E,m n{i۳H۞A,¶g=жg=Ym n{i۳H۞A,Ҷg=mm{=i,ͶϿjA=/Ԟ\{r9ȵ՞\{r9ȵ煖skA=/Ԟ\{r9ȵ\{q9ȵ煖skA=ǸR{r9ȵ煖skA=R{r9ȵ מZjA=R{r9מV{ b9ȵgk ֞A= Rsk ֞A=X{r3gkA=X{tUb3 מA=X{r3gj1=X{R{ _X{r3砿=UX{3gk ֞\{ b9ȵgj֞A= bskϠh-gkA=X{3gk ֞Zj ֞A=X{r3HמA=X{3gkA=X{ b9ȵgk ֞\{ bsk ֞A=X{b3 מA=X{R{ b9ȵgk ֞A= bsk ֞A=X{r3HמA=X{`3gkA=X{3gk ֞\{ by b3 ֞1Ԟ\{ߨ b9ȵgk ֞A= bsk ֞A=X{r3 ֞1rsk ֞A= b3煖3gk ֞\{ b9ȵgk ֞A= Rsk֞A=X{Ry ĝ~e=X{a9ȵgk ֞A= bsk ֞A=T{^f=T{ư3gk ֞\{ b9g kϠmsk ֞A= VKsk ՞1=T{q3 מA=X{3Hg k oR{3Csk ֞A=X{r3gkA=X{3gk ՞c\{\{r3gkA=X{3gk ՞Yj ֞A=X{B.WO@ ֞\{ask ֞A= b3 מA=X{r3gkA=X{ b9ȵgk ՞c\{gX{R{ b9ȵgk ֞A= bsk ֞A[sk ֞A= R3HמA=X{3gkA=X{ b9g k ֞V{"sk - מ\{rm מ\{rysk - מ\{ry!מc\{rysk1=/Ԟ\{ryskA=/Ԟ\{r9ȵ煖skA=/Ԟ\{b9Ƶ՞A=X{r3gkA=T{ư3gk ֞\{ bsk ֞A= b3 מA=X{r3gj1=X{R{ _X{r3砿=UX{3gk ֞\{ b9ȵgj֞A= bskϠh-gkA=>Gk= b3煖3gk ֞\{ R9Ƶgk ֞A= bsk ֞A=X{r3 מA=X{3gk ֞X{ư b9ȵgk ֞A=/ԞA=*i b3 מA=X{r3gkA=X{3gk ֞\{ bsk ֞A= b3 מA=X{^h=X{ b9gF- מA7j=X{r3gkA=X{3gk ֞\{ b9gm\{ư3gkA=X{ by b3 מA=X{r3gkA=T{ư3gk ֞\{ ŝ~f=T{ư3gk ֞\{ b9ȵgk ֞A=/ԞA=cԞA=X{3gkA=cX{m֞\{ b9ȵgZj ֞\{ask ֞A= b3 מA=cX{^ȵgm3 מA=X{r3gkA=T{ư b9ȵgk ֞\{ bskϠۃ מA=X{3gkA=X{ Ry b|h+gk ֞\{ask ֞AZj ֞A=X{r3 מA=cX{3gk ֞\{ R9Ƶg~gk -gk ֞\{ bsk ֞A=Ǹ b~u= bsk ՞1=T{q3gkA=X{3gk ֞X{ư bmgoj{n_k?A=~NKԥ֞/Pkԥ֞tjO\:PkOS{ j)?֞8tjOjKj퉏kC=qԞtjO]jKĥS{RkO֞S{ҩ=u.ĥS{ҩ=Z{SPjO֞_jԞD˰>.ԞSZ{RjOJC=u'QjO~\jO]jK=y)'/jI jIS?֞S'}}Ԟ[{RkO^JKS{PkOjK=qԞD=qԞSZ{joCٯ=Ϥ.Ԟ?ZǵhSR{cNK=u'sNK=y?ZjI?ZjI{NKoNK$z֩=u.hSZ{cNK=u'sNK=ujO֞DujOZ{RkO^oԩ=u:>'/}oTkOjC:.ԞQǝړSRkO]jIߨS{ $ߨS{GSZ{FSړujOjK:.ԥ֞D:.ԥ֞ߨS{7ԞDujOZ{sNKFSSZ{sNK=y龿QjIQ7SZ{7ԞB=nujOZ{RkO]jKooOR{PkODSZ{RkO^zOԩ=u'#zOԩ=ړߞ/}Oԩ=ujO֞[{cNK=u)'=>'=ԞSZ{RjO]jK;&/.?HkO^z/֩=Z{ԞSZ{cZ{Щ=q'sNK=y鱿Xԥ֞ړړ?XS{n3=>ԞB=ZSZ{RjOz|{~.:SR{}Z{ʴ$?:S?֞ړ^tjO}\kO^zө=u):}=_R{p,OL{e<9c8929c89ye9cc9Sye<9+c49.xe9c9㝗yrs ;ps ;/1xs 7;hs;e3F{1kF?|:c4MuRg :C931ZHg6:p3F 1>sh3Fci-shs w9c4U1&g&9c91e1b49K1瘿?mpg8c41ߌf7p{3ӛ!Zތnhv3Fc8s[!Onhqs 7c1\یf6c4y/mhh3F;1Õl`cs'6ckf5c49ۚ1֌Ѳf5pW3F1ZQmjhR3FcԌўf4c9Fc!Ҍє.ihH3F;1ѼW4c4>NhhA3F1̘xngh:3F˙1f`5sG3c-f`f2c41ˌVf2p)3FC1ɌLdh$3FDf2c4}1 :f1p3x3FØcYbhs 71c4E1Čf0c9c1Œ-aG;!`hs '0c_^1Ze/p2F˗1^h2Fcy-^e.c4w1XO]ev-c0kU1OZUe2F1Å \hr -cnql[^Ӗ1X yow-c4kUZe&-ch9F!ڳy;'51іe,p2x2F3cbmX`r,c4`1ze+c]9ӕ1X pe[r[_Vhr 7+c4Y1^e*cV9c1ت Te*p2F;1ÕTh2CP>Sh2F1ڦi-Shr w)c4KUR^DBTƼ|1cq A@r2H GA A2%dS C zoC1 b$r FA"/dA"F42mdA#~oG1B2d F\I1 b'9ȡdK Al%9 b-\r{ɘDa29d VM b8rBK:v2dA'O12 e F\Q)aG9!e K Al)9 _%2Ae&TĆ2_ٲA*V2me ՕY 1 , bb2 WA,Ybh2E2esA-~R\12He ec]1 by9e ƗA/9 RB.0cnc4A0 bsC AL1br39f{A2Xd1&3Qf ece\fr63qfA3g1B3f͠B_3 vA 5 bVsc ՚15kqb3 7A6Xm1n3fAN7n0 b9f A,89 bs+Π ; ZJ AZb ֜A9srĢ3HI7A:/.Y wA ;Xvr3qg1;w1 b9ȉg F\y1 bsKAl=- MZ{4SAĥS{RkO]jҗSR{RkO\:'.S'Щ=Z{ jAkO:ĥS{ ǵԡ֞8tjO\:.ĥS{ҩ=uPkO|ܩ=qԞSZ{ҩ=qԞB=N)Sk?OKҗړk֞ړ?_jO]jK=y(ԥ֞D=q=u.ԞS'Q2L:{PkOԞԞB=7SZ{RjO^lC=y)'.ړ('>ԞSZ{RkOԞB=~=U}}Ԟԥ֞ړ>GԞ֞S{RjOz֩=u.$z֩=u'/=GԞB=>GԞB=~֩=yҩ=qԞD:.ԥ֞ZS{PkO^z֩=u.$z֩=u'cN)ړcNAkO]jK:.$ߨS{Fԡ֞<ߨS{RkO^JKujO|ܩ=y).ԥ֞D:PkO:~=u'/=Q?^zoԩ=q=y鹾Qԡ֞tߨS{RkO]jIߨS{RkO]jK:'mNIQԏ'/=7ԞtjO^zoԩ=q=u'=7ԞړujO֞DujO}=u'}N)ړ趿Qԏ.ԥ֞Ft)$zO?s'ԞܟS{RkO'GڟS{?'/==Q?^ܟS{'ԞB=DSZ{RjOz/TkO}XkOz/ԩ=u.ԞSZ{MIS{nK:qPл_R{IkO}~kO]jKjCġ֞4:.bSZ{RkO^z/VkO`Moδ$_S{ 7ړkujO]jK=yE;'}NK=u'/=Ԟړc}N ړ?VԞړ('sNo'/ԞSR{cNOkK=y?Nԥ֞֞2=?o=Z{~kO^zө=^S{oK=u/4jԞ8tjO^zԞ֞ړ^ujOdړs}^=SvoYmIE{tcQM_3Q#)S{RkO]jK:>.dSR{Ǔ?[8$؟S{dS?K:'~?Y7}jO\:'/='ԞDujO^ܟS{RkO^zө=u'/_n=>.:SR{mZ{ʴ$:S?֞ړtjO}\kO^ө=u):}=__V{rǺe3۞m n{qB˶g=mA g=y3۞A n{p3۞m m{ps=mA g=9۞A g=y3۞Am n{i3۞Z=Ym n{i۳H۞E g=km"m{i۳H۞A,Ҷg=m"m{i3۞E,Ҷg=YmϢ'f҂Ym"m{a3۞E,Ҷ o{i۳HGE g=w۞^W~i۳H۞A,Ҷg=m"m{i3۞EѶg=Ym"m{q۳}YmϠ=Ym n{i۳H۞Em"m{i۳H۞A,Ҷg=cYm"m{i3۞E,Ҷg=Ym"m{q۳H۞E g=Ym n{i۳H۞E Ҷg=m"m{i۳H۞Ym"m{q۳H۞E,Ҷg=Ym n{i۳H۞E g=m"m{i۳H۞A,Ҷg=m"m{=7۞E,Ҷg=YQm"m{i۳H۞AѶg=YQ,Ҷg=Ym"m{q۳H۞E g=Ym n{i۳H۞Ayߟ(n{h3m"m{i3۞E,Ҷg=y۳H۞E,Ҷg=Ym n{i۳H۞E g=kmm{i۳H۞A,Ҷg=Ym"l{h3۞E,¶A g<_fѲm"m{i۳۞cYmm{q۳H۞E,Ҷg=>۞AѶgm m{q۳H۞E gZy۳H۞A,¶g=m"m{i3۞E,Ҷg=Ymm{gXy۳H۞A,Ҷg=Ym"m{i3۞EѶg=Ym"m{q۳H۞E,¶g =?o g=YmϠ=Ym l{ 9,go{i۳H۞E g=m"l{h۳۞1,Ҷg=Ym"m{i3۞E,Ҷg=Ym"m{q۳H۞E,Ҷg=Ymn{gYmA,Ҷg=Ym"m{i3۞Emn{i۳_r=Ym"m{q۳۞5,¶g =Ym"m{q۳H۞E g=Ym m{h۳H۞Z=j?6jA=/Ԟ\{r9ȵjA=BK9ȵ מZjA=B=ǸBK9ȵ ֞c\{^h=BK9ȵ מ\{^h=sk - מ\{^h=sk/՞A=X{r3gkA=T{ư3gk ֞\{ bsk ֞A= b3 מA=X{r3gj1=X{R{ _X{r3砿=UoG ֞A= b3 מA=X{r3gkA=X{3}3 מA=X{r3gk -gk ֞A= bsk ֞A=X{r3 מA=X{3gkA=X{ b9ȵgk ֞A=aߨ b3煖3gkA=X{ b9ȵgk ֞\{ bsk ֞A=Ǹ b3 מA=X{3gkA=X{ b9ȵgF-煖3gk ֞X{ư b9ȵgF-gkA=X{ b9ȵgk ֞\{ bsk ֞A=yߟ(מ1= bsk ֞A=X{^h=X{ b9ȵgkϠD-gk ֞A= Rsk֞A=X{r3 מA=T{ư3gk ֞\{'/=7Ԟ:ړnujO]jK=ujO]jK=y鹿Q$zߨS{}oԩ=#ߨS{ҩ=qԞtߨS{R{PkOzoԩ=u'/7ԞB=>7Ԟ[{RkOFS'FS?֞SZ{ۥԞ:ړ>Qԡ֞ړujO]jItDujO|Ǐ'KujODS֞tߟS{RkO]JCjkC:.ԥ֞SZ{RkO=iujO}߭=y?PjItS{ԞtƝzQjO\nI_S{RkO^/֩=u.by=Mԙ֞DkujO֞[{mNK=u)'Vg{NIt_S{RkO]jK:.$X_S{yS{pjO]jIړ?V7ړncujO]jK=y?Nԧԥ֞S{RkO^SkO֞D럷֞B=~kO^ө=j4+|PoSZ{RkO^OVkO:'ړ?!SSZ{sNI>Y$\gkOdSZ{RkO^O֩=q=u'/='Ԟړn?_=‰o'dړ>'Ԟ ^zO֩=3:'S{ҩ=y:':ړ>ԞړtjOjK[OkK=y鱿NԥԞm n{qB˶g=9۞A g=y3۞Am n{q3۞m m{g=ߨe3۞A o{q3۞m n{qs=m -۞A g=q3۞AmϠZ=9۞A g=y3۞Am n{q3۞ n{gDy3۞m n{g=m -۞A g=y3۞Am n{q3۞mn{g =mA g=y3۞A o{q3۞Am n{=j g=Ҕe)ϠS~jm n{q3۞m n{g =^o+Dps=mA z_e3۞mn{is=mA g=9۞Akl{^۞1cl{qs=mA g=9۞Ag=y3۞Am n{q3H۞cy o{q3竐3_A z= qs=m m{^f g=9۞A zOֲmn{is=mA g=9۞A o{i3۞Am n{q3۞m m{g~۞Aвm n{g=mA g=x3۞A[mA g=y3H۞1 Ҷo{q3۞Am n{qs=m n{g:-۞_h zm?,RڳHgj"՞\{,RY3gj"՞A=T{,RڳFgj ֞E=P{֨ bYڳHgk"՞E=T{,RYڳHgk"՞E=X{,BYskσP{ڳHA=Byj"՞=AY Ԟ<gjσP{ ԞE=ByHA=Byj"՞<gjσP{׵gjσP{3A=_BY Ԟ,B 7MBW<gjσP{ ԞE=Byj"՞=Ayj"՞<gjσGA=T{ ԞE=ByjσP{<A=BY Ԟ=kT{ Ԟ,RyjσP{<A=BY Ԟ,RyjσP{ڳHA=Byj"ԞǠ<gjσP{ ԞA=Byj"՞<A=T{ ԞE=ByjσP{<Ak՞<AbyjσP{ڳHA=BY Ԟ<gjσP{3A=Byj"ԞǠ<gjσ7A=T{ Ԟ,RyjσP{<A=BY Ԟ,ByD<gjσP{ڳHA=ByjϠ?s}X{ ԞE=Byj"՞<A=T{<gjcP{ ԞE=Byj"՞9Ɠq;9cN^fcXM~%fr 1,&/`r{1%/Zr,q)9vcI^ƕFcH^ƉcHaycXGayCGeq9YVq9M&cXD~?,=cXC^1cB^%cAayWc 0r 1/q 1/q 1*0|1ǰz2n0y2ǰwqj/Ďc:ax5 k|N[xWc9ax&CX8y f7^y֍c7^m㘷Y1 /q!(j1Lǰh10gÚ2Ǩe”˸d>?K8e\1a8 e0a8q8FƋc.^c.^fcX-Qx7c?^./`U8_cX+^Ʊc*^ƥc)QEJq #1l0Q 1 ǰO10N6"NGh /.q 10J1LǰH10G2ǰEq K8Dq2ċBa8 Y 1 ǰ?10>2Nǰ<"0;^&cX^CQmxdžcaj8eag8e\ad8&aa8̖yo~DA ߷x) u.1|}[d(} u!.Ni(贆B Z 57ď!PZIPC:!.P)q餇P!>ԇtC]jK qtD6@'Bj( Qo%"QFkKy)5"/%Gԥ R$PD]jH(*Q%RD^JK)&寸DZ'%Oԏ}"/%PjHt[ߨoFJ)t:PQZ*RRE\:"QbE|ܩy).WԥD),Ϳ/YWG[IE]jK ysNkKOE]JC:.`ԥ&D:.bhQ!#hQ-#h?_.NH4RF]jK:YkhQ6RFhQ7GB->744rԥVtߨ9RCG:#/}oTcGjC:.5xQyǝ著R=RG]jHtߨS> 5}$ߨ?GQ?FRu"HjK:.5ԥD:-.5ԥ֐ߨCo)">744F,NK:e>.iF:RGmN )BcN#o.$o$JoI%#h+K%u$/=~Q]J/C &uIj3K&y?Q'ԥvDOԯ?Q'7~I^zx~?Q'$O (ZPoBK:.ԥd<_].5:SvmZw4$:S?&Ɠt*O}\3O^JKSzc}Ş/}=߿9cA\9 IqP2E -Aܔ dW%yV2Ae NKq[2㒃.y Kd&41ÍA dg&yg2CA\ oMql2kA Nqqr''9N^h,d'՞*֞A= b3 מA=X{r3gkA=X{3}3 מA=X{r3gk -gk ֞A= bsk ֞A=X{r3 מA=X{3gkA=X{ b9ȵgk ֞A=ask ֞A=X{^h=X{3gk ֞\{ b9ȵgk ֞A= bsk ֞A=X{r3gkA=nԞ\{ bsk ֞A=/ԞA=X{՞1=X{rQKsk ֞A=X{r3 מA=X{3gkA=c'ʵg kA=X{3gk ֞Zj ֞A=X{r3 מA=X{3Hg kA=cX{ b9ȵgk ֞\{ Rsk ֞A=X{r3 מA=X{R{j= b3 מA=b9q_SjϠ׿msk ֞A= z_ b9ȵgj֞A=Ǹ R{r3gkA=T{ưkϘZj ֞\{ b9ȵgk ֞A= R3 מA=X{r3gU9_Z3gk ֞\{ b9ȵgk ֞A=/ԞA=X{3gkA=T{ư R9Ƶgk ֞\{ bsk ֞A= R3 מA=X{3gj1=3=X{^h=n=X{r3gkA=X{3gп֥3gkA=T{ư R9Ƶgk ֞A= bsk ֞A=X{b3jϠ=[9ȵ煖skA=B[9ȵ מ\{^h=BK9ȵ מ\{^ȵמ\{^h=sk - מ\{^h=sk - מ\{rysk - מX{q3gkA=X{ b9ȵgj֞\{ bsk ֞A=X{r3 מA=X{3gkA=X{ R9Ƶgk ֞Zj ֞A qkA=X{3V{X{3gk ֞\{Gk= R3 מA=X{r?ZKsk ֞A= b3煖3gk ֞\{ R9Ƶgk ֞A= bsk ֞A=X{r3 מA=X{=T r3gkA=cX{3gk ֞Zj ֞A= b3 מA=X{r3gkA=X{3gk ֞\{ bskϠF- מA=X{3gk -gk ֞A=askϠZj ֞\{ bsk ֞A= b3 מA=X{b?Q=cX{r3 מA=X{='j=X{ b9ȵgk ֞\{ bsk ՞1=a3 מA=X{r3Hg kA=X{ b9ȵgk ֞\{ b2Kt[3gk ֞\{ b9S1;^rݫvjA=X{3m3 מA=cX{3gkA=X{ b9ȵgj֞r?VKsk ֞A= b3 מA=cX{3gkA=X{=_J ~q!t9ȵgk ֞A= bsk ֞A=T{^f=X{ b9ȵgk ֞\{ask ֞A= b3 מA=X{r3gkA=X{ b9ȵgk ՞c\{gX{R{ b9ȵgk ֞A= bsk ֞A[sk ֞A= R3HמA=X{3gkA=X{ b9g k ֞_h=}=BZ{}&NK=uKjO֞?[K=qԞtjO֞@j)S'~=qԞ:N)SZ{Щ=qԞNKԥ֞BԞS{ҩ=u.ĥS{ҩ=Z{SPjO֞jח՞D˰>.ԞSZ{RjOJC=u'QjO~\jO]jK=y)'/jI jIS?֞S'm}՞[{RkO^JKS{PkOjK=qԞD=qԞSZ{jI6ڳ_u[o~&=u'/:>'/=GԞړujO]jK=ujO]jK:PkO:PkO:'/='/=7Ԟ:ړnujO]jK=ujO]jK=y鹿Q$zߨS{}oԩ=#hK:'.ړujO}\jOjC:.+~鶿QjIQ7SZ{7ԞB=7Ԟԥ֞ړ?ި.ԡ֞D:ԥ֞؟S{RkOۏ'WܟS{?'/=~'.ړR{RkOu:'/}ө=u'/=Ԟ:ړ/SSZ{cNK=y趿N=eZ{M_}N@kO]jKu:>'/ԞSZ{c}՞/}=?m}k o{q3۞Aвm n{qs=mA g=9۞1 o{q3H۞1m n{qs=mϠ=y3۞A o{q3۞m m{pB˶g=m"m{i۳H۞A,¶g=Ym"m{i3۞E,Ҷg=Ym"m{q۳H۞E,Ҷg=Ym n{i۳H۞Eg=9۞E,Q=Ym"m{q۳퟿Wi۳H۞A,Ҷg=m"m{i3۞EѶg=Ym"m{q۳}Ym n{i۳H۞A,Ҷg=9۞E,Ҷg=Yړm"m{i۳H۞A,Ҷg=Ym"m{i3۞E,Ҷg=YmϢ'k)Ym"m{i3H۞5,Ҷg=Ym"m{g=m"m{i۳H۞A,Ҷg=Ym"m{i3۞E,¶g =Ym"m{q۳H۞E,Ҷg=Ym n{i۳H۞E g=9۞E,Ҷg=Ym"m{q۳mYm n{i۳H۞E gmm"m{i۳H۞A,Ҷg=Y?QѶg=Ym n{i۳H۞Eg=Ym n{i۳H۞A,Ҷg=m"l{h3H۞5,Ҷg=Ym"m{q۳H۞EѶg=Ym"m{q۳H۞E g=Ym1,¶g=Ym"m{i3۞E,Ҷg=kYrJBSA,”_[=YV,Ҷg=Ym"l{p۳H۞E g=Ym n{a۳F۞Y?V,Ҷg=Ym n{i۳H۞E g=kYm n{۞A|r+5Yz¶g =? g=Ym n{i۳H۞A,Ҷg=9۞E,Ҷg=Ym"m{q۳۞5,¶g =Ym n{i۳H۞E g=m"l{h۳H۞A,Ҷg=m"m{a3۞Em{is=Ym n{i۳H۞E jK,¶g =Y/~۞A,Ҷg=Ymm{a3۞E,Ҷg=Ytög=Ym"m{i3H۞5,Ҷ煖mϢ{[kA=/Ԟ\{r9ȵjA=BK9g?\{^h=sk sk - מX{qysk - מ\{ryskA=/Ԟ\{rysk1=V{ b9ȵgk ֞A= Rsk ֞A=X{r3gkA=X{3gk ֞\{ b9ȵgk ֞A=Ǹ bBK3!b9ȵgk ֞\{|^ǝ%*֞\{ bsk ֞A= R3 מA=X{r?ZKsk ֞A= b3煖3gk ֞\{)3gk ֞\{ b9ȵgk ֞A= bsk ֞A=X{r3gkA=cX{3gk ֞Zj ֞A= b3 מA=X{r3gkA=X{3gk ֞\{ bsk ֞A= b3 מA=X{^h=X{ zok֞A= zߨ b9ȵgk ֞A= oR{r3gkA=X{3}\{ư3gkA=X{ by b3 מA=X{r3gkA=T{ư3gk ֞\{ b9ȵgk ՞1= b3 מA=X{r3gj,gj֞\{ bsk ֞A=a"ԞA=b9Hq_j ֞A= R3HמA=X{r3gkA=T{ưkϘZj ֞\{ b9ȵgk ֞A= R3 מA=^מBJ$k ֞A=Ǹ Z3gk ֞\{ b9ȵgk ֞A=/ԞA=X{3gkA=T{ư R9Ƶgk ֞\{ bsk ֞A= R3 מA=X{3gj1=3=X{^h=X{3gk ֞\{ R9ƵgkϠ˭K9ȵgk ֞\{ask ֞A=X{r3 מA=X{3gk/՞AS{Os [8s C1<̒ya96q9q9y֝cw^mcXv^avcuayGctaycta99e\sa9-q9!vq9ECp~%Qs 17coat3D16cmƨh3Ffclƨ׌Q9fb1J5ǰԌQNs 3U14chaB3Feg(ό_`c1l3cfƨ03 :WYfHUF1j2cdƨ 3F=fr11ccŌQ9%fBucaƼϐ#5c`ƨQ9e՗1//2Fec](Au9e%1*.[(2FeZcXZ(Qg9e*E1j,0Qa2F}!+cWa[2Fee˸QVr 51J*cTTaP2F9֔1)cR(Ò2F!e :!(cTQ(QC9 e 1'0Q=xr 1*'cNa7l2FeMƨQ2\_!%cKa-:n%cJa)P2Fd21$cIƨD2FdcGƨQ9Fmd谌 Q9]dUcEƨQ"2"cC(Q 91dZcXB(Q r̟ A2Ddc?ƨ~Q8c! ǰ{Q1F61JcTYs}n7ƨnQ8Õ1o1 ǰkA1Q61JcT4a1F9cj1c2(e KƐqq +E1j0aQ1F1C/ƨ]tEp/T1c-ƨZA8bg1c+ƨVX1FbR1,c*ƨSAxW1c((QB1Fb1cP'(NA8]ibc%(KQ(q %1*0HA1F5ƈ1jc"ƨD1Fb 2!c#jc ^bcƨ>Q|p 1;QvҦ1lcƨ80arԆCƨ5Qjp Cu1 ǰ2Qd0F! c~%/y5$r?/j_ NaKM uK"CV?[fK q鄆tJC@5jl(P!~ q:Nr(PZqtNyK'=ԥBq>ĥRC]jK@ĥ A:P+Dd2_/}+7Z}\[D]jKy)9.Gԥ<"Q$RDDT,Q%RD^J(4(%J(:(y~y)P EF}k7RԥVLSԡ:R*i+NKu.5X$J(dm5-ZWZϤ٢>"/%\:>"/=Gԋ|uF]jKMu"F]jK:PCFD:-#h?_.NH4RF]jK:YkhQom#cNݨKuGD_54rԥVtߨ9RCG:#/}oTcGjC:.5xQyǝ著R=RG]jHtߨS> 5}$ߨ?GQ?FRu"HjK:.5ԥD:-.5ԥ֐ߨCo)">744F,NK:e>.iF:RGmN )BcN#o.$o$JoI%#h+K%u$/=~Q]J/C &uIj3K&y?Q'ԥvDOԯ?Q'7~I^zx~?Q'$O (ZPoBK:.| ՐR֒ uZJ]jLK)y)9.ԥDST<4UcNV)Ԯ?PԥԶպN^C+iu K]jbK:.ԥf44鶖:ؒcNn)RxK^),5:RcKg{NwIt_S^RK]j{K:.5$X_`y`p"L]jI ?V'7ncuZL]jK1y辿VO{ZW_I.ԥFtߟf22?-3ftߟSg 5$؟hR M]jKjCġic'jZjRSM^zO։5'DlIt۟lRM]jK:٦>ݦ.5dtSnǓ?[8-$_p:Sps}NI 9MNKu:1':>ԢtNjK[O֩kשK ;y鱿N'ԥ:,#CNưQ*r 51J"cTD^Adz1!0Q r K1 cAa2D %!* c@ƨ1Fc1lc>Ơ| Q8cU1ǰyQq 1cP;^ıc ZcX:(tQq +E1j(q Q7a1Fq1os1Fav1D/~Q61JcT4a1F9cj1c2(e KƐqq +E1j0aQ1F1/abux1JcT.(\n1FbDC,lX,a^1Fbj1c*(UR1Fb:dqH1Fb1,c(ƨO<1ubC&ƨLQ8]bU1ǰIQ"q !cT#a1F)bJ1 c! C 1f=1F e\ (@Q8aŇ1j0=Qype1/m::0Fa1 c(7Am8aZ1* 04Qgp +E1j cQa0F}Y˜ [^LeP/NaKM uK"CV?[fK q鄆tJC@5jl(P!~ q:Nr(PZqtNyK'=ԥBq>ĥRC]jK@ĥ A:P+D?vBחDkKy[Ku)A"Hԡ&&(Q"?.U.5Kԥv0R& 5M$_qXgjH74=RG]jKuGDuGZ?RG^x~ߨS@@c}NC y鶿Qԥ辿QԥƐuzH:E$F&R?F*NKF2R4RFcNK#y鶿Q'j!IQ7HR>7dD:$FTR?XRZKۥ:`>Q'ԡ6huI]j7ItDuI|㧝Ǐ'KuIDR&>'T ՐR֒ uZJ]jLK)y)9.ԥDST<4UcNV)Ԯ?PԥԶպN^C+iu K]jbK:.ԥf44鶖:ؒcNn)RxK^I.uͥ.%Cl,A~[xoyozKm/y龿VԥDkuL4cuLNK0a=ꄘ[bmNK1ҫ2_ciI?a'ԥ$SdRL^OXLvD–BM3~L^Oة3g7@SZhRM^oX#M:&L?!PSRSjsNI>Y'$\gMddSlRM^O6q6u&/='뤛vn?^_=‰o&:>$ ^zө83u:!'SrI9y鹿N'$JͩkKtN]jKu:M5˭'ǵԥ_vRNSND?Wt_SxSxsN婏kKu:.ԡ'k=X{3Hg k ֞\{ bsk ֞A=Ǹ ϰ by bsk ֞A=X{r3HמA=/. מA=X{r3gj1=X{ b9ȵgk ֞\{ bsk֞A=V{M?oР֞͏:'.SZ{Rkח՞B=_ܷSZ{ҩ=qԞB=N)SPkOZ{Щ=u'.S'>ġS{ҩ=u'.NK=Z{NKԥ֞NKj tjO֞B={ˎ+Kl#U0؍QB:WL(I&Lk߁oKjO?ǵԥ֞ړRkO]JC=u.$JɏKK=u'/ԞB=aԞB=R{[ړR{ $oԷS_xkO]jK=yijOjC=y)'.ړ('>ԞSZ{RkOԞB=>|oߨ_jԞԞ?ZǵhSR{cNK=u'sNK=y?ZjIgN)ړcNK/NK$z֩=u.hSZ{cNK=u'sNK=ujO֞DֿX}=-hK=y龿Qԥ֞D7ԞQ=u'7ԞړR{FwjO^JK=u'cN)ړFS߂֞ړ?ި_/7Ԟ֞\ߨS{cNK:.$zoԩ=u.Fړ趿Q$ߨS{[ړujO\:'/=7ԞԞ:ړujO]jK:PkO?ujO}=u'}N)ړ趿QԷ.ԥ֞Fv)$zOԩ=u.DSZ{Ԟ^zө=3u:'S{ҩ=y鵿N$ө=ysNK=y鹾Nԡ֞/~Ԟ֞ړtjO]ө=^tjO?+zө= hK=y鵿Nǵ:SR{PkOzӷo/~jA=/Ԟ\{r9ȵjA=BK9ȵ מZjA=B=ǸBK9ȵ ֞c\{^h=BK9ȵ מ\{^h=sk - מ\{^h=sk/՞A=X{r3gkA=T{ư3gk ֞\{ bsНgk ֞\{ bsk ֞A= b3HמA=X{^h=X{/A= bskϠOzwίr3gkA=X{3Hg k ֞\{ b9ȵgm3 מA=X{r3gk -gk ֞A= bsk ֞A=X{r3 מA=X{3gkA=X{7j= b3 ֞1=X{r3gk -gk ֞\{ bsk ֞A= b3 מA=T{q3gkA=X{ b9ȵgk ֞\{ bsk ֞A=/ԞA=X{3gkA=>7j=X{r3gkA=X{3gk ֞\{ b9gm\{ư3gkA=X{^A=/ԞA=X{3gkA=X{ b9ȵgj֞X{ư bsk ֞A= b3 מA=X{3gkA=X{ Ry Rsk ֞A=X{r3 ֞1=p]kA=X{3c3 מA=cX{3gkA=bOan מA=cX{^ȵgm3 מA=X{B.̯|~C=X{r3gkA=X{3gk ՞c\{]{r3gkA=X{3g}\{^f=X{ b9ȵgk ֞\{ask ֞A= b3 מA=X{r3gkA=X{ b9ȵgk ՞c\{gX{R{ b9ȵgk ֞A= bsk ֞A[sk ֞A= R3HמA=X{3gkA=X{ b9g k ֞_h=nU{~Կ՞͆mtЩ=qԞSZ{j՞NKj tjO֞B=Z{[NC=qԞB=q=u'NK=qԞtjO]j)wjO\:.ԥ֞tjO\:PkOS{ J)w[ҷړq=u'/ԞSR{PjOjK=R{R{RkO]jK=y)PkOe(PkOԞԞB=SZ{RjO^SZ{PkO^JK$J퉏;'/ԥ֞ړ(PkO7F}=[[9Nw'/}֩=q=y?ZԥԞ<S{RkO]jIS{RkO^z֩=Z{S{ $S{ǣ˥S{ҩ=ujO]jK=y>Zԡ֞S{RkO]jIS{RkOhS'џ:=u'/7ԞړFړ>7FSZ{RjO^ߨS{NK=u.$zoԩ=Z{ߨS{[SZ{FSړujOjK:.ԥ֞D:.ԥ֞ߨS{7ԞDujO} Z{sNKFSSZ{sNK=y龿QjIgN/.$oԩ=Z{7Ԟ?7Ԟړ?ި.ԡ֞D:ԥ֞ܟS{RkO'WڟS{ ?'/=VBM@i'/ԥ֞ړvjO}ZkO]jK ;.iIqn)S֞؟S{ $?aԥ֞ړNCOǵԥ֞߰S{'ԞDjItߟS{RkO]jKWǵԥ֞_S{RjOx~=g '՞DԞNԥpk}NIyө=ENKu:'mNKtjO]jKu:íǵԥ֞_S{RjOSkO֞D?W_S{SZ{kNkKu:.ԡ֞<\_oKjs o{q3۞Aвm n{qs=mA g=9۞1 o{q3H۞1m n{qs=m n{g=mA g=y3۞A煖m"m{i3۞E,Ҷg=Ymm{q۳H۞E,Ҷg=Ym"m{q۳H۞E g=Ym n{i۳H۞A,Ҷg=>cYm"m{g=?*Ҷg=Ym n{}UmϢ̯g=Ym n{i۳H۞A,¶g=>G۞E,Ҷg=nm"m{q۳H۞E g=YmA,Ҷg=m"m{a3۞E,Ҷg=Ym"m{q۳H۞E,Ҷg=Ym n{i۳辿Q g=Ym m{h۳H۞A,Ҷg=9۞E,Ҷg=Ym"m{q۳H۞E g=Ym n{i۳۞1,Ҷg=m"m{i۳H۞A,Ҷg=Ym"m{}o=YmA,Ҷg=mm{i3۞Em"m{q۳H۞E,Ҷg=Ym n{i۳H۞E zh۳H۞E ҶgmYm n{i۳H۞A,Ҷge"m{g=Ym n{i۳H۞A,Ҷg=m"l{h3H۞5,Ҷg=Ym"m{q۳H۞EѶg=Ym"m{q۳H۞E g=Ym1,¶g=Ym"m{}=Ym m{h۳B=Ym"m{q۳cYm n{a۳F۞Eg=m"m{a MyqʳS5|폕=mϢ۞oBJ ~aҶg=m"l{h۳H۞A,Ҷg=Ym"m{a3mϢ=Ym"m{i3۞E,Ҷg=Ym"l{g=Ym n{i۳H۞A,¶g=m"m{i3۞E,Ҷg=Ym"m{q۳۞5,Ҷg=Ym"m{q۳H۞Eg~F۞Em"m{i3۞E,Ҷg:y۳H۞Eg=z3۞E,Ҷg=Ym"l{p۳H۞E,Ҷg=Ym n{i۳H۞E Ҷg=ye۳7۞ӹ՞\{^h=sk/՞\{r9ȵ煖skA=/Ԟ\{r9ȵ\{q9ȵ煖skA=ǸR{r9ȵ煖skA=R{r9ȵ מZjA=R{r9מ_h=X{3gk ֞\{a9ȵgk ֞A= b3 מA=X{r3gkA=X{3gk ՞c\{ by bĿ3gkA=>o>A=_3gk ֞\{ b9ȵgj֞A==X{ b9ȵgm3 מA=X{r3gk -gk ֞A= bsk ֞A=X{r3 מA=X{3gkA=X{ b9ȵgk ֞A=ask ֞A=X{^h=X{3gk ֞\{ b9ȵgk ֞A= bsk ֞A=X{r3gkA=X{3gk ֞\{ by b3 ֞1=X{rQKsk ֞A=X{r3 מA=X{`3 ֞1rsk ֞A= b3煖3gk ֞\{ b9ȵgk ֞A= Rsk֞A=X{r3 מA=q֞\{ bsk ֞A= b3He3Hg kA=X{ b9ȵgk ֞X{ư zu= bskϠqZj ֞\{ask ֞A= b3 מA=cP{)|ã[3 ԞB 7sk ֞A=X{r3gkA=X{3gk ՞c\{\{r3gkA=X{3gk ՞Yj ֞A=X{r3 מA=cX{3gkA=X{ b9ȵgk ֞\{x~=sk ֞A=X{r3HמA֞A=/ԞA=X{r3gkA=X{3gп֥3gkA=T{ư R9Ƶgk ֞A= bsk ֞A=X{b3jϠ_՞ {^ƭYR˸C˸2˸#˸2Kyqe2;/2;΋8/qyfqe2n:/,Eet^=es~漌c˸弌S/qyw_f8/28/fK8ǰÀ270zs ˸ts8ns]Vq9&cXl^ck^ƵƚcjaycjaygcXia9FEha9Y13/cg^mcXf^afcʼ~1l20"22ǰ21(s S˸s ;8s[%2N0ǰ2/0r /c^ay9e]av9FE]as9qp9斗qm9cZ^ƥcY^ƙVcYacy'cXXa`9}eWa]9qeVaZ9e_f*0ê2*ǰär 8Þr s˸Ør [1L)/r C1(/r +1(ǰ1,(0~2'ǰx2n'0rr ˸lr /DcLa29eLa/9e\KX_T2.%0Nr 3˸Hr 8Br 1#/G0|1ǰz2n0y2ǰwqj/Ďc:axc:a8e\9a8e8a8ϓ `xcX7axc>f)0l1j"n0iâ2ǰgÜq k8fqS/!a,1+_!1ǰa1,0`~2Ǩ^xq 8]rq ˸[lq 1ۣ4c?^./`q {1ǰVc1l0UK1 ǰSL,Fc(axc(axcT'a8FmE&a8ae%a8UFq8Iq8F=cX#^1c"axc!QxWc#l0A2K8q~8Ƈc^c^fc\˸9p 88ps1 /p [1L ǰ4C1 03+1 ǰ12, 00þf .-/|7q9}a/q qP-2jeeNhK4jjtZCƆB [NpC-q$Bmqu!NwK q锇tC]j{(wC\:.?ԥt D\: PD! BJ(w[ҷ(ǵEԥƈ#R{D]JC)uI.I$JȏKKu]"/%L䥔BMW\ĉB'[>( P$oԷFQ_x#E]jKyi:EjC-y)".V(">Ԋ\Q+REBM>_sZo/b~UEnnE^..kNKy?Z'`ԥԄ?Z'bԥV1 5d$?Z'ejH?Zf׏GKgĥ4=G$ԦQ5k}N֨Cy?ZlԥԶ?ZnԥD:P G?uG} 9R+G^ou#џ:#/}oTcGjC:.5xQyǝ著R=RG]jHߨS> 5}$Q'~Է.5Ǐ7K Z@@s}NC y龿Qԥ豿QԥgbH]j K:=$mNIQԷQ$/=7dtH^zo)#qI#um$=7ԑ<uID74IR+IFNR$mN*oA[I]j,K%y).ԡD:ɤԥFܟMRI'WڟN ?$/=N'jIsߦ`p̯lt%sNwMK^JyKI/u.%bRR`kNKm0y鱿X0eab o)&/=ĘB1/1uA.dġeЩ2y2q 3ue&/'봙D:u&dg'DShcNkK4y鹿Nԥ&.r^tM:z>ԀtNjKgYOũkƩK8y鹿Nԥ7EZ e/4Y N`iH#A\, fv04%"Mai 3Hc5f08YE"MbqHEZ,, biH˘E 6f1y"ci ssE f5k4YM͘F5YY jiXH˚E f5k95mA=_E"MjiS3EZ,Ҭfv58YeMki[3EZ,Ҽf54Y"Llpchƕ ligHCEZ f64ĵ"miocY"mnit3E,f7Y"lop|HE f8Y npiH+A,g8)"mqiHkA,g9cY&gF9yHE 0g94Ym si1,@gѿYVOtqH#EZ Lgv:k4YNuiHcEZ zjH{E bg&;Y vhHZ;nA;/ĝwr9qA;9BK9q ǝZA;9B;8BK9q砇~y -q ǝw^h;9s -q ǝwry%s -q ǝwq3qgA;w1 b9qgƝw1 bĸs ƝA;wrĸ3q ǝA;w13qgA;w1 R9qg ƝZ ƝA qA;w13Cĸ3q砿;w1 b9qg Ɲw)aĸs ƝA;9 w13qgA;w1 by% bĸ3q ǝA;wqĸ3qgA;w13qg Ɲw1 b9qg ƝA;9 bĸ3q Ɲ1;wrĸ3qgF-qg Ɲw1 bĸs ƝA;9 bĸ3q ǝA;wqĸ3qgA;w1 b9qg Ɲw1 bĸs ƝA;/ĝA;ĝw0 b9qgF-qgA;w1 b9qg Ɲw1 bĸs ƝA;1OƝw1 b9qg ƝA;/ĝA;w13qgA;w1 b9qgƝw0 bĸs ƝA;9 b3q ǝA;w13qgA;w1 Ry% Røs ƝA;wrĸ3q Ɲ1;p]A;w13c3q ǝA;cw)3qgA;w1 b9qgƝrsߦ% s~ ƝA;9 bĸ3q ǝA;cw13qgA;w1 R9qgq ǝA;w13qgA;w1 Ry% bĸ3q ǝA;wr3qgdw1 b9qg ƝA;9 bĸs ŝ1;wrĸ3qgA;w)3h?ø3q煖3qgA;w1 b9qg ŝcw1 ?˺ĝw1 b9qgƝA;8 bĸ3q ǝA;wrĸ3qgA;cw1B[tk;wrĸ3qg -qg ƝA;9 bĸs ƝA;wbø3q ǝA;w03qgA;w1 b9qg ƝA;9 bĸs ƝA;cw^h;w) bYHqg ƝE;kw1,RYHqg"ŝE;w1,RY3qg"ŝE;w),RĸHqg"ĝ1;w)丳HqgB\3qg"ŝA;>o>E;w]_Hqg ƝE;w1,BYHqg"ŝE;wGqg ƝE;w1,RYHq ǝE;w) bYqg "ŝE;w1,RY3qg"ŝE;w),RĸHqg"ŝA;w),RBYHqg"ŝE;>7qg"ŝA;w),RĸHqg ƝE;w) bYqg "ŝE;w1,RYHqg"ŝE;w),RY3qg"ŝw),RY3Hqg"ŝA;>7qg ƝE;w) bYHqg"ŝE;w1,RY3Hqgmw( bYHqg"ŝE;wrYHqg ƝE;w1,RYHqg"ĝ5;w(,RY3qg"ŝA;w!QĸHqg"ŝA/ŝE;w1,RYqǝE;kw1,RYHqg"ŝE;w(,zu;w),Rĸcw) bYFqgƝE;w1,RYHqg"ĝ5;1o΢qA8;w1,RYHqg"ĝ5;w1,RY3qg"ŝE;cww1,RYHqg"ŝE;w),RYs"ŝE;w1,RY3qgŝE;cw),RĸHqg"ŝA;w) bYFqg ƝE;w) \/1,Bøh?Hq ǝE;w1,RYHqg"ŝE;cw),?3qg"ŝA;w(,BøHqg"ŝA;w) bYHqg ŝ5;w^h;nw~ğ5  NܩK;uqKNƝ?[ܩK;qĝtNƝ@'j)ԸSq';qĝ:ԸN)Ը׸SwЉ;qĝԸN܉K'ԥƝB;q'ĥwRN]j܉KƝtNƝ@'j)Sqoq'Q2kܩK;y)q'/%ԥƝwPN]jISwRN^JK;w/D;w%Էq'/%jIt_ߨoqƝԸwĝ:ԸSwRN\:q'QN|܉;y)q.5ԥƝD;w}̿7[ܩoA[ܙ_ǣĝ"w 55hSwcNܩK;uq'sNܩK;y?Z'jIgN)ԸcNK/N܉K'$z։;uq.5hSwcNܩK;uq'sNܩK;uNƝDGĝ4ԥƝtߨwRN?uN^ߨƝ:Ը^uN]jK;ysN܉;q'/%ԥƝԸ豿Q'jIgNܩoAN]jKoԯ^uN}\N^zoԉ;uq'/7ĝԸSw=7ĝԸSwkNItߨw%jܩoAN^zoԉ;qĝߨwwPNzoԉ;uq'/7ĝB;oԉ;7ԥƝD:qPNFS߂ƝԸSwۥĝ:Ը>Q'ԡƝԸuN]jItD^uN|''KuNDSqƝ؟wRN]JCjܩkC:q.5ԥƝSwRN;i^uN}ݍ;y?P'z}ԉ;7ԥƝԸոN܉C;iuN]jK:q.5ԥƝƝ4}S_tNiIgN)ԸS_xN^Ӊ;uq.%ǏCl؉;tN]jܩK;y?N'ԥƝDĝ@;intN|NܩK;;+wsNܩMN^։;uq.%bSָSwkNܩK;y鱿X;eww 5oq'/=ĝB;/։;uq.5d5ġwЉ;y;q;uq'/'ĝD:q'dw'ĝԸSwcNܩkܩK;y鹿N'ԥĝq'.^tN:>ĝԸtNjKgYOܩkܩK;y鹿N'ԥĝPrg;c9˝A\ rg;y3˝A\.w_Nr /wq3˝?Nrg;y3H˝1\ r/wq3˝ .wqs; y3涿Mrg;X̯rg;y3˝A\ r /wi3˝A\ .wqs; -wrg˝Πb-˝ .wrg;,˝A\ rg;y3˝A\ -wp3H˝c .wrg;A^ rg;y3H˝1\ r /wq3˝A\ .wis;3\ _e3˝A\ .wq3˝ -wrg;ϲ.˝ .wrg;c1^ rg;9˝A\ r /wq3˝A\.wq m˝AYONKĸs ƝA;w^h;w1 b9qg Ɲw1 bĸsƝA;9 b3q ǝA;wrĸ3qgA;w1 b9qg Ɲw1 RøBKYHqg"ŝE;w1,BY3qg"ŝE;w),RY3qg"ŝA;w),RĸHqg ƝE;w!aYHq ǝE;"ŝA;w) bY)RY3*ŝE;>Gqg"ŝA;w(,RĸHqg ƝErY3qg"ŝA;w),R9qg"ŝE;w),BøHqg"ŝA;w) bYHqg ƝE;w1,o"ŝA;w),RFqg ƝE;w)丳Hqg ƝE;w) bYHqg"ŝE;w1,RY3qg"ŝE;w),RYQ;w) bYHqg ƝE;wrYHqg ŝ5;w1,(ǝE;w),RY3qg"ŝA;w),RĸHqg ŝ5bY3qg"ŝA;n帳Hq ǝE;w) bYHqg"ŝE;w1,BY3Hqg"ŝE;w),RĸHqgŝA;w),RĸHqg ƝE;w}"ĝ5;w),RY3qg"ŝA;kw ŝA;w) bY?N;w1,BYqg "ŝE;w),RY3qgŝwqg ĝM_3qg"ŝE;w!QY3qg"ŝA;w),BøhƸ3qg"ŝE;w),Rĸ|Hqg1;w),RĸHqg ƝE;kw!aYHqg"ŝE;w1,RY3qgŝE;w),RY3qg"ĝ1;3;wrYHqg"ŝE;w1,RY3qg΢񳬎;w),Rĸqg"ĝ1;w),RĸHqg ƝE;w) RYHq煖Wqoq ǝZA;9 mq ǝwry%s -q ǝwry!ǝcwry%s1;/ĝwry%tc9q ǝZA;9BK9q ǝZA;1 mqg Ɲw1 bĸs ŝ1;9 bĸ3q ǝA;w13qgA;w1 b9qg Ɲw1 bs ƝA;/ĝA; Ɲw1 b9qgЇ'qgA;-oh~ Ɲw1 b9qgƝA;9 bĸsΠh-qgA;w13qg ƝZ ƝA;wrĸ3HqǝA;w13qgA;w1 b9qg Ɲw_A;wrĸ3qgA;cw13qg ƝZ ƝA;9 bĸ3q ǝA;wrĸ3qgA;w)3qg Ɲw1 bĸs ƝA;9 b1=q ǝA;w^h;w1 b9qg Ɲw}ow13qg Ɲw1 b9qg ƝA;9 bĸsΘD9a9qg Ɲw'j;w^h;w1 b9qg Ɲw1 bĸs ŝ1;1aĸ3q ǝA;wrĸ3Hqg A;w1 b9qg Ɲw1 b2K3q ǝA;w13qgA;cwƝw1 b9qg8-qgA;w0 R9qg Ɲw1 zwr3qwi;wrqg~%A;w1 b9qgƝA;9 bĸs ƝA;wqys9qg ƝA;9 bĸs ƝA;w^f;w1 b9qg Ɲw)as ƝA;9 bĸ3q ǝA;wr3qgA;w1 b9qg ŝcwgw1w1 b9qgΠ:-q ǝA;wqĸ3_,wrĸ3q ǝA;cw)3qg Ɲw1 b9qg ƝA;1aĸ mqgğ/Ӵ3);9a'ĝfo|:auoM'4|={srN֜09ar7|攜8Ӑq4|Y8q3|$ӂpsMi zgxnNMi 79<06al4|[Vl-ؔoY5q$ԝTwRjLBMi;4eRiiNMi;)4u'&LLuV&u&LL7ԝ0 3e۫-*webܙ$gZdLLI1eRccNZLi;-1eb´Ôoη6`/Jß3tK&_k}N|;i/u>C%4ĝv2:%4ԝ ť̟:%LsK:~CĝfRw^3tKib;:%ĝ2:q%y)+aVYUުwU}}uNR;-*e)us}uZSLcJyI)q%$ԝ9:$ĝ6ӄR汾:'i?)g}uN={Ii;;ow^sI|VIynΩ&qѤW$bwLgGs}uN;m#u羾:i)g}uNU$4I"aZDW7ĝ֐Rw?^_$ę29$4ĝV\@NHG7Z?O;ow>G紏29#LG|u>:zĝFQgQgsrGi;u'#4uĝ2:'d[9s}rNQ>9'pĝӼQw|{NLF䜰w5c}rNՈ;qM<'Em}qgۜGZ3Y24eܒQwss:Fiƈ;u?ˋtFܜw/NEy͉q̟9{pQ䶾6'[|;?"4ZI]8>AXo'䊸Zw+c}Nj; u絾A'SĝVXߠ6 Me?^ a' "@ԝޜw{ۙ?ke)us}oNw;?۝ޜPf=XߛSzOp u絾76i us}oNi; u繽7'3ęVi YM q<􅸓Pg{Ӹmϟ<愅+ĝfZߛc}oNQ; q=<[Mη;>x)HKA\,Rd"9KEZ,Rd"Y"-Eq)HKEZ,Rd"kY .Ei)K5Z Rd"ĥ"-Ei)HKA\,Rd">ĥ"-Ei)2KEZ,Rd"y) ,E"-Eȃy"ycYȃy"Rd"RAX<KEZ<Ka)HKa) ,E"-EȃYȃyPD^zYȃy"y"] ,Ei) ,E"-EAX<KEZq.5ĝSwRNJܩC;uq'QN~\N]jܩK;y)q'/}/0 jI %jIS߂ƝSq'}}ŝwRN^JKwPNjK;qĝD;q'ĝԸSw%jI1Ct_ߨoq;uq^%JӟuNNwkNܩK;y?Z'ԥƝԸ?Z'ԥƝw 5$?Z'jI?Z'׏GK'ĥw=GĝԸSwk}NܩC;y?Z'ԥƝԸ?Z'ԥƝD:qPN?uN} wRN^oԉ;uq'џ:q'/}oTNjC:q.5ĝQ'ǝwRN]:q'FFS߂ƝԸ?ި_/7ĝƝ\ߨwPN^oԉ;uq.5$zoԉ;uq.5F趿Q'$ߨw[иuN\:q'/=7ĝĝ:ԸuN]jK:qPN?uN};uq'}N)Ը趿Q'Էq.5ԥƝFv)q5$zOԉ;uq.5DSwN'jIsߦwpN]jImzwW6qƝSwRNz/։;i;uq'/ĝԸոSq'ǹqPNwcN)ԸbSwRN^OVN:q'S׸SwkNIt[w}O֫q'}NܩK;uq'/=NS׸SwsNܩK;yu럭w_w:S^?Ku:q'~汿N'}N\:q'/ĝDu:q'/}Ӊ;uq'/=ĝ:ԸϲS׸SwsNܩK;y辿N;ewI_cNܩo@N]jKu:q>q'/=ĝSws}ŝ/};KHrg;y3˝A\ r煖 .wq3˝ .wrg;A\rg;y3˝AZr /wq3˝ .wqs; .wrg;9˝A\ rg ;/,wiH˝A\,rg;",wh3˝EZ,rg;Y"-w%rg;"-wiH˝A\,rg;Y"-wa3˝EZ,r /wiH"-wqH˝EZ rg?^EZ,rg;/w~C:+@"-wi3˝EXrg;Y"-wq?Z^,rg;Y .wiH˝EZ"-wiH˝A\,rg;cY"-wi3˝EZ,rg;Y"-wqH˝EZ rg;Y .wiH˝EZ rg;"-w}풖;yH˝EZ rg;Y .wiH˝A\,rg;"-wa3˝EZ,rg;Y"-wi3˝EZ,rg;Y"-wqH˝EZ"-wiH˝AZrg;YQ^,rg;Y"-wqH˝EZ rg;Y .wiH˝AZO;k"-wi3˝EZ,rg;yH˝EZ,rg;Y .wiH˝EZ rg;k-wiH˝A\,rg;Y",wh3˝EZ,rg@yH˝EZ rg;1^,rg;Y"-wi3˝EZ,rg;kYv9B˝A\,rg;Y?N^,rg;Y",wpH˝EZ rg;Y .waF˝Ys&/wi3˝EZ,zyF:Z,rg;Y-wi3˝EZ,rg;Y",wphC .wiH˝EZ rg;"-wi˝cY"-wi3˝EZ,rg;Y؟,.wpH˝EZ rg;Y .wiH˝A\,rg;"-wiH˝A\,rg;cYrg;yH˝EZ rg;Y .wi˝1\,rgѿYV/wqH˝EZ rg;kY.wiH˝EZ rg;"-wiH˝AZrg;/,wf? Ɲw1 bĸBKĸ3qgA;w13qg Ɲw0 b9qg ŝ1;9 bĸs ƝA;wrĸ3qgA;w13qgƝZ"ŝE;w),RY3qgŝA;w),RĸHqg"ŝA;w) bYE ƝE;w1,RYqg "ŝE;9,RY) bYHqg΢O"ŝA;wU_3qg"ŝA;w(,RĸHqg ƝErY3qg"ŝA;w),R9qg"ŝE;w),BøHqg"ŝA;w) bYHqg ƝE;w1,RYHqg"ŝE;w)8帮&iwx tcSᬒk" L69x5;w1,RYHq ǝE;w1,RYHqg"ŝE;w),RY3qg"ĝ1;w),RĸHqg"ŝA;w) bYHqg ƝE;wrYHqg ŝ5;w),z(ǝE;w),RY3qg"ŝA;w),RĸHqg ŝ5bY3qg"ŝA;w),R9qg"ŝE;w),RĸHqg"ŝA;w( RYHqg ƝE;w1,RYFqg"ŝE;w1,RY3qg΢@1㸳qg ƝE;w) bYHqgŝE?\W3qg"ŝA;qg ƝE;kw!aYHqg"ŝE;w1,BYsΚ69,RĸHqgΠwW*,RY3qgŝE;w),RĸHqg"ĝ1;?;w),RY3qg"ŝA;w),B9qg"ŝE;w),Rĸqg"ĝ1;w) bYHqg ƝE;w1,BYHqg"ŝE;w1,RY3qg~FqgA;w) bYHqg ƝE;w0,RY/~qg"ŝE;w!QY3qg"ŝE;w),RĸHqg"ŝA;kw)w=S׿ŝ5m^tЉ;qĝԸSw_w 5oq.5ĥw҉;w5j)ԸSq';qĝ:ԸN)Ը׸SwЉ;qĝԸN܉K'ԥƝB;q'ĥwRN]j܉K'ĥw 5:qPNĝ2;KN_5ԥƝwRN]JC;uq.5$JɏKܩK;uq'/%ĝB;aĝB;w[иw 5$XߨoqƝԸwĝ:ԸSwRN\:q'QN|܉;y)q.5ԥƝD;b7w[иSwR^-̯wwhSwsNܩK;uq'kNܩK;y?Z'jI?Z'jI?Z'/N܉K'$z։;uq.5:q5hSwRNhSw=GĝB;Gĝ4ԥƝqh}C?ި.5$zߨwF5ԡƝĝwkN)ԸcNܩK;uq'/=q'wҼĝԸuN]jܩK;y?P;i4qƝ:Ӹ}N)ԸS_xN^wRN]JCӯw}Ӊ;uq.58SwӉ;w<ĝSw%$zoӉ;ŝouN}_wRN]JC:q>q.5:q.5b5iI!l)ԸSƝ_w 5$z_wRN]jKոN܉C'/'5ԥƝ?Y'$zO։;'q'dSwRN^zO։;q;uq'/ĝ>~Nk$ŝDtN^_wϟg:h?_w>q'.>ĝDu:q'/}Ӊ;uq'/ĝ:ԸϲS׸SwkNܩK;ycw4$:S߀ƝԸ>ĝƝ_wRNjCuw_wr闸us;/,wr /wr-wr /wr煖A^ ys;ys;/1^ -˝\1^в9˝yes;ys;/,wr /wr煖A^ -˝9˝cm˝A\ r /wq3˝A\ -wps; .wrg;A^ rg;y3˝A\ r /wq3˝ .wis; -˝A\ (˝ .wz_;W;9˝A\ o˝U\ .wqs; .wrg;9˝AZ;9˝A\ r /wq3˝A\в .wqs;1^ rg;9˝A\ r /w=GkY r /wq3˝ .wqs; .wrg ;9˝A\ rg;/,wq3˝ .wqs;A^ rg;9˝A\ r/wq3˝A\ .w=7jY .wqs; .wrg;ye3˝A\ r .wp3˝޸Qrg;y3˝A\ r /wq3˝ .wqs;A\yO;c9˝A\ r /wq3˝A\в .wqs;A^ rg;9˝AZr .w<4 .wrg;9˝A\ rg ;y3˝A\ r /wq3˝ .wi2rg;c9˝A\ rg;y3˝A\.w/'Dps;A^ ze3˝Θf9˝A\ r /wq3˝A\ -wpB^yoӲA^ rg;a+@+A^ rg ;9˝A\ r /wq3˝AZΠ;y3豿Xrg;y3˝A\ .wq3H˝Y; .wrg;9˝AZrg;x3˝A\ .wq3˝ .wrg;cA^ rg;9˝A\ r/wg,w^hY rg;y3˝A\ r /wq3H˝cΠr /wq3˝.wis; .wrg;9˝A\ rg;q3˝A\ΠY;*ynqgA;w1 by% bĸ3q ǝA;wrĸ3qgA;cw13qgƝw1 b9qg ƝA;9 bĸ3q ǝA;wrĸ3Hqg -qg"ŝA;w),Rĸqg ƝE;w) bYHqg ƝE;w1,RYHqg"ŝE;w),RY3qg"ŝw),_w1,RY3qgͧHqg ƝE;%RĸHqg ƝE;kw) bYHqg΢h9,RĸHqg ƝE;w)丳Hqg"ŝA;w!aYHqg ƝE;w1,RYHqg"ŝE;w),RY3qg"ŝE;w(,RĸHqg"ŝw),RĸHqg"ŝA;w) z(,RYHqg"ŝE;cw),RY3qg΢F9 bYHqg"ŝE;w1,RYs"ŝE;w)QY3qgF9,RĸHqg"ŝA;w) bYHqg ƝE;w)yOŝA;w) bYHqgA;w),RĸHqg ƝE;w) bYFqgŝE;w1,RY3qg"ĝ5;w),RY3qg"ŝA;w),B9qgŝA;w),RĸHqgΠŝE?\W3qg"ŝA;qg ƝE;kw!aYHqg"ŝE;w1,BYsΚ69,RĸHqg ƝE9TY3qgŝE;w),RĸHqg"ĝ1;?;w),RY3qg"ŝA;w),B9qg"ŝE;w),Rĸqg"ĝ1;w) bYHqg ƝE;w1,BYHqg"ŝE;w1,RY3qg~FqgA;w) bYHqg ƝE;w<w),?3qg"ŝA;w(,BøHqg"ŝA;w) bYHqg ŝ5;w^h;)Ɲw^h;9s?h;9s -q ǝw^h;9s 9s -q ǝwqy%s -q ǝwry%sA;/ĝwry%s1;- bĸs ƝA;wr3q砿_Ow1 b9qg ƝA;9 bĸs ƝA;wrĸ3q ǝA;w)3qg -qg 8q ǝA;wr bĸs ƝAq7trVίrĸ3q ǝA;cw13qgA;ĝA;9 bĸs ƝA;w^h;w1 b9qg ŝcw1 bĸs ƝA;9 bĸ3q ǝA;wrĸ3qgA;w1 b9qg Ɲw1 bĸBKĸ3q ǝA;w13qgAƝA;w13qg1;w1 b9qg ƝA;9 bĸsΠF-qgA;w1w1 bĸsƝA;9 zߨ% b9qg ƝA;9 bĸs ƝA;wrĸ3q Ɲ1røs ƝA;9 bĸ3q煖3qg Ɲw1 b9qg ƝA;9 RøsƝA;wrĸ3q ǝA;w03qg Ɲw1 b9qg ƝA;/ĝA;cwr% b9qg Ɲ;cwp]A;w13m3q ǝA;cw)3qgA;w1 b9qgƝrߦ% b9qg Ɲw3qgA;w0 b9qg Ɲw1 bsΠA;w1 b9qg Ɲw1 b2Kĸ3qgA;w13Hqg ŝcw1 b9qg ƝA;9 bĸs ŝ1;wrĸ3qgA;w)3h?ø3q煖3qgA;ĝA;9 bs ƝAgYs ƝA;9 Rø3HqǝA;w13qgA;w1 b9qg Ɲw=S^v>}}:#ϗt8A֜7rqފF7༽|i7npVڼ'ټ5oEc[RwLi4oO4мq[4Seޞhyww7Ny{-ݍb8&ݧ)/oo4 .nV4,oE [м7-[4ўFb))oo4D'oo<?o iky*N}x{v7>TDs8V7ދTF{\ފ}y*NJxmGx{8퍶}yN5xky ޞh,xsyN&x{7ᤁwroo^<ᄀx_^nx4yA޽x_^~no4»p[^'h7Zhv< '>^I8ٝhpvˋpRno42)kyN[v6,q"ܥgId_\b8퇴!рNtFh1v j(v+ZNx.ĉnE˰{ FkCĉNkin?V_7>^^g{<ѴF8E4纽іkyNu{# o?O|şVn݋M8M8ϟ?W~Nu/M8mWy¬ʺ ǺM8%M8 X7^~Nzu{gNqu)ͭnoZބSYHbucyW݂UOS<7UT7R\ބQ~J M8퍄S'ZMݟxMKKr㟱nY  /q /KxA\»в% .q o%A^ ^7Kx1\  /q /HKx1\% .q o% . ^%A^ ^y /KxAZ‹ޅ%"-i /KxEZ+^W%-q HKxEZ+^W%"-q HKxEZ ^W% .i HKxA\+z`HKxEX‹^7KxEZ+=HKxA\+^W HKxEZ ^W򫸄W%"-q Kx5Z+^W% .=GKxEZ ^%"-i HKxW%"-i /KxEZ+^ W%"-q HKxEZ z^W% .i HKxA\+^%"-i HKxAZ«^W%"-i oW% .i HKxEZ ^%"-i HKxA\+^bW%"-i /KxEZ+^W%"-q 豿Q^+^W%A^+^%-i /KxEo%"-q HKxEZ+^W% .i HKxEZ ^%Dq FKxA\+^W%"-i oW%"-q HKxEZ ^W% .a FKxAX«^%"-i /KxEZ+^W%"-i /KxEZ+^W%",^j%@y HKxA\+^W%yW%"-q mW% .a FKxEX‹^%"-i HKxA\+^q 汿M^+^W% ./}Cw7bW%-i /KxEZ+^W%",p hC% .i HKxEZ ^%"-i KxcW%"-i /KxEZ+^W%",p HKxEZ z^W% .i HKxA\+^%"-i HKxA\+^bW^y HKxEZ ^W% .i Kx1\+^ѿYV/q HKxEZ ^jW%.i HKxEZ ^%"-i HKxAZ«^.,=xq ǝZA;9A;9BK9q ǝZA;9B;8B;9ĸs -q ǝw^h;9s -q ǝwry%s -q ǝwqmqg Ɲw1 bĸs ŝ1;9 bĸ3q ǝA;w13qgA;w1 b9qg Ɲw1 bs ƝA;/ĝA; Ɲw1 b9qgЛ'qgA;w1 oq*ǝA;wr3qgA;w13?ZKĸs ƝA;9 bĸ3q煖3qg Ɲw1 R9qg ƝA;9 bĸs; ƝA;wrĸ3q ǝA;w13qg Ɲw0 b9qg ƝA;/ĝA;wrĸ3qgA;w13qg Ɲw1 R9qg ƝA;9 bĸ3q ǝA;wrĸ3qgA;w1w1 bĸsƝA;9 zߨ% b9qg ƝA;9 bĸsΠF-qgA;w1ĸ3?Q;cwrĸ3q ǝA;w1w1 bĸs ƝA;9 bĸ3q ǝA;cwzWø3qgA;w13qgƝw1 bĸs ƝA;9 bĸ3Hqe3Hqg A;w1 b9qg Ɲw0 Ɲw1 b9qg8-qgA;w0 R9qg Ɲw=i;wr3qw7q5FSwFSq'FS_xN]jIQ'jIߨw[иSwRN^zx~Sw='ĝ:ԸSwkNܩK;>~ĝwkN)ԸcNܩK;uq'/=q'wҼĝԸuN]jܩK;y?P;i4qƝ:Ӹ}tN};ycNܩK;u)q'=N'jIߦwpN]jI赿M'޸>nߦ32q7uN}ZN]jKuN]jKj)ӸhCظSq~;y鹿X'jIX'ԥƝԸ>'q'NK_ NܩkܩK;ysNIXw}OgN:q.5ԥƝܟwwRN^zӉ;u)q'}x~=I|;ĝN'ԥϟ?u:q'~湿N'}N\:q'/}Ӊ;tN^_wRN^zӉ;uq'/e=q>q.5:Sw:5iI'YEu:q;uq'/}Ӊ;q;y鹿N'ԥĝ:Ը^--?Ώ?'3q ǝA;w1w1 bĸs ƝA;9 bĸ3q Ɲ1;wrĸ3Hqg A;w13qg Ɲw1 bĸs ƝA;9 b3q煖Hqg ƝE;w) bYFqg"ŝE;w1,RY¿) bYHqg"ŝE;w1,RY3qg"ŝE;cw),R9qg"Hqg"ŝE;w|w) bYHqg}yZ_ *ŝE;w!QY3qg"ŝA;帳Hqg"ŝE;w),RYs"ŝE;w1,RY3qg"ŝE;w),RĸHqg"ŝA;w) bYHqg ƝE;^3Hqg"ŝA;w),R9qg"ŝA;w),RĸHqg ƝE;w) bYqġ"ŝE;w1,RYHqg"ŝE;w),RY3qg"ŝw),RY3Hqg"ŝA;7qg ƝE;w) bYHqgЇ"ŝE;w1,RY3Hqgcw( bYHqg"ŝE;wrYHqg ƝE;w1,RYHqg"ĝ5;w(,RY3qg"ŝA;w!QĸHqgkw1,RY3qg"ŝE;8,BY3qg"ŝE;w),RFqgU( bYHqgЇ΢qrY3qgŝE;cw),RĸHqg"ŝA;w(ĸ汿M;w1,RY3qg΢8o JƝE;kw) bYHqgЇ"ŝE;w0,Z2 bYHqg ƝE;w1,RYqǝE;w) bYHqg"ĝ5;w0,RY3qg"ŝE;w),Rĸqg"ŝA;w),RĸHqgƝEŝE;9,RY3qg"ŝE;w),BøHqgѿYVǝA;w) PYFqgƝE;w) bYHqg"ŝE;w)QYBKYOq그QРƝ͋:q'.SwRKNƝ-ԥƝtN\:qPNw 5j)Ը߂Ɲ8tNj܉K'j܉kܩC;qĝtN]j܉K'ĥwRNƝw҉;uq.5ĥw҉;wSqPNƝ߁oqoq'wRN^JK;uq.%ĝ:ԸSw%%ԥƝԸwRNƝD0QNƝD;-hK;w}oԷS_xN]jK;yiNjܩC;y)q'.(q'>ĝSwRNĝB;|>7[ܩoAN]jK;ykNϏ-̯wwSwsNܩK;uq'kNܩK;y?Z'jI?Z'jI?Z'/N܉K'$z։;uq.5:q5hSwRNhSw=GĝB;Gĝ4ԥƝ?Z'ԥƝDuN^ߨƝ:Ը>7ĝԸwFwN^JܩK;uq'sN)Ը}NܩoAN]jKoԯ>7ĝƝZߨwPN^ߨwRN]jIߨwRN]jKuNFkNܩoAN^zoԉ;qĝߨwwPNzoԉ;uq'/}oԉ;woԉ;7ԥƝDuNoԉ;uN]jܩK;yRNjI\wPN]jK:q.5$D>'ĝOKOԯ'ĝDuNƝwsNܩK;u)q'q>q'=ĝԸSwRN]jܩK;&wnK:qPN:q.5ԥƝƝ8tNjIwRN^zԉ;uq.5@5yĝwLNq:qĝ?N'ԥƝ?_}=`'$wRN]jKq:q.5$z_w5yoӉ; 8q.5$JIߦw oKt^;W6ĝ:w}/։;uq'/}/։;u㱿X'$Z_ww 5oq'/=ĝB;ĝԸSwd5ġwЉ;y;q;uq'/}O։;uNlI?Y'ԥƝԸuN}\N]jK'Ɲ>~Nk$ŝDtN^_wϟg:h?_w>q'.>ĝDu:q'/}Ӊ;uq'/ĝ:ԸϲS׸SwkNܩK;ycw4$:S߀ƝԸ>ĝƝ_wRNjCuw_wr闸]y;9wr9q ǝwr9q ǝZA;9wr9q ǝr9q ǝZA;1BK9q ǝZA;9BK9q ǝw^h;9BK9q ƝcwA[ĸ3q ǝA;w13Hqg A;w1 b9qg ƝA;9 bĸsΠ: ƝA;9 bĸs ƝA;wqĸ3q煖3qgBĸs ƝA;9 zӿ1 b9qg ƝA;Ǹ3qgA;w0 b9qg Ɲw=Gk;wrĸ3q ǝA;w1w1 bĸs ƝA;8 bĸ3q ǝA;wrĸ3qgA;w13qg Ɲw1 bĸsƝA;9 bĸ3q煖3qgA;w1 b9qg Ɲw1 bĸs ƝAZ ƝA;wrĸ3qgA;w13qg Ɲw1 by% bĸ3q Ɲ1;^ĝAoĝA;9 bĸ3q ǝA;wrĸ3qgA;w1ĸ3?Q;cwrĸ3q ǝA;w1w1 bĸs ƝA;9 bĸ3q ǝA;cwbø3qgA;w13qgƝw1 bĸs ƝA;9 zw)w)a9qg ƝA;9 bĸsƝA?\s ƝAqZΠqZ Ɲw)as ƝA;9 bĸ3q ǝA;cw^qgc3q ǝA;wrĸ3qg;W: Rø3q ǝA;wrĸ3qg1;?;9 bĸ3q ǝA;wrĸ3qg,qg ƝA;9 bĸs ŝ1;wqĸ3q ǝA;w13qgA;w0 b9qgΠ:-q ǝA;wqaĸBKĸ3q ǝA;w13qg1;we]A;w13Hqg ŝcw1 bĸs ƝA;9 bĸ3q Ɲ1;wA[/q_3襸s ƝA;w^h;w1 b9qg Ɲw1 bĸsƝA;9 b3q ǝA;wrĸ3qgA;w1 b9qg Ɲw1 RøBKYHqg"ŝE;w1,BY3qg"ŝE;w),RY3qg"ŝA;w),RĸHqg ƝE;w!aYHq ǝE;"ŝA;w>A;o>E;w1,RYHqg;w) bYFqg ƝE;w1,z쏖"ŝA;w) bYHqgA;w),RĸHqgƝE;w) bYHqg"ŝE;w1,RY3詸Hqg"ŝA;w),RFqg ƝE;w)丳Hqg ƝE;w) bYHqg"ŝE;w1,RYZ(ǝE;w) bYHqg ƝE;w1,RYHqg"ŝE;9,RYHqgŝErYQ;w1,RYHqg"ŝE;w),RY3qg"ŝA;kŸFqg"ŝE;w),RYs"ŝE;w1,RY3qg"ŝE;w!QFqg"ŝA;w) z*,RYFqg"ŝE;w1,RY3qg"ŝE;8,BY3qg"ŝE;w),RFqgU( bY?N;qg ƝE;kw!aYHqg"ŝE;w1,BYsΚ69,RĸHqg ƝE;wǝh%ŝE;w),RĸHqg"ĝ1;?;w),RY3qg"ŝA;w),B9qg"ŝE;w),Rĸqg"ĝ1;w) bYHqg ƝE;w=w!QY3qg"ŝE;w),Bøh?Hq ǝE;w1,RYHqg"ŝE;cw),?3qg"ŝA;w(,BøHqg"ŝA;w) bYHqg ŝ5;w^h;)|9ŝϿğ5 ?_N܉K'ԥƝԸҷSq};uq'.N)ԸĝB;w 5ķq'Sw҉;wwPN:q'.Swҳq'.Sw 5ǝNܩK;uq'.N)ԸĝB;w4|;/};a}\N]jK;y)q.5ԥĝQ'ԡƝԸ^uN]jI}Oԉ;񅟸^?_/}Oԉ;>'ĝB;7DSwRNz/TN}XNz/ԉ;uq.5ĝBhN:qƝw 5$wRN]jKj܉C'ġƝ4:q.5@SwRN^zTN>Mܩ/q4$zw 5޸>ĝԸStNk{NI?N'ԥƝԸtN]jI>N'jIߦwpN]jI赿M'޸>ĝԸoKN:q.5:q.5b5iI!l)ԸSƝ_w 5$z_wRN]jKոN܉C'/'5ԥƝ?Y'$zO։;'q'dSwRN^zO։;q;uq'/'ĝ>~Nk$ŝDtN^_wϟg:h?_w>q'.>ĝDu:q'/}Ӊ;uq'/ĝ:ԸϲS׸SwkNܩK;ycw4$zkw}Ӊ;uq'/}Ӊ;q;y鹿N'ԥĝ:Ը^--/qն9˝Z;ys;yږ;ys;yBr /wr煖A^A^;xs;/,wr .wr煖A^ =9˝9˝Z;ys;yBr /wr煖A^1^ .wqs; .wrg;c9˝A\ rg;y3˝A\ r /wq3˝ .wqs;A^ rg;9˝A\ r煖 .wvA^ rg;y3/A^ z 9˝A\o~4˝.wqs;A^ zֲA^ rg;y3˝A\ r煖 .wq3˝ -wrg;A^ rg;y3˝A\ r /wq3˝\ rg;9˝A\ rg;q3˝A\ .wq3˝Z;A^ rg;9˝A\ r /wq3˝A\ .wis; .wrgF-˝A\ .wqs; .wrg;ye3˝A\ r .wp3˝Qrg;y3˝A\ r /wq3˝ .wqs;A\yO;c9˝A\ zOԲ .wqBrg;A^ rg;y3˝A\ r /wi3˝ .wqs;AO.wq3H˝1\ .wq3˝ .wrg;,˝AZr /wq3˝A\ .wqs;ctA^ rg;y3m .wrg;c1^ rg;y3˝A\ r /wi3˝rgc .wrg;^۴,wq3˝A\c3R˝1\ r /wq3˝ .wis;?O.wrg;A^ rg;y3˝A\ re .wq3˝ .wrg;c1^ rg;y3˝A\ r /wq3˝.wqs; .wrg;9˝A.wqBrg;9˝A\ rg;y3˝AZ .we];y3˝AuZ; -wrgϟdq3˝ .wrg;A\rg;m3_;_~n`;wrĸ3qg -qg ƝA;9 bĸs ƝA;wbø3q ǝA;w03qgA;w1 b9qg ƝA;9 bĸs ƝA;cw^h;w) bYHqg ƝE;kw1,RYHqg"ŝE;w1,RY3qg"ŝE;w),RĸHqg"ĝ1;w)丳HqgB\3qg"ŝA;"ŝE;w),RY3qg;w1,BYHqg"ŝE;w=Gqg ƝE;^帳Hqg"ŝw),RY3qg"ĝ1;w),RĸHqg ƝE;w) bYHqg"ŝE;w1,RYHqgŝE;w),RYs"ŝE;w),RY3qg"ŝA;w),RĸHqgƝE;w) bYHqg ƝE;w1,RYHqg"ŝE;9,RYHqgŝE;wo"ŝA;w),RĸHqg ƝE;w) bYHqg qgcw( bY?Q;w),R9qg"ŝE;w),RĸHqg"ŝA;w( RYHqg ƝE;w1,RYFqg"ŝE;w1,RY3qg"ŝE;8,BY3qg"ŝE;w),RFqgU( bYHqg΢qrY3qgŝE;cw),RĸHqg"ŝA;w(ĸ汿M;w1,RY3qg"ŝE;{_Fqg ƝE;w1,RYqg ΢!Π"ŝE;w1,RY3qg"ŝE;8,RYHqg"ŝE;w!QY3qg"ŝA;w),RĸHqg ƝE;kw) bYHqg ƝE;w0,(,R9qg"ŝA;w),RĸHqgƝE;ϲ: bYHqg"ĝ5;w0,RYHqg"ŝE;w),RY3Hqg"ŝZ΢;v^iqywq٪8꼌8c2:/Yr˸漌c˸cr^%er1KygayGp^ e\p1Kyqyכo^en^qygRm^el^f+60^25ǰXs [8RsC˸Ls +14/Fs 1,40м13ǰμ1l30223ǰ,220&s̋ s {?f1ǰÿaycXbaywc3cXaay7c`a9e_o"֗q|9FcX^^vc]^rc}r ˸r {8r c1l-%r C1,/r +1,/r 1,,01+ǰ1l+0ò2+ǰì2*0ær ˸g)0 k!)ǰS1,)0ÎY21(01L(ǰÀ2'0z2'ǰtr 8nrɋhr 1L&/br 1%0k1%ǰS1,%0N2$ǰHY1L$ǰ@2#0:2#ǼΒFaycEa9UeEa9Ie\Da9=搗q 91y)XCA^VcA^ &cX@a,Y1/q 1,/q 1ǰz1j0y ! ǰw20v2Nǰtq;8sq #1l/q 1 /q 1(nCq!,/q 1ǰj1l0i ! <挗q81q8m}nq ;8cq#1j/q 1 /~q 10^1J\c.y͒-axGc,axc,a8eP+o.h_Vq S˸TPq ;8SJq #1j/Dqg΁e'a8uƉq8iq8]fcT%!K8]&cX$^Ac#^5ňC"Qxc"axgcX!a8 e a8eQ~8Ƈq{8c^fcT^1,%8p s˸6p [1L /p C1 /p +1h.eaa8eQ^8uŅq[8ic^]fcX^Q6caQxCaNj1~ ՄϿ5' ?_NOK'(ԥԤҷPQ} uY!.NX(Բ褅Bm  .ķy!P) P#C:!.P q锆P!>Ćf[?R{C\:!.P!i :ivx_oRC]j~Ky(@ԥ&Diqu.5CtQ%"QKQ1"QjD} #RzDD-I&Q%RD^,Q%PD^JK'M$J;q"/Nԥ扺>(P E)[JQ)R:E^ߨS**ob~hXQ_djEzu.X$ziu"/=GdB.G뤋DouE^hr䋸tEhQ0RF^\S1P3F^z u%.5e$z։u5#sN(Ԡ}NҨoAF]jKuF]jHꔍQmuq#}ou}#/%p䥯:#>4QZ9R3GFQ#FQ߂Ǝڑ?ި_/}o q-y鵾QyԡFQ'{ԥv蹿Q'}ԥ>7D:$FR߂6ߨSA y鹿Q'ǥԡ<ߨCRkH^ߨC 5$zߨD oK">7dB"uH} FRH]jKooGPHDBRHRI^zOԩ$u$Ǐ'W?Q~RI^zx~?Q$؟K 5buI]j4K&y赿P&a 'y蹿P'ԥxRORI]j?I4%@R_}NDI?P'$RRKJ]jJKjLCġ4:A.@RURJ^zTJ>MY/iδ$zSW 5޾>RX롯dDtBK]jiKM-y?N'ԥ֖DtzK4m:%ԥFD.^tK} /ycNzKm/u)?ŗ:>$ S&!PKLbsN)}NK 2uE&/}OVL:Q&*^.S0SZfd6>Y$ZDu M]jKm4y?Y5ԥvڟSjRRM:z󯭓Vk5ykNK?KtMsN/tM^_n=ԛNԥZ_pPN^?z*N}\3N]jKu:%.%䡏uj)ӚOtN}ZtRN^_uZusNשK ;ue'[y[˥Ɲ7u V Eq-2sA܋2 NFq3rG#Aލ pd#89ۑ1 z Gq?2H1\ nHqDrW$8# Idл$%1A^ d$yP2A䅖Q"JiV2E,Ҳd%-YqɚSA,Ҿd&0ĉ"mLidH+A,d&4Y"mMil2kE,d'8Y"lNptHE" OjT nOi|HA,z?U"-PqHE, eg(e(DY)mQi2kE,e)I"mRqHE .e)LYiAަ,8e)4O}" Ta2Eڨ,HeV*8SY" UqHSEڪ,Xe*4WY ViHEڬ he+Vi2HÕ5Z,te+4^Y"W~e,` "mXiIJH+A,ҎekdY)"mYi2kE,že -hYI"mZqԲHE,Үe-lYiˠOm[iܲHE e.p9Eڸ,eV.4sY" ]qmuY ]iH{E e&/y"^iHA,e/}Y؟(_h2E,f'0Y"` fDyHKA,f0Y9"ai3EĬ&fF1kYY"bqH˘E 6f1Yy ci H E FfF2ę"di(Kcg:ϲz3E,Jgg:Y",upH[E,Zg:YΠ."mvi3H5,n煖΢Yflq ǝZA;9A;9BK9q ǝZA;9B;8BK9q Ɲcw^h;9BK9q ǝw^h;9s -q ǝw^h;9ĸs?h;w13qg Ɲw)a9qg ƝA;9 bĸ3q ǝA;wrĸ3qgA;w1ɸ3qg ŝcw1 by% bĿ13qgA;o>A;wrĸ3qgA;o_3Hqg Ɲw1 b9qgc3q ǝA;wrĸ3qg -qg ƝA;9 bs ƝA;wrĸ3q ǝA;w13qgA;w1 b9qg ƝA;1aĸs ƝA;w^h;w13qg Ɲw1 b9qg ƝA;9 z(ǝcw1 bĸs ƝA;wrĸ3qOƝA;w13qg -qg ƝA;1aĸsΠZ Ɲw1 bĸs ƝA;9 bĸ3q ǝA;wb؟(ǝ1;9 bĸs ƝA;w^h;w1 b9qg Ɲw1 bĸs ŝ1;1aĸ3q ǝA;wrĸ3Hqg A;j;wrĸ3q ǝA;w)w)a9qg ƝA;9 bĸsƝA?\s ƝA;9 z% b9qgƝA;8 bĸs ƝA;wr3qwZ'ԡƝwRN]jIwRNhSq'hS߂ƝԸ>GĝԸ}NK_ոSwFSwRN^ߨwNK;uq.5$zoԉ;woԉ;-hܩK;yFS׸^uNjKuN]jܩK;uN]jܩK;ysNIߨw}oԉ;-hK:q'.uN}\NjC:q.5䥏:qPN:qƝԸcN)Ը豿Q'Էq.5ԥƝFv)q5$zOԉ;uq.}Oԉ;uq.5$D>'ĝOKOԯ'ĝDqvwmXIngM?NYȈ͏VJn,wKqNƝwRN^ڟwRN/TN}XN/ԉ;uq.5ĝԸSwMIwnK:qPN@SwRN^TN:q'5ԉ;uq'/ĝԸSw}w\iN}Ӎ;uq'8SqƝtN]JCC_ĝDq:q.5ԥƝtwRNq:q'PN6?wRNĝDm:qƝtߦwRN]JCӻ3_X'иuN]jKj)ӸhqPNoK:qPNĝ:q.5d5ġwЉ;y;q;uq'/='ĝD:q'd=w]'ĝԸSwmNܩkܩK;y?Y'ԥĝGĝ4ԥƝtwRN:q'/}oTNjC:q.5ĝQ'ǝwRN]jItߨw 5$ߨwGиSwcNܩkK:q5FSwRNFSwRN^zoԉ;.uN:q~_uN\:q'.nuN}\NjC:q.5FSq'FSxN]jItߨw 5$oԉ;#hܩK;uq'/Q.%ԡƝD:q5ԥƝtߟwRN'%zOԉ;񍟸?'ĝD:qPN};y?Q'ԥƝ ոSָn uN]jܩK;y)q.5ԥƝDw<ĝw}N)Ը?P'ԥO׸nոN܉C;iuN]jK:q.5ԥƝtƝ4}StNiI?N'jܩoq'/]ĝԸSwׯ;q'uNܩK;uq'/ĝԸs}N Ը沿M'ĝԸ(q'}Nܩoq'/]ĝԸSw.W~/։;=4bSwmw4$Z!l)ԸSwmN)ԸsNܩK;uq'/]'q'NKo NܩkܩK;y?Y'$O։;'Ѹ?Y'ԥƝԸnuN}\N]jK:q.%'ǯw}Ӊ;ykNܩKc}NIӉ;MNKu:q'eNK_tN]jKu:q5?]wwRN^Ӊ;u)q']שqLNĝ4ԥƝ_wwmNܩK;usNҷoqK/)Ɲw>wr9q ǝwr9q ǝOĝwrDK9q ǝw>1;9|%s1;h;9󉖸sA;9|%sA;h;9󉖸sA;83qgA;w1 b9qgƝw1 bĸs ƝA;wrĸ3q ǝA;w13qgA;w1 R9qg ƝOĝA; Ɲw} b9qgЇ'qgA;w1 b9qgΠ;w)aĸs ƝA;9 w13qgA;w1 bDKĸ3qgA;w)3qg Ɲw1 w1 bĸs ƝA;9 bĸ3q ǝA;w1ĸ3qgA;w1 bDKĸ3q ǝA;w13qgA;w1 b9qg ŝcw1 bĸs ƝA;wrĸ3q ǝA;w13qg'Z ƝA;wbø3q ǝAĝA;9 bĸ3q ǝA;wrĸ3qgA;w1ĸ3?Q;cwrĸ3q ǝA;w1|% bĸ3q ǝA;wrĸ3qgA;wqg ƝA;9 bĸs ƝA;cwrĸ3qgA;w13qg ŝOĝA;cwrĸ3qgA;w1ĸ3qg_`9qg8-q ǝAĝA;9 Rø3HqǝA;wrĸ3qgA;w0|"ǝ1mZ Ɲw1 b9qg ƝA;9 R>w JǝA;wrĸ3qg1;wrĸ3qgA;w13qg ŝOĝA;w13qgA;w0 R9qg Ɲw1 bĸs ƝA;9 Rø3q ǝA;w13qg1;3;w>w1 b9qg ƝA;9 bs ƝAK9qg Ɲw)as ƝA;wrĸ3q ǝA;w1ĸ3qgh;.w[bqQРw҉;uq.5|[)Ը};uq'.N)ԸĝB;w 5ďq'Sw҉;wwPN:q'.Sw҉;qĝԸSq'>ĝtN]jܩK;qĝtNƝ@'j)Sqoq'q;uq'/%ĝԸSwPNjܩK;wwRN]jK;y)qPNa(qPNĝ4ĝB;-7޸SwRN^SwPN^J܉K'$J܉;q'/%ԥƝԸ(qPN;F};#hܩK;y)q'/}oԉ;q;y鱿Q.uN};uq.5$։;uq'/GĝB;>GĝB;>GĝhtN\:q'}NܩK;uq'/=Gĝ:ԸnuN]jܩK;uN]jIkNI?Z'ԏq.5hSw}։;yuPNjC:q.5ĝQ'ǝwRN]jItߨw 5$ߨwGиSwcNܩkK:q5FSwRNFSwRN^zoԉ;.uN:q~;y龿Q'ĥwmNܩKܩC;y辿Q'ԥƝtߨw 5$ߨwoܩK;uNƝD:q~;uq.57եĝ:Ը>Q'ԡƝԸuN]jItDD:q'wD?Q'jܩoq'/'ĝԸSw}wwmNܩK;uq'/%ԥƝԸhN@SwN^ԉ;w]ĝԸSwmwЉ;qq'}NܩK;y?P'ԥƝԸո&q'mwLNq:qPN};y?N'ԥƝn?~m؉;tN]jܩK;y?N'ԥƝDtNƝ4m:q'~'ԥƝD;tN};y麿M'ԥƝnt~븳_ٸSwLN]jܩK;y鶿X;ew6jܩ;y鶿X'jIX'ԥƝԸոN܉C'7'5ԥƝ؟w]'ĝD_hItݟwRN]jK:q>q.5dSwǓI|;>ĝN'ԥg}y鱾N'$ĝO܉K':貿N'䥯u:q.5:Sw.;q;uq'/ĝԸSq'd}ntNwRN^zӉ;q;y鶿N'ԥĝ:Ը-|[ҋe3Fc8vhi< vhs :c1Tg:c49F;!Jth3!ZÁshs 9c4mMs2g9cY1\(g69p3F1 xk5g 8kY!pּ, gF8kY ,ph5߬f7kY-o`x5݌f F7k,n`pf6kY1ڬf D5ڌf f6k͚_o[5جf6kYykh\ۚ55k0*/z?Y]jhU5ԌѤfe}8Y=i`Mc1Ҭf 4k09;5Ѭf F4cY ͚ !Ь~f 3klgg˙5άnf f3cY>Čdf 3k0Ye`-c5ʌTf 2k0d`%#cY,dh 5Ǭ:f1kYi-c`5Ō*f F1kobh5Ĭf0kY1lah K5Œf f0kYm`` c8Y_`2%ؾe/k>W5e F/kyY-^`{1e .ku,]`2;%e F.cqY>:\e -k0oYu1e -klaZ`2F5e &-chY~в侾9,e ,ke),Y`2F;5ybYmX`² 5~e +k^lW`rWּ߭,leV+k0ZYLVh5ث\e *kލ`2FS5XPev*k>+5Fe,Tּ >e )kNqlS`˔1yKYY1Z, 7)k0IE R`2Fs5Xe (c4EY~C5C/ e V(k0B LP`e'k>lO`z˓1\ Nhu5؜y?995d &c6YlMhjd &kLhf+5d &&k0YK`^1y-Yi,KhX5dF%k)Y~R2D5I`Nr $k0&Y-MI`IC5ؑьd V$kޏHhC5hr@2F5zd#koG`:rd#kYFh45bd #kYE`,[OȚ_-E˭&pA. 9)pA 9+|+p'ZAn 9.q_8ȁ- 'qdDKe8蓙 wO\rj8ȭ- ׆roDKp8 'O4bu8ouA Xrz0aA0@1 b F\!1C bqK Al9F b1= A,$r(1Ub1&L|%M b?N<1}bA.>9Al)rL1bCA.*UbJb s ,X b8bej1 wA X.rv1b'Z A X0rĆ1HWA11d1)c[AX31g b8Ach-I 7AX51k1ac 60n b8yc A,hI8ݕ r1cCA.:u1cs <x R8c VA{ b1 AX?r1d AN @1| b2! 1L!Br QKr AL"Dr*2Y wA #XF162qdA#c.@2 'AD\I1 b'PR2d[ ƒ\K1 b/9d &Al&9 R5lrA,'Nr;x2 A'Pư2 e# VQ bH9%eS A)f)Sj *XT1 bS9Qe fU0 zuL+ b\ĺrʠqZ Xadr3 vA - bj2 זA-c[>˘6-eA.X]12e ^)a}><F3_3 'Al0a 3h! AL1b139f{A2Xd1 R4K*3YfA3Xf163Hqf cg1 O֒h bJs3 vA 5 RV3 ךA5k1b3f1636m>n b9f ֛A7 bs 6AK9g; \r)ask A9trĤ3M GA:uİ3eghk;.wh;wrĸ3qg'Z ƝA;wrĸ3q ǝA;w1ĸ3qgA;w)a9qg Ɲw1 bĸs ƝA;wrĸ3q ǝA;w0|%,RYï>qg"ŝE;w!QĸHqg"ŝA;w),RĸHqg ƝE;w) bYHqg"ŝE;w0,RYs"ŝEq ƝE;w1,),RĸHqg"ŝA;w) _Fqg ƝE;w1,쏖"ŝA;w) bYHqgA;w),RĸHqgƝE;w) bYHqg"ŝE;w1,RY3qg"ŝE;w),RY3Hqg"ŝA;w),R9qg΢;™ ƝE;w) bYHqg"ŝE;w1,RY3qg"ŝE;w),RY3qg"ŝA;w),RĸHqgA;w),RŝE;w}o"ŝA;w),RĸHqg ƝE;w) bYHqgΚD1QĸHqg ƝE;w)丳Hqg"ŝA;w) bYHqg ƝE;kw)QYHqg"ŝE;w),BY3qg"ŝE;w),RĸHqg"ĝcw!"ŝE;w1,RY3Hqg΢\W3qg"ŝA;>qg ƝE;kw!aYHqg"ŝE;w1,BYsΚ69,R"ŝE;w),RY3qgŝE;>W*,RĸHqg"ĝ1;w1,RYHqg"ŝE;w),RYs"ŝE;w1,RY3qgŝE;cw),RĸHqg"ŝA;w) bYFqg ƝE;w) bYqg ΢"ŝw),RĸHqg"ŝA;w!aY~qg"ŝE;w!QY3qg"ŝE;w),RĸHqg"ŝA;kw)|%,U=%<=qg&ĝtN]jܩK;_w 5|qN]j܉K'ĥw 5:qPNƝB;#h܉C'ԡƝtNƝƝ:ԸN܉K'ԥƝtN\:q.5j܉;q'.SwRN\:q'.Sq'Љ;w %i'-|[I? wRN^JK;uq.%ĝ:ԸSw%%ԥƝԸwRNƝD0QNƝD;#hK;w]7[ܩoq.5ĝ4q5ԡƝNIwN^JܩK$ԥƝD;w}]7[ܩAN]jK;ykNܩkK:q.Wh?Z'ظSwGĝԸnuNƝDuNƝDuN^zx^\:q'.?Z'ԥƝԸuNjK:q.5ԥƝD:q.5$։;w}։;#hܩK;y?Z'ԥƝDuN^Ɲ:ԸuN]jK;ykN܉;q'/%ԥƝԸ趿Q'jIQ'ԏq.5ۏ7FS׸uNjK:q.5ԥƝD:q.5ԥƝߨw]7ĝD_uNw}N܉K'FS?uNoԉ;uq'/]7ĝB;>7ĝwRNFSq'eNܩAN]jܩK;yzu)q5$Oԉ;uq.5DSw]ĝԸSwuwЉ;qĝtĝƝԸuNdk};uN]jܩK;y?Y'5ԥƝtߟwRNx^z:oq':ĝ//=ĝD:;qĝ_w]ĝN'ԥƝt__wPN^e=q>q.5:Swuw4$/mNܩ@N]jKu:q>q'/ĝSw}}ŝ/};_\zw[˝Dr /wr /wFr /wr /w>Ѳ9˝Dr /wr /w>;xs;hYA\'Z;ys;hYA^'Z;ys;yA^'Z;ys;x7ږ;A^ rg;9˝AW#ps; .wrg;A^ rg;y3˝A\ r /wq3˝ .wis;> r-˝A\ (˝rg;9˝A/ rg;y3˝A\ r /wq3˝ |w拸A^ rg;y3?Zrg;y3˝A\ .wq3˝O,wq3˝A\ .wis; .wrg;9˝A\ rg;y3˝A\ .wq3˝ .wqs;cA^ rg;Drg;9˝A\ rg;y3sA^ rg;9˝A\ r/wq3˝A\ .wq3˝ .wrg;A^ rg;hY rg;9-wp3˝Qrg;y3˝A\ r /wq3豿Qrg;A^ rg;q3?Q^r /wq3˝ .wq .wq3˝ .wrg;A^ rg ;q3˝A\ r /w}/Բ9˝A\ rg ;y3˝A\ r /wq3˝ .wii -wps; .wrg;9˝1\ zA^ rg;y3c .wrg;c1^ rgc .wq3˝.w>;c.۴,wqs;A^ rg;9˝AZrg;XWr3˝ .wis;9˝A\ rg;y3˝A\ .wq3H˝O,wq3˝A\ .wqs; -wrg;9˝A\ rg;y3sA^ rg ;9˝A\ rg;y3˝AZΠ ;Drg;9˝A\ rg;y3˝AZ .w.˝ .wrg;c1^ rg;9˝A\ zӲ .wqs;ch[ rap;wrĸ3qg'Z ƝA;wrĸ3_iw1 bĸsƝA;9 b3q ǝA;wrĸ3qgA;w1 b9qg Ɲw1 Rø󉖸Hqg ƝE;w) bYFqg"ŝE;w1,RYHqg"ŝE;w),RY3qg"ŝA;w),BøHqgA;wE;w),RĸSHqg"ŝE;w1,RY(ǝEww) bYHqg΢h9,RĸHqg ƝE;w)丳Hqg"ŝA;w!aYHqg ƝE;w1,RYHqg"ŝE;w),RY3qg"ŝE;w(,RĸHqg"ŝw),RĸHqg"ŝA;w) bYHqg ƝE;w0,RYHqg"ŝE;w1,RY3qg"ŝE;w),R9qg"ŝE;w(,Rĸcw) bYHqg ƝE;帳Hqg"ŝA;w) RYsٟ(Ɲ5;w),RĸHqg"ŝw),RY3qg"ŝA;w),Rĸqg ŝ5;w) bYHqg"ŝE;kw1,RYHqg"ŝE;w),RYs"ĝ5;w),RY3Cqg"ŝA;kw ŝA;w) bY?N;w1,BYqg "ŝE;w),RY3qgŝw\qg ƝE;w1,RYHqg"ĝ5;w!wo ~ ƝE;w!aYCȸ3qg"ŝE;w),RĸHqg"ĝcw),RY3qg"ŝA;w(,BøHqg ƝE;w) bYHqg"ĝ5;w1,RYHqg"ŝE;cwgw)丳Hqg ƝE;w) bYqg "ŝE𻬎;w),Rĸqg"ĝ1;w),RĸHqg ƝE;w) RYHq-qgO߷(hPWN܉K'ԥƝԸoqP-ԥƝtN\:qPNw 5j)Ը?Ɲ8tNj܉K'j܉kܩC;qĝtN]j܉K'ĥwRNƝw҉;uq.5ĥw҉;wSqPNƝŝD_5ԥƝwGN]JC;uq.5$JɏKܩK;uq'/%ĝB;aĝB;wGиw 5$oԷSxN]jK;yiNjܩC;y)q'.(q'>ĝSwRNĝB;>|-ԏq.5ĝQ'5FSwЫ3_tw{lܩK;uN]jK:qPN:qPN:q'/=~Gĝ4ԥƝtwRN:q'/}VNjC:q.5ĝQ'ǝwRN]jItߨw }^:q~;uq'/~Q//=7ĝƝt_ߨwPN^oԉ;uq.5$oԉ;uq.5F貿Q'$ߨwGиuN\:q'/7ĝĝ:ԸuN]jK:qPN:qƝԸ躿Q'jItߨwGиSwRN^x^]JܩC;nuNjܩK;y?Q'ԥƝDOK؟w?q'/wҿ_TN>Mܩoq4$w 57޸tN]jܩK;yqzy?N'ԥƝԸntN]jI>N'jIsߦwpN]jI辿M'7޸tN]jܩK;y?N'ԧ5ԥƝ.W>ĝFwmw4$Z!l)ԸSwmN)ԸsNܩK;uq'/]'q'NKo NܩkܩK;y?Y'$O։;'Ѹ?Y'ԥƝԸnuN}\N]jK:q.%'ǯw}:q'/}Ӊ;uY_^zӉ;3u:q'w҉;y鱿N'$Ӊ;ykNܩK~龾N'ԡƝzN}\N]jKu:q.%:5iI7Y_:S?ƝԸtN}\N^Ӊ;u)q5:};_w"K-wr-˝9˝m˝9˝Dr /wr-˝9˝D^A^|es;qs;hYA^|es;ys;hYA^'Z;ys;hYA\h[ rg;y3˝A\ r.wi3˝ .wqs; .wrg;9˝A\ rg;y3˝A\ .wq3H˝c .w>Ѳ ێ9˝A\ r /w}¿+˝A\ .wq3˝ .wrg_-w拸A^ rg;y3?Zrg;y3˝A\ .wq3˝O,wq3˝A\ .w=GkY rg;9˝A\ r /wq3˝A\ .wqs; .wrg;A\rgc .wq3˝O,wq3˝ .wqs;A^ rg;9˝A\ r/wq3˝A\ .wq3˝ .wrg;A^ ߨe .wq3˝ .wrgF-˝A\ .wq3˝ .wrg;A^ rg;q3?Q^r /wq3˝ .wq .wq3˝ΠD-˝A\ rg;y3H˝1\.wq3˝ .wrg;A^ rg;9˝A\ r /wq3˝AZ|e3H˝1\ .wq3˝>?Pr .wp3rB;y3˝A\ΠqZ;9˝AZrg;x3˝A\ .wq3˝.w>;c.۴,wqs;A^ rg;9˝AZrg;y3;Z; -wrg;y3˝A\ r /wq3˝ .wii .wq3˝ .wrg;c1^ rg;y3˝A\ r /wq3˝.wqs; .wrg;9˝A.wq .wqs; .wrg:ys;˺,wrg;9˝AZrg;x3˝A\ r /wq3˝ .wqs;ch[ rx Ɲw1 bĸ󉖸3qg Ɲw1 b9qg ƝA;1aĸs ƝA;cwrĸ3q ǝA;w13qg Ɲw1 z(3qgƝOĝE;w1,RYHqg"ĝ5;w),RY3qg"ŝE;w),RĸHqg"ŝA;w) bYHqgƝE;wrYH .RĸHqg ƝE;"ŝE;w),RY3qg"ŝA;ƝEگRĸHqg ƝErY3qg"ŝA;w),R9qg"ŝE;w),z"ŝE;w1,RY3qg"ŝE;w),RĸHqg"ŝA;w),RFqgcw),RYs"ŝE;w),RY3qg"ŝA;w),RĸHqgƝE;w) bYHqg ƝE;w1,RYHqg"ŝE;9,RYHqgŝE;w}o"ŝAŝE;w) bYHqg"ŝE;w1,RY3Hqgew( bYHqg"ŝE;wrYHqg ƝE;帳Hqg"ŝA;w( RYHqg ƝE;w1,RYFqg"ŝE;w1,RY3qg"ŝE;8,BY3qg"ŝE;w),RFqg_PĸHqg ƝE丳Hqg"ĝ5;w0,RY3qg"ŝE;w!Q9qgew) bYHqg"ŝE;w]w!QY3qg_ǝJŝA;w),Bøhqg"ŝE;w1,RY3qg"ŝE;8,RYHqg"ŝE;w!QY3qg"ŝA;w),RĸHqg ƝE;kw) bYHqg ƝE;w0,(,R9qg"ŝA;w),RĸHqgƝE;wYw1,RY3qgŝE;cw),RY3qg"ŝA;w),RFqg'Z΢_ŝ_Ɲw>wr9q ǝwr9q ǝOĝwrDK9q ǝw>1;9|%s1;h;9󉖸sA;9|%sA;h;9󉖸sA;83qgA;w1 b9qgƝw1 bĸs ƝA;wrĸ3q ǝA;w13qgA;w1 R9qg ƝOĝA; Ɲw1 b9qgЇ'qgAƝA;w13qgA;w]ܙb9qg Ɲw]Gk;wrĸ3q ǝA;w1|% bĸ3q ǝA;wqĸ3qgA;w13qg Ɲw1 b9qg ƝA;9 bĸ3q Ɲ1;wrĸ3qg'Z ƝA;9 bĸ3q ǝA;wrĸ3qgA;w)3qg Ɲw1 bĸs ƝA;9 bĸ3q ǝA;w>w1 bĸsƝA;9 ߨ% b9¸3qg Ɲw1 b9qg ƝA;9 bĸsΘD9a9qg Ɲw1 bĸ󉖸3qg Ɲw1 b9qg ƝA;9 RøsƝA;wrĸ3q ǝA;w03qg Ɲw1 b9qg ƝA;f;w03qg Ɲw1 b9qg Π\s ƝA;9 % b9qgƝA;8 bĸs ƝA;wr3q9ow13qgA;w1 b9qgƝA;9 zw~C;w| ƝA;wqCs ƝA;wrĸ3q ǝA;w)|% bĸ3q ǝA;wr3qg1;w13qg Ɲw1 b9qgƝA;9 bĸ3q ǝA;wqaĸ󉖸3qgA;w1 b9qg ŝcw1 e]A;w13Hqg ŝcw1 bĸs ƝA;9 bĸ3q Ɲ1;wF[t/;ov?Oj':q'.SwRŝB;ܷSw҉;qĝB;N)ԸSqPNwЉ;uq'.Sq'>q5ġw҉;uq'.NܩK;wN܉K'ԥƝԸN܉K'j tNƝB;ew |;_wƝԸwRN]jܩK;y(q5ԥƝD;q;uq.5ĝSq'Q0LSq'QNwRNƝDwoܩK;y)q'/MܩC;uq'/%ĥw%ǝwRN]jISq'u}ŝ4ԥƝ7ĝƝߨwRN}^ŝ:qƝD:q.5hSq'hSq'h?N܉K'$։;uq.5hSwmNܩK;u߿XZkܩkܩK;nuNƝDuNwRN^։;uq'hGq5FSwRN^ߨwNK;uq.5$oԉ;w}oԉ;#hܩK;yzy鱿Q'5FSwuNܩK;uq'mNܩK;uq'/=7ĝD:q'FS?Ɲtߨw҉;y鶿Q'%ԡƝq'.tN:ĝԸtNjK'5ԥƝt_wRNSNƝD?%Ӊ;hܩK;y鱿N'5:SwPNӷoqK;pv>g;ps G;pY&;ps ;pi<9kc84é1\áΧNtJxs 7:hs:c9Ou1m1|/s0r,xs G9pi<9c49{2sſ"Fcc)-qhs w8c01g&8c91ߌf7p|3Fۛ1 ohw3Fcmnf7c4!یf6[1ڌѿ(FCclfǯMl<0V61׌Ѽf5p\3Fۚ1e kծfHcQmjfe}<=1ӌњf4pK3FS1ZҌѐxG3F31ZьшnhhB3 C8gh=s 3c31\Όpfv3c491͌fNfh13F1ùeh,3F[c4 eNff2çFf&2c91njQlb$f1c4=1Ìf0c9S1ZŒ`h3F+1 M`hi<_hr/C}1\X_^hr W/c4zM^e/cw9s1Ze.p2FK1ːp2D#cq-\e-c4ou˧e-c4me1Ѯef-p2F1ڴѤ.Z`2D{c4g5Yhr ,cd!1ܱьe V,C4b91тe,p2F1ZmWh2˕OVhr W+c4ZMVbe+cW9Fs!Zy;1Re*p2c}nRXoT`2D 1}Shr )cMi-S0e v)C4K4\ 7)c4I91Qh2Fc1ڢ),Qh2F;c8Cʘ/e&(c@!ܟOh{2Fӓ1ZNhvr W'c4:LN>'c48Md&c59S1X d v&pf2F+1ÍMLha2Fc/yKd %C4-e1Ѯdf%c*91ڔyl%c#ړќxM2Fc1ڒ)-IhH2F;c8#Hd&$cOGh>2Fc8MG`9r#cFhd6#c491^d"h-2Dc1ڊmȘ,EHךps'ZzA (7ښA *pA. hI -p'r^8} Obc8Ƒ- g>ri8ȩ OĆ\rn8Ƚ- >rt8g1< by8a ƇA9? Rq &Al!n!C b8%bS #F bq ALI b*1HYwA X&>ђ&M |X'r>1 Aۜ 6AR bN1 AL*rZ1} _5UX,1Yf1?ZKlq A,9] bx1-b A,9a bq+ fA2rĔ1- njA3g1EcAn5j b8]c ALmaĺq A X8>ђ8]7jr b1 AL:r1c{A X<)y1c f=1| bq ƏA9 b2 'Al A>RA1 brKAl!9 ߨ% b9Ad &Al"9 b,r A,#Fr82u 1r Br 6A$ b&N2-dS A% b.^r AL&Lr4tElrA,'Nr;x2 A'Pư2 e# VQ bH9%eS A)f)Sư2Ee 6U bV9]e ʠYr' ƕA+9 % ba9ȉeFA,8 bgrK Al-[rm29oӒ\2eA.^ bz9e֗A/ b| 6A0TaqCsK Al1cr3= A,2d|% b,3] A,3fr83uf13h bJs3 vA 5 RV3 ךA5k1b3f1636m>n b9f ֛A7 bs 6AK9g; \r)ask A9trĤ3M GA:uİ3eghk;.wwrDK9q ǝwF[9q ǝw>wr9q-q ǝwrD;8󉖸sA;8|%s'ZA;9󉖸sA;9|%s'ZA;17 ƝA;9 bĸ3q ǝA;cwrĸ3qgA;w1 b9qg Ɲw1 bĸsΠFmq ǝA;w)3qg'Z ƝAqA;w13Cĸ3q ǝA;w13qgA;w0 sqg Ɲw]Gk;wrĸ3q ǝA;w1|% bĸ3q ǝA;wqĸ3qgA;w13qg Ɲw1 b9qg ƝA;9 bĸ3q Ɲ1;wrĸ3qg'ZΠF-q ǝA;w13qgA;w1 b9qg ŝcw1 bĸs ƝA;wrĸ3q ǝA;w13qg'Z ƝA;wbø3q ǝAĝAZ ƝA;wrĸ3q ǝA;w13qgA;c.3q ǝA;wrĸ3qg'Z ƝA;wrĸ3q ǝA;w13~&q Ɲ1;w13qgA;w)a9qg ƝA;9 bĸs ƝA;w>w)a9qg ƝA;9 bĸsƝA.q ǝA;wr?NKĸs ŝ1;wqĸ3q ǝA;w13Hqg 'rsߦ% b9qg Ɲw1 b?K;w0 b9qgΠqA8JƝA;wqCs ƝA;wrĸ3q ǝA;w)|% bĸ3q ǝA;wr3qg1;w13qg Ɲw1 b9qgƝA;9 bĸ3q ǝA;wqaĸ󉖸3qgA;w1 b9qg ŝcw1 e]A;w13Hqg Π:-qg ƝA;9 bĸs ƝA;wbø3qoŝA;Fo;wrĸ3qgCq-qg ƝA;9 bĸs ƝA;wbø3q ǝA;w03qgA;w1 b9qg ƝA;9 bĸs ƝA;cw>w),RĸHqg"ŝA;w( bYHqg ƝE;w) bYHqg"ŝE;w1,RY3qg"ŝE;cw),R9qg"Hqg"ŝE;w}|w) bYHqg ƝE;w1,BY|"ŝE;w]Gqg ƝE;w1,RY丳Hqg"ŝA;w!aYHqg ƝE;w1,RYHqgUqg"ŝA;w),RĸHqg"ŝA;kw) bYHqgA;w) bYHqg ƝE;w1,RYHqg"ŝE;cw),RY3qg"ŝE;w),RĸHqg"ŝA;w)丳Hqg"ŝA;kw) bYQ;帳Hqg"ŝA;w) bYHqg ƝE;w)OŝA;w) bYHqgA;w),RĸHqg ƝE;w) bYFqgŝE;w]w),RĸHqgŝA;w),RĸHqg ƝE;w!㸳qg ƝE;w) bYHqgŝEoBqg"ŝE;w}쏓"ŝA;w(,BøHqg ƝE;w) bYFq Ɲ5mrY3qg"ŝA;w),Rĸqg"ŝA;w) _HqgƝE?;w),RY3qg"ŝA;w),B9qg"ŝE;w),Rĸqg"ĝ1;w) bYHqgΠsqg ƝE;kw) bYHqg ƝE;w0,(,R9qg"ŝA;w),RĸHqgƝE;wYw1,RY3qgŝE;cw),RY3qg"ŝA;w),RFqg'Z΢_ŝwԸ3|OtN\:q.5ԥƝ/};woq.5ĥw҉;wSqPNƝ4ġwPN\:qPN|\Nj܉CƝtN]j܉K'ĥwRNƝw҉;uq.5ĥw҉;wSqPNƝŝDð>q.5ĝSwRNJܩC;uq'QN~\N]jܩK;y)q'/%jI? %jIS?ƝSq'u}ŝwRN^JKwPNjK;qĝD;q'ĝԸSw%jI1Ct]ߨoq~;uq'/%䥯:q>q'/=7ĝnu^zwW5ƝD:q.5hSq'hSq'h?N܉K'$։;uq.5hSwmNܩK;uq'}NܩK;nuN?uNhSwuNܩK;>Gĝ?Z;uq'=?XSwRN^ߨwNK;uq.5$oԉ;w}oԉ;#hܩK;yzy鱿Q'5FSwuNܩK;uq'mNܩK;uq'/=7ĝD:q'FS?Ɲtߨw҉;y鶿Q'%ԡƝq.58ŝbk}NICظSq~;y鶿X'jIXgwidkvF.71O3xuC4HBB)}N]jܩK;y?Y;qĝ8tN^zbpN}\N]jK:q'm}NI>YƝD:q.5ԥƝcNܩK;y?Y'ԥĝuN]z}}/ĝD:;qĝ_wĝN'ԥƝ\_wPN^zN}\N]jKu:q.%:5iI7YDu:q~;uq'/ĝƝ_wRNjCuw~Kåc[ -˝9˝A^A^в9G˝yes;ys;/1^ -˝9˝cy;ys;/,wr /wr煖A^A^в9˝yes;qs;?Ѷ .wrg;A^ rg ;y3˝A\ r /wq3˝A\ .wqs; .wrg;9˝A\ rg;x3˝A\в ׎9˝A\ r /w+˝A\ .wq3˝ .wrg;cw˝U^ rg;y3?Zrg;y3˝A\ .wq3˝Z; .wrg&g9˝A\ rg;y3˝A\ .wq3˝\ rg;y3˝A\ r /wq3˝A\.wqs; .w^hY rg;y3˝A\ r /wq3˝ .w7jY rg;x3˝A\ r /wq3˝A\ .wqs; .wrg;ye3˝A\ r .wp3˝Qrg;y3˝A\ r /w7jY .wq3˝ .wrgmA^ rg;y3˝A\ r煖 .wq3˝ .wrg;A^ rg ;q3˝A\ r;;A^ rg;c^,wq3˝A\ .wqs; -w^fY rg ;y3˝A\ r /wq3˝Πߗ"9˝A\ r /wӲA^ rg ;9˝A\ r /wq3˝A\ -wpB^oӲA^ rg;y3˝A\ r /wi3˝A\Π8-˝,w+ -wrg˝ .wqs;A^ rg;^듵,wq3˝A\ .wqs; -wrg;9˝A\ rg;y3˝A\ -wp3mA^ rg;9˝A\ r/wg -˝A\ r /wq3˝A\ .wis;/~uY .wqs; -wrg;A^ {~A^ rg;9˝1\ r'ږ;nGĝA;9 bĸ3q煖3qg Ɲw1 b9qg ƝA;1aĸs ƝA;cwrĸ3q ǝA;w13qg Ɲw1 b9qg ŝ1;/ĝE;w1,RYHqg"ĝ5;w),RY,,w),RY3qg"ŝA;w),RĸHqg ƝE;w!aYHq ǝE;"ŝA;w) bY)RY3qg"ŝE;w),Rĸqg΢΃rPw) bYt-ǝE;w),RĸHqg"ŝw),RY3qg"ĝ1;w),RĸHqg ƝE;w) bYHqg"ŝE;w1,RYHqgŝE;w),RYs"ŝE;w),RY3qg"ŝA;w),zo"ŝE;cw),RY3qg"ŝE;w),RĸHqg"ŝA;w)丳Hqg"ŝA;kw) bYQ;w1,RYHqg"ŝE;w),RY3衸Hqg ŝ5bY3qg"ŝA;w),R9qg"ŝE;w),RĸHqg"ŝA;w( RYHqg ƝE;w1,RY?P;w),RĸHqg ƝE;w!㸳qg ƝE;w) bYHqgŝEr] ƝE;w1,z'ǝE;w!QY3qg"ŝA;w),RĸqgA;kn丳Hqg"ŝE;w),RY3qgŝE;w),RqgRqg"ĝ1ŝEBƝA;w),RĸHqg ƝE;w!㸳Hqg"ŝA;w) bYFqgƝE;w1,RYHqg"ŝE;w!QY3qg"ŝE;w),Bøh?Hq ǝE;w1,RYHqg"ŝE;cw),3qg"ŝA;w(,BøHqg"ŝA;w) bYHqg ŝ5;w^h;nw_ΟFAw4/:ĝtN]jܩK;%j};uq'.N)ԸĝB;w 5ďq'Sw҉;wwPN:q'.Sw҉;qĝԸSq'>ĝtN]jܩK;qĝtNƝ@'j)Sq?/qĝD?5ԥƝwRN]JC;uq.5$JɏKܩK;uq'/%ĝB;aĝB;wGиw 5$oԗSxN]jK;yiNjܩC;y)q'.(q'>ĝSwRNĝB;|%ԏq.5ĝQ'5FSwcNܩKĝ{駸3_?Z'7ԥƝw 5$zw 5$zwۣåw҉;uN]jܩK;y>Z'ԡƝwRN]jIwRNhSq'hS?ƝԸuN]jI?Z'䥏jܩC;y?Z'ԥƝ>7ĝwRN]jܩK;uNƝDuNwRN^z|{~ߨwws}NܩC;y龿Q'ԥƝԸ豿Q'ԥƝԸ^uNFcNܩAN^zoԉ;qĝߨwwPNzoԉ;uq'/7ĝB;7ĝwRNFSq'mNܩAN]zoԉ;yRNjIXwPN]jK:q.5${~D:q'w㥏:q'}N)ԸSxN^zOԉ;uq.%B5ԇ5BSwRN^JܩK;uq'ĝ4:qƝw 5$ԉ;uq.5@5ġwPN@SwcNܩK;uq'/=q'm&7ݸSgwӉ;woKq:q.5ԥĝ<8x?N'ԥƝԸtN]jI>N'jIsߦwpN]jI蹿M'7޸tN]jܩK;y?N'ԧ5ԥƝwR;[|/VNƝDƝB;3iK:qPN:q.5ԥƝtߟƝ8tN:q'/=18q>q.5d>Y'$XWNdSwRN^zO։;q;uq'/='ĝߞlė}NKuN]z}}/ĝD:;qĝ_wĝN'ԥƝ\_wPN^zN}\N]jKu:q.%:5iI7YDu:q~;uq'/ĝƝ_wRNjCuw~Kåږ;yBr /wr /w~ms;ys;/,wr /w^hYA^ ys;yBr /wr/w^hYA^в9˝9˝Z;ys;yBr;;yBr /wr/w~m3˝A\ .wq3˝.wrg;A^ rg;9˝A\ r /wq3˝A\ .wqs; -wrg;ye3˝Aqs;A^ A^ rg;9˝A\ r /wi3˝A\|;9˝A;9˝A\ r /wq3˝A\в .wqs;1^ rg;9˝A\ r /wq3˝A\ .wqs; .wrg;A\rg;y3˝A\ r煖 .wqs; .wrg;9˝A\ rg;y3˝AZ .wq3˝ .wqs;A^ rg;9˝A\ r煖 .wq3赿Q^rg;y3m .wrg;A^ rg;y3˝A\ r;A\O;c9˝A\ r /wq3˝A\в .wqs;,wrg;A^ rg ;q3˝A\ r /wq3˝ -wps; .wrg;9˝A\ rg;/,wi3˝ .wqs;A\rg qZ;A^ ze3˝.wis;A^ rg;9˝AZr煼sߦe3˝ .wrg;A^ rg ;9˝A\ r ,w~Atw+1^ Zzs; .wrg;9˝A\ rg;/,wq3˝A\Πd-˝.wis;A^ rg;9˝A\ r /wi3˝A\ .wq3˝ -wrg~˝A\в .wrg;A^ rg;x3˝AwYA^ rg;y3H˝1\ r/wq3˝A\ .wqs; .wrg ;Π,w>_`i;01 ;ǰì,UFctayctaycXsa9-era9!eqa9FFq9 q9cXo^cnaycmayWcmQ9Y150׌QX3F1(5CjaL3Ff"1l4chƨЌQ9}fՙcgƨ͌Q2s u12ǰʌQ&3I1 2cc^9fj6_3F%fB10c310caa3Ff1/c_ƨ2ec.Qv9em}2F1 .c[an2FeZ8Qi2Ff1,cYac2Fe1+cWƨø2FmecVƨQV9Ue51J*ǰQP2F9Ք!)cRaJ2F!e:8QEr %1*(cPa?|2FƓ1j'cNƨp2Fd !&cMƨQ29d1%: !CAa 2F61J cT@(1c?a1F1c=ƨz1c1*C<ƨwQ8cbc:ƨtAq 3U1c8a1F1cT7 n!*0lQ1FUF1jc4Q1' xύkŌ1j0ey[10cA1 㐧1 ǰ_Qz1F1HCT.^bm}m-ƨZh1Fb1,c,ƨWQ8b b1JǰTQNq 3Řc(ac8}bՉ1ǰMQ2q u1cP%^Qb%1*0HQq kĈ!jc"a1Ff1c!ƨA1Fb1c>Q|8a1 ǰ;QvpØqp0Fֆ1 c(50Fa :! cT쿣p 1 ǰ/A^0q1J cT(,TW0FUF1j cƨ(0D=arOԄ1 c 9'rP8E 'hk 9*p -] \^hI -p 9/p - 'qdx2p; - rkx%6psA /\rrx9p1?1< by8a ƇA9? Rq &Al!r 1bCA."E15bs X$1I&1Qb ec%1L bx%M bĿN<1}bA.9Al)rL1bCA.*UX1Hb s ,~A?U*&,Gk-rp1 Al/^В/_ bĂq 6AǸb bĎ1! AL2rĚ19c{AX41i1Qc f51l bĴqƍA9o b1ㅖ1c#A9s b8ȥcS ;v bq AJǸy btߨ%{1c l?~1c @ by b2! 1L!Br QKr AL"Dr*2Y wA #XF162qdA#cn@2 'Al$Ir%L2dC -dS A% b.^r AL&Lr4j2 v1 'XN1v2dA'O)aA9 e FA(9 bGĐrK Al)S^f)Sư2Ee 6U bV9]e ʠ.i A+XWr^?NK`r 51,TYqf2 AL-Z12He { 9oӒ\2eA.^ bz9e֗A/ bs̠o00Taq!t9%fS A1 bs AL2d^f2Xe1 b9af f)Όaq5ġw҉;uq'.NܩK;wN܉K'ԥƝԸN܉K'j tNƝB;eww~KI wRN^JK;uq.%ĝ:ԸSw%%ԥƝԸwRNƝD0QNƝD;#hK;w7Kܩoq.5ĝ4q5ԡƝNIwN^JܩK;uq'QNƝDoo>DwGиSwRN^ߨwwkNܩK;y豿Q'ԥƝԸOqg?Z'7hSq'hSq'h^.NI?Z'ԥƝZwPN^z։;uq.5$z։;uq'cN)Ը}NܩAN]jK:q.5$zwh5ԡƝ<wRN^JKuN|܉;y)q.5ԥƝD:qPN:q~;uq'/%FS׸uNjK:q.5ԥƝD:q.5ԥ}N)Ը趿Q'$ߨwGиuN\:q'/=7ĝĝ:ԸuN]jK:qPN:qƝԸ辿Q'jItߨwGиSwRN^z~{~Sw='ĝ:ԸSwsNܩK;ߞkN܉oĝDxcNItߟw 57޸uN]jܩK;y蹿P;a;y豿P'ԥƝԸwRN]jI4q'kNܩq'/=ĝB;uN]jܩK;y?P;qĝ8Ը?P'ԥƝwRN]jKjIsߧ;M7ԙƝDtNƝw}NܩK;u)q'==N?=`'$Ӊ;uq.58SwӉ;wĝSw%$zoӉ;76SwRNzӉ;i;uq'/ĝԸ>Nʏ:q'qPNLwc>zq'bSwRN^OVN:q'S׸SwkNIt[w}O֫q'}NܩK;uq'/='ĝƝԸuN]JCoO֏^NKI?Y'䥏:q.>돗^tNcN܉oĝtN^zӉ;ntN^_wRN^zӉ;uq'/e=q>q.5:Sw}w4$?:S?ƝԸ^tN}\N^zӉ;u)q5:};%Ɲ}\ .wrg;Z r煖 .wq3˝ .wrg;A\rg;y3˝AZ5n߷;A^ rg;9˝A\ rg;y3˝A\ .wi3˝Z;Y .wiH˝EZ rg;k"-wiH˝A\,rg;"-wi3˝EZ,rg;Y"-wqH˝EZ,rg ;YA^,rgkGEZ rg;΢?,wqH˝EZ,rg;Y .waF˝EZ rg_-w΢hyH˝A\,rg;Y"-wis;Y"-wqH˝EXrg;Y .wiH˝A\,rg;>G˝EZ,rg;Y"-wqH˝EZ,rg ˝5Z,rg;Y"-wrg;"-wiH˝A\,rg;Y"-wi3˝EZ,rg ;Yt(/wqH˝EZ,rg;Y .wiH˝EZ rg;9˝EZ,rg;Y"-wqmY .wiH˝EZ rg;"-wiH˝A\,rg;Ys۟(.wh3˝EZ,rg;Y"-wrg;Y .wiH˝A\,rg;",wh3H˝5Z,rg;Y"-wqH˝EXrg;Y"-wY"-wqH˝EZ,r/waF˝A\,rg;"-wi3H˝5Z,u9B˝A\,rg;Y?N^,rg;Y",wpH˝EZ rg;Y .waF˝Ys&/wi3˝EZ,rg;Y"-wq˝5Z,rg;Y .w>Kٯrg ;?\ rg;Ym .wiH˝A\,rg;9˝EZ,rg;Y"-wq˝5Z,rg ;Y .wiH˝EZ rg;",whH˝A\,rg;>Y^,rg ;3Z,r /wiH˝A\,rg;"-wa3˝EZ, .wiH˝A\,rg;"-wiH˝A\,rg;Y"-wi3H˝5Z,r煖΢?K?ĝŝw^h;9sOŝwr9q煖sA;/ĝwr9qwq9q煖sA;8wr9q煖sA;9wr9q ǝz9s -q ǝwq3qgA;w1 b9qgƝw1 bĸs ƝA;wrĸ3q ǝA;w13qgA;w1 R9qg ƝZ ƝA qA;w13Mĸ3q ǝA;w13qgA;w0 b9qgŝ*ƝwGk;wrĸ3q ǝA;w1w1 bĸs ƝA;8 bĸ3q ǝA;wrĸ3qgA;w13qg Ɲw1 bĸsKqg Ɲw1 bĸBKĸ3q ǝA;w13qgA;w1 b9qg ŝcw1 bĸs ƝA;wrĸ3q ǝA;w13qg -qg ƝA;1aĸsΠZ Ɲw1 bĸs ƝA;9 bĸ3q ǝA;wbs۟(ǝ1;9 bĸs ƝA;w^h;w1 b9qg Ɲw1 bĸs ŝ1;1aĸ3q ǝA;wrĸ3Hqg A;w1 b9Ÿ3qgA;w1 Ry% Røs ƝA;wrĸ3q Ɲ1;~Ɲw1 b9qg8-qgA;w0 R9qg Ɲw1 bĸs ŝ1;/3涿MKĸs ƝA;9 btߦ%3Hqg Ɲw1 b9qgΠ;;8 Z:3qg Ɲw1 b9qg ƝA;/ĝA;w13qgA;w0 R9qg Ɲw1 bĸs ƝA;9 Rø3q ǝA;w13qg1;3;w^h;w13qg Ɲw1 R9qgΠK9qg Ɲw)ﯓ1;w1 b9qg Ɲw1 bĸsƝA;?w*/qOA;tN\:q.5ԥƝ_w 5ĝԸN܉K'j tNƝB;wGиNܩC;qĝB;q;uq'NܩK;qĝtN]'j܉;q'.SwRN\:q'.w 5:qPNĝ2; |;%$z?q.5ĝSwRNJܩC;uq'QN~\N]jܩK;y)q'/%jI %jIS?ƝSq'}}ĝwRN^JKwPNjK;qĝD;q'ĝԸSw%jI6Ct_ߨ/q~;uq'/%䥏:q>q'/7ĝuN]jܩK;Q?U;uq7iK:q'hSq'h^.NIwRN]jK:q5hSwRNhSw=GĝB;Gĝ4ԥƝtwRN:q'/}VNzGĝԸSwRN^ߨwNK;uq.5$zoԉ;woԉ;#hܩK;ykNܩkK:q5FSwRNFSwRN^zoԉ;nuN:q~;y鹿Q'ĥwcNܩKܩC;y蹿Q'ԥƝtߨw 5$zߨwoܩK;uNƝD:q~;uq.57K;uq'c}NܩC;uq'/='ĝԸ'ĝOKoOԏ>'ĝD:qPN};y?Q'ԥƝ ոSָ uN]jܩK;y)q.5ԥƝDwҼĝwsN)Ը?P'ԥƝԸոN܉C;iuN]jK:q.5ԥƝƝ4}StNiI?N'jܩoq'/ĝԸSw㡏?vN8SwRN^zӉ;uq'8q'mN܉;uq'QN6SxN^oӉ;uq.%8SָSwkNܩK;y[ܙX_ww 5Ϥq'/=ĝB;ĝԸSw}wЉ;qĝĝƝԸ^uNdc}^;uN]jܩK;y?Y'5ԥƝܟwRN{~CܙrgmY .wiH˝A\,rg}9˝EZ,rg;Y",wpH˝EZ,rg;Y .wiH˝EZ rg;"-wiH˝A\,rg;-wi3˝EZ,rg;yH˝EZ rg;YQ^,rg;Y"-wi3˝EZ,rg ;Y"-wqH˝EZ,rg;Y .wiH˝EZ rg;9˝EZ,rg;Y"-wqmY .wiH˝EZ rg;"-wiH˝A\,rg;Ys۟(.wh3˝EZ,rg;Y"-wrg;Y .wiH˝A\,rg;",wh3H˝5Z,rgByH˝EZ rg;Y .wiH˝EZ rg;"-wi˝cY-wqH˝EZ,rg;Y -wh -wqH˝EZ rg8yH˝A\,rg;"-wi3˝EZ,rg;>Y-wrgmY .wiH˝A\,rg;",whH˝A\,rg;Y΢^Wb3˝EB.wqH˝EZ,rg;Y .wiH˝EX"-wiH˝A\,rg;Y-wa3˝EZ,rg;Y΢rg;",whH˝A\,rg;"-wa3˝E-wis;Y .wiH˝EZ rg;"-werg;Y .waF˝EXrg;Y .wiH˝A\,rg;-wiBrgo;~q ǝZA;9mq ǝwry%s -q ǝwry!ǝcwry%s1;/ĝwry%sA;/ĝwr9q煖sA;/ĝwb9q' ƝA;9 bĸ3q ǝA;cwrĸ3qgA;w1 b9qg Ɲw1 bĸs ƝA;9 bĸ3HqƝA;w^h;w/A;9 bĸsΠ7O Ɲw1 bĸs ƝA;9 Rø3q ǝA;.rt% b9qg Ɲw1 bĸBKĸ3qgA;w)3qg Ɲw1 b9qg ƝA;9 bĸs ƝA;wrĸ3qgA;cw13qg ƝZ ƝA;9 bĸ3q ǝA;wrĸ3qgA;w)3qg Ɲw1 bĸs ƝA;9 bĸ3qƝA;w^h;w1 b9qg Ɲwow13qg Ɲw1 b9qg ƝA;9 bĸsΘD9a9qg Ɲw1 bĸBKĸ3qgA;w13qg Ɲw)a9qg ƝA;9 bĸs ƝAwW A;w1 b9qg Ɲw1 b2K3q ǝA;w13qgA;cwu;9 bĸsΠqZ Ɲw)as ƝA;9 bĸ3q ǝA;cw^qgm3q ǝA;wrĸ3qgA;w0 b9qg Ɲw1 3_sΠA;w1 b9qg Ɲw1 b2Kĸ3qgA;w13Hqg ŝcw1 b9qg ƝA;9 bĸs ŝ1w3A;9 bĸ3q ǝA;wqaĸBKĸ3q ǝA;w13qg1;we]A;w13Hqg ŝcw1 bĸs ƝA;9 bĸ3q Ɲ1;w~- U [9q煖sA;9D[9q ǝw^h;9BK9q ǝw^qǝw^h;9ĸs -q ǝw^h;9s -q ǝwry%s -q ǝwq3qgA;w1 b9qgƝw1 + b9qg ƝA;9 bĸs ƝA;wrĸ3q ǝA;w)3qg -qg 8q ǝA;wr bĸs ƝA;wrĸ3q ǝA;cw13qgŝU;nĝA;9 bĸs ƝA;w^h;w1 b9qg ŝcw1 bĸs ƝA;9 bĸ3q ǝA;wrĸ3qgA;w1 b9qg Ɲw1 bĸBKĸ3q ǝA;w13qgA;w1 b9qg ŝcw1 bĸs ƝA;wrĸ3q ǝA;w}ow1 by% bĸ3q Ɲ1;wrQKĸs ƝA;wrĸ3q ǝA;w13qgA;cn3q ǝA;wrĸ3qg -qg ƝA;9 bĸs ƝA;wr3q Ɲ1;w13qgA;w^1;9 bĸ3q ǝA;wrĸ3qg,qgƝw1 b?PKĸ3q Ɲ1;~Ɲw1 b9qg8-qgA;w0 R9qg Ɲw1 bĸs ŝ1;/3涿MKĸs ƝA;9 bĸ3q ǝA;cw13qgA;ww~Av;?;9 bĸ3q ǝA;wrĸ3qg,qg ƝA;9 bĸs ŝ1;wqĸ3q ǝA;w13qgA;w0 b9qg ƝA;9 bsΠ ƝZ ƝA;9 bĸ3c3qg1;we]A;w13Hqg ŝcw1 bĸs ƝA;9 bĸ3q Ɲ1;w~- E[ĝ{qgЗA'ĥwRN]j/qP?KܩK;qĝtNƝ@'j)ԸSq'~;qĝ:ԸN)Ը׸SwЉ;qĝԸN܉K'ԥƝB;q'ĥwRN]j܉K'ĥw 5:qPNĝ2; |;%$_q;uq'/%ĝԸSwPNjܩK;wwRN]jK;y)qPNe(qPNĝ4ĝB;%7޸SwRN^lܩC;y)q'.(q'>ĝSwRNĝB;|w%ԏq.5ĝQ'5FSwcNܩK;uq'7~UNnܩMwkNI?Z'jI?Z'׷GK'ĥw=GĝԸSwk}NܩC;y?Z'ԥƝԸ?Z'ԥƝD:qPNĝD:q.5hSw։;ycwPNz։;uq'/%䥏:q'>ĝSwRNFSq'FS?ƝԸި/7ĝƝ\ߨwPN^oԉ;uq.5$zoԉ;uq.5F(q'QN:q~;y鹿Q'ĥwcNܩKܩC;y蹿Q'ԥƝtߨw 5$zߨwoܩK;uNƝD:q~;uq.57K;uq'c}NܩC;uq'/='ĝԸ'ĝOKoOԏ>'ĝD:qPN};y?Q'ԥƝ ոSָ uN]jܩK;y)q.5ԥƝDwҼĝwsN)Ը?P'ԥƝԸոN܉C;iuN]jK:q.5ԥƝƝ4}StNiI?N'jܩoq'/ĝԸSw㡏?vN8SwRN^zӉ;uq'8q'mN܉;uq'QN6SxN^oӉ;uq.%8SָSwkNܩK;y?N;w wcCظSq~&;y鱿X'jIX'ԥƝԸոN܉C'/'5ԥƝڟw'ĝDjItߟwRN]jK:q>q.5dSwۓןwO։;ycNܩKwgtN|'ĥwkNIt_w:Sws}NܩC;y_.;q;uq'/=ĝԸSq'd=ĝ4ԥƝ_wwcNܩK;uq'=K/q~;:;"-wiH˝Y"-wi3˝EZ,rg;Y"-wiF˝EZ rg;Y .wiH˝A\,rg;"-wiH˝A\,rg;Y",whs;rAX,rAX<˝aH˝y ;y;rAX,rAX<˝aH˝a ,wi ,w΃Y΃y;y;rAǑky;rg;rA"-w΃Y΃:˝aH˝a ,w"-w΃Y΃~_<˝}o;rA/wΟ |my;y;rg;rAX<˝A\<˝a ,wi ,wrg;rAX<˝EZ<˝aH˝a ,w"-w΃Y΃y;rg;rAX<˝EX<˝aH˝a ,w .w΃Y΃y;rg;rAX,rAX:!31 01L ǰ,cX?axc>axc=a8c}tq!L/q10wk1ǰuS1,(t2ǰrq 8qq ˸oüq 1?6Q8ee6a8YVq8M&a8Als˸fØq [8e>7K8e1Q85q8q8֋c/^CX.~CnkdcX-^6c,^c+ax׊c+a8e\*a8e)a8☏ߞ(9P1ǰN82n0M22ǰK,qODc$a8Ee$a89e\#Q8-q8!vq8Fc ^ c ^CXa|xcay8eav8FEY09,c^ƵƆcajxcQgxgcXGsi /p 1 /p! (.1L ǰ,ð2 0+ê2 ǰ)äp 0(žp sVMLj 愃1( bQĤBKSĨ0UaA ,0ma օư/ b`8ȅa 51 2 bfpC AL rl0a{AX190aØeZ"E*=,R|X0aA, A,R Hb:"A,"E bXH9bz E*$I,RX*Yb "E*9M,RXN bX>Hb Ţ7kN"EA)S,RRHbZ ƊEk+W bXbHb5hZ,RnHb Ej/^|Hb"AL0!baXHcB EJ21f,RXH=c"EJ4)j,RX1]c"EJ6(n,RļH}c"8q,RʱHc:"A,:u bXڱHcz E*<ưy,z(WE=)|,RX1c"ՏA?),RH d"A A,RF)dZ ƐEoH=d"EJ"D1,RY,2]d"EJ#F),RĝtN]jܩK;qĝtNƝ@'j)Sq?/qĝD˰>q.5ĝSwRNJܩC;uq'QN~\N]jܩK;y)q'/%jI %jIS?ƝSq'}}ĝwRN^JKwPNjK;qĝD;q'ĝԸSw%jI6Ct_ߨ/q~;uq'/%䥏:q>q'/7ĝuN]jܩK;uSܙ։;M6jI?Z'jI?Z'׷GK'ĥw=Gĝ:q'/Gĝ:ԸuN]jܩK;uN]jIw 5$zwGиSw}NܩK;Gĝ?Z;uq'GĝԸwwNK;uq.5$zoԉ;woԉ;#hܩK;ykNܩkK:q5FSwRNFSwRN^zoԉ;nuN:q~;y鹿Q'ĥwcNܩKܩC;y蹿Q'ԥƝtߨw 5$zߨwoܩK;uNƝD:q~;uq.57K;uq'c}NܩC;uq'/='ĝԸ'ĝOKoOԏ>'ĝD:qPN};y?Q'ԥƝ ոSָ uN]jܩK;y)q.5ԥƝDwҼĝwsN)Ը?P'ԥƝԸոN܉C;iuN]jK:q.5ԥƝƝ4}StNiI?N'jܩoq'/ĝԸSw㡏?vN8SwRN^zӉ;uq'8q'mN܉;uq'QN6SxN^oӉ;uq.%8SָSwRN]jܩK;y?N;w6qPNLwcN)Ը}NܩK;uq'/'q'NK_ NܩkܩK;y?Y'$O։;>'ո?Y'ԥƝԸuN}\N]jK:q.%'C?['%$zߟwdS^KS'$<ĝO܉K':趿N'䥏u:q.5:Swҿ]wwRN^zӉ;u)q'שqLN#zӉ;hܩK;y鵿N'5:SwPNzӗK_.w2z˝yes;ys;?Ѷ9˝9˝;ys;/,wr /wr煼9˝yes;qs;/,wr /w^hYA^ -˝9˝yes;yBr /wr/w~m3˝A\ .w=40A^ rg ;y3˝A\ r /wq3˝A\ .wqs; .wrg;9˝A\ rg;x3˝A\в ׎9˝A\ r /w+˝A\ .wq3˝ .wrg;cA^ rg;a FT櫸A^ rg;y3˝A\ r煖 .wq3˝ .wis; .wrg;9˝A\ zֲ9˝A\ r /wq3˝A\ .wq3˝ .wrg;?Zrg;9˝A\ rg;y3˝A\ .wq3˝ -wrgF-˝A\ .wq3˝ .wrg;A^ rg;/,wq3˝A\.wqs;7jY r /wq3˝A\ .wqs; .wrg;9˝1rg ;y3˝A\ .wq3˝Z; .w;A^ rg;9˝AZr .wp3豿Pr /wq3˝ -wps; .wrg;9˝A\ rg;/,wi3˝ .wqs;A\rg \ .wqs;iY r /wi3˝AZ .wqs; .wrg;cy!/wiY r /wq3˝ .wqs; .wrg;9˝A\ rgЯ˝`4_!r /wq3豿Xr /wq3˝ .wi2rg;A^ rg;y3H˝1\ X;A^ rg;9˝A\ r /wi3˝A\ .wq3˝ -wrg~˝A\в .wrg;A^ rg;x3˝AwYA^ rg;y3H˝1\ r/wq3˝A\ .wqs; .wrg ;Π,ww13qg ƝZ ƝA;wrĸ3q ǝA;w1ĸ3qgA;w)a9qg Ɲw1 bĸs ƝA;wrĸ3q ǝA;w0w),RĸHqg"ŝA;w( bYHqg ƝE;w) bYHqg"ŝE;>w1,RY3qg"ŝE;cw),R9qg"Hqg"ŝE;w|w) bYHqg ƝE;w1,BYHqg"ŝE;w&W),RĸHqg ƝE;w)丳Hqg"ŝA;w!aYHqg ƝE;w1,RYHqg"ŝE;w),RY3qg"ŝE;w(,RĸHqg΢rYHqg"ŝE;w1,RY3qg"ŝE;w),BøHqg"ŝA;w),RĸHqg ƝE;w) bYHq ǝE;w) RYHqg΢rY3qg"ŝE;w),RĸHqg"ŝA;w) RYs۟(Ɲ5;w),RĸHqg"ŝw),RY3qg"ŝA;w),Rĸqg ŝ5;w) bYHqg"ŝE;kw1,RYHqg"ŝE;w),RYs"ĝ5;w),RY3qg"ŝA;kwu;w),Rĸmw) bYFqgƝE;w1,RYHqg"ĝ5;1o"ŝA;w) bYM;w1,BYHqg"ŝE;w),RY3~qg"ŝE;w1,RY3qg"ŝE;8,RYHqg"ŝE;w!QY3qg"ŝA;w),RĸHqg ƝE;kw) bYHqg ƝE;w0,(,R9qg"ŝA;w),RHqgƝE;: bYHqg΢urY3qg"ŝE;w),RĸHqg"ŝA;kw)w*Ɲw^h;1sOŝwr9q煖sA;/ĝwr9qwq9q煖sٽ%E%KQH _ĺT7e/ s:"/q Ɲcw^h;9BK9q ǝw^h;9s -q ǝw^h;9ĸsOŝA;wrĸ3qgA;w03qg Ɲw1 bĸs ƝA;9 bĸ3q ǝA;wrĸ3qg1;w1w1 wrĸ3q ǝAo; ƝA;9 bĸ3q ǝA;wr3qgA;w13WqgqgA;w13m3q煖3qg Ɲw1 R9qg ƝA;9 bĸs ƝA;wrĸ3q ǝA;w13qg Ɲw0 b9qg ƝA;/ĝA;wrĸ3豿QK9qg Ɲw1 bĸs ƝA;8 bĸ3q ǝA;w13qgA;w1 b9qg ƝZ ƝA;wbø3q ǝAoĝA;9 bĸ3q ǝA;wrĸ3qgA;w1ĸ3?Q;cwrĸ3q ǝA;w1w1 bĸs ƝA;9 bĸ3q ǝA;cwbø3qgA;w13qgƝw1 bĸs ƝA;9 bĸ3Hqe3Hqg A;w=j;9 bĸsƝAr]A;w13m3q ǝA;cw)3qgA;w1 b9qgƝrsߦ% b9qg Ɲw1 bĸs ŝ1;wrĸ3q ǝA;w)w+wrĸ3qgA;w13qg ŝY ƝA;wrĸ3q ǝA;cw)3qgA;w='k;9 bĸs ŝ1;wrĸ3qgA;w)3h?ø3q煖3qgA;w1 b9qg ŝcw1 ˺ĝw1 b9qgƝA;8 bĸ3q ǝA;wrĸ3qgA;cw1D[t'kK~zPΠM^ĝtN]jܩK;%j};uq'.N)ԸĝB;w 5ďq'Sw҉;wwPN:q'.Sw҉;qĝԸSq'>ĝtN]jܩK;qĝtNƝ@'j)Sq?/qĝDð>q.5ĝSwRNJܩC;uq'QN~\N]jܩK;y)q'/%jI? %jIS?ƝSq'}}ĝwRN^JKwPNjK;qĝD;q'ĝԸSw%jI6Ct_ߨ/q~;uq'/%䥏:q>q'/7ĝuN]jܩK;uN]j~;U:qPN:qPN:q'/=Z?\:q'.?Z'ԥƝԸ^uNjK:q.5ԥƝD:q.5$z։;w։;#hܩK;y?Z'ԥƝDuN^Ɲ:Ը^uN]jK;ycN܉;q'/%ԥƝԸ豿Q'jIQ'ԏq.5Ƿ7K:q>q'/=7ĝ:ԸuN]jܩK;uN]jܩK;y鵿Q'$oԉ;>7ĝ4FNK:q>.q5FSw}N)Ը}Nܩoq.5$oԉ;w7ĝ4ԥƝԸި.%ԡƝD:q5ԥƝܟwRN'Gڟw?q'/==Q?^؟w'ĝB;7DSwRNz/TN}XNz/ԉ;uq.5ĝԸSwMIwnK:qPN@SwRN^zTN:q'5yԉ;uq'/=ĝԸSwswiN}Ӎ;uq'8SqƝtwRN]JCoӏ>l؉;tN]jܩK;y?N'ԥƝDtNƝ4m:q'~'ԥƝD;tN};y龿M'ԥƝtN}ZN]jKq:q.585i跸3_CظSq~&;y鱿X'jIX'ԥƝԸոN܉C'7'5ԥƝڟw'ĝDjItߟwRN]jK:q>q.5dSwۓןwO։;ycNܩKdh?_w>q'.^tN:>ĝԸtNjKwYOܩkܩK;y鹿N'ԥĝ˝EXrg;Y(/wqH˝EZ rg;~]Nrg;Y .w폓;",wh˝1\,rg;Y"-wi3˝EXr .w˝EZ rg;"-wiH˝A\,rg;"-wi3˝EZ,rg;c~_C .wiH˝EZ rg;΢ъY1^,rg;"-wi3˝EXrg;cY"-wqH˝EZ,rg;Y .waF˝EZ rg;Y .wi˝1\,hcY"-wqH˝EZ,rg;Y.wi_.;Y"-wq˝5Z,rg ;Y"-wqH˝EZ rg;Y -whH˝Z;n׶2N;?Rv^aeu^Y?f:/2n:/,Eet^=Yr˸漌c˸4N9/29?q^eXq^Y8Ἄ O߼˸4Kyqyf 7/n26?Rm^el^?f+60^25ǰXs [8RsC˸Ls +14/Fs 1,40м13ǰμ1l30223ǰ,220&s̋ s {OcXc`ǰżS1,10ļ;1oۙ100¼1L0ǰ2/02/Ǩr 8r ˸s[_m.狘\^c[^ƹ֖c[akir K1 -ǰ31,(1L,ǰ2+0ú2+ǰôr 8îr ˸s[ä2.*0Þr s˰˜r [8Òr C1(?͒QaE9ePaB9q?9֓q<9cXN^vcM^FcLa2ycLa/9e\Ka,9eJa)9vq&9Ffi$0Br ˰a8e>a8Vq8F&a8c;^ƵƎc:^Ʃc:axgcX9a8e8a8e7a8uōdi(m²2ǰkìq 8jæq ˰h qO69e\3a8-e2y[%dÎ2ǨbˆqƋ8aÂq ˸_|q 1/vq!,?!Y1/hq 1L/bq 10Wk1UT2.0TN2ǰRHqŋ$?s/>q 10N1LǰL10K*,Q6c$axc#ax׈c#a8F)E\"a8e!a86q8q8Fևc^cXaxxwcQuxGc#Lǰ84Kp8憗qm8c^ƥc^ęVc\81p ˸/p1 /p 1, 0,1 ǰ*1l 1~ b8c A, 9 bBK 2dCA,!cB2m2= A,"D(2UdA"F=7jI# b:rȘD9a!9ȉd F\I1 b'PBK)T2dD-ds L b2fr U1&a8r2 A'XOr>~2He AN(P1 bE9e; \R1 bK2KM2= A,*T2UeA*cVuL+ b\ĺrʠqZ Xadr3 vA - bj2 זA-c[^em2 GA.]rw2eAn/_ư b~9e ` b sG\!t9%fS A1 bs AL2d^f2Xe1 ؟% b4s ř13gq@3 'Al4iL3fCA.5jư b9ȵfs A 6 bfs͠ vZ AL7 bz3 A 8TpqĆ3_.RqrĎ3! AJ9cr)39g{ \t1 b9Qg fA:1aĴmmgo7q.ƝA_A'ĥwRN]j/qP?KܩK;qĝtNƝ@'j)ԸSq'~;qĝ:ԸN)Ը׸SwЉ;qĝԸN܉K'ԥƝB;q'ĥwRN]H܉K'ĥw 5:qPNĝ2; |;%$q;uq'/%ĝԸSwPNjܩK;wwRN]jK;y)qPNa(qPNĝ4ĝB;%7޸SwRN^SwPN^J܉K'$J܉;q'/%ԥƝԸ(qPN;F};#hܩK;y)q'/}oԉ;q;y鵿Q'ԥĝ<ߨwRN]jIߨwRN^zFw^uN:qPN:q'/=Z?\:q'.?Z'ԥƝԸ^uNjK:q.5ԥƝD:q.GĝDuN:q~;uq'/GĝԸ}NKոSwkNܩK;y)q'/}։;q'ĝԸSw=7ĝB;7ĝ4ԥƝFx鵿Q'5FSw}NܩK;uq'cNܩK;uq'/7ĝD:q'FS?Ɲߨw҉;y鱿Q'%ԡƝ<ߨwRN^oԉ;woԉ;>7ĝD:qPNFS?ƝԸSwӥĝ:Ը>Q'ԡƝԸuN]jItD^uN|''KuNDSqƝ؟wRN]JCjܩ{OC:q.5ԥƝSwRN;i^uN}ߍ;y?P'jItwRN]jKj܉C'ġƝ4:q.5@SwRN^zTN>Mܩoq4$zw 57޸tN]jܩK;yqǟ;q'}NܩK;uq'/=ĝԸ}}N Ը涿M'ĝԸ(q'sNܩoq'/ĝԸSwcNܩOkܩK;y?N'ԥƝƝ2;w+w 5Ϥq'/=ĝB;ĝԸSw}wЉ;qĝĝƝԸ^uNdc}^;uN]jܩK:q'dSwsNܩK;yI|;'ĝ?Y'ԥgk}NIyӉ;MNKu:q'mNKtN]jKu:q5'5ԥƝ_wRNSNƝDG_wиSwkNܩkKu:q.%ԡƝ<\_/qĝ?\!|#rg;y3˝A\ r煖 .wq3˝ .wrg;A\rg;y3˝AZr /wq3˝ .wqs;Π-wrg;9˝A\ rg ;/,wiH˝A\,rg;",wh3˝EZ,rg;Y"-wi3˝EZ,rg;Y"-wqH˝EZ rg;Y.wiH˝YtrgmGEZ rg;΢? Y .wiH˝EZ rg;",whH˝A\,rg;Yt(-w~AuTWqH˝EZ rg;YA^,rg;"-wa3˝EZ,z쏖;Y"-wqH˝EZ,rg;Y .wiH˝EZ rg;Y?Z\rg;Y"-wis;Y .wiH˝EZ rg;"-wiH˝A\,rg;cY"-wi3˝EZ,rg;Y"-wqH˝EZ,rg;YA^,ߔ\"-wiF˝EZ rgFyH˝A\,rg;"-wi3˝EZ,rg;Y"-wi?Q\rg;Y .wiH˝EZ"-wicY"-wqH˝Erg;Y -whH˝EZ rg;"-waF˝A\,rg;"-wi3˝EZ,rg;x˝5Z rg;Y .wiH˝AZ;+"-wi3˝Eo"-wq˝5Z,rg ;Y .wiH˝EZ rg;k9˝5mrg;Y"-wqH˝EZ,rg;Y"-wqH˝EZ rg;Θ_Wr3˝EZ,rg;Y"-wqH˝EZ,r/wiH˝EZ rg;",wh˝1\,rg;Y"-wi3˝EZ,rg;n"-wqH˝EZ,rg;Y.wgYA^,rg;Y"-wi3˝EZ,rg ;n"-wqH˝EZ rg;kY.wiH˝EZ rg;"-wiH˝AZrg;/,wjA;/ĝwr9q'A;9BK9q ǝZA;9B;8BK9q Ɲcw^h;9BK9q ǝw^h;9s -q ǝw^h;9>1q' ƝA;9 bĸ3q ǝA;cwrĸ3qgA;w1 b9qg Ɲw1 bĸs ƝA;9 bĸ3HqǝA;w^h;wA;9 bĸsΠ7O Ɲw1 bĸs ƝA;9 Rø3q ǝA;wrtߨ% sqg Ɲw1 bĸBKĸ3qgA;w)3qgcs ƝA;9 bĸ3q ǝA;wrĸ3qgA;w1 b9qg Ɲw1 bĸBKĸ3q ǝA;w13qgA;w1 b9qg ŝcw1 bĸs ƝA;wrĸ3q ǝA;w13qg -qg ƝA;1aĸsΠZ Ɲw1 bĸs ƝA;9 bĸ3q ǝA;wbs۟(ǝ1;9 bĸs ƝA;w^h;w1 b9qg Ɲw1 zOwr3q Ɲ1;w13qgA;w)a9qg ƝAĝA;wrĸ3qg,qgƝw1 bĸs ƝA;1a/E03qgA;i;wr3qg1;w13qg Ɲw)ay!ǝ1mZ Ɲw1 b9qg ƝA;9 Rø3q ǝA;wrĸ3qg1;_y-̗13qg Ɲw1 b9qg ƝA;/ĝA;w13qgA;w0 R9qg Ɲw1 bĸs ƝA;9 Rø3q ǝA;w}Ow1 R9qg~qg -qg Ɲw1 bĸs ƝA;8 b/~u;9 bĸs ŝ1;wqĸ3qgA;w13qg Ɲw0 b37q<w4 ԸyA'ĥwRN]j/qP?KܩK;qĝtNƝ@'j)ԸSq'~;qĝ:ԸN)Ը׸SwЉ;qĝԸN܉K'ԥƝB;q'ĥwRN]j܉K'ĥw 5:qPNĝ2; |;%$z?q.5ĝSwRNJܩC;uq'QN~\N]jܩK;y)q'/}L8#Ը(&J)Ը(q~;y)qPNF};7ԥƝ&ԡƝ:Ըw҉;wNK;uq.5$J)Ըm·达Q_NwRN^JKuN}\N^zoԉ;u)q'=7ĝԸSw=7ĝԸuE?ĝƝ:ݸ?Z'$zwۣåw҉;uN]jܩK;y>Z'ԡƝwRN]jIwRNhSq'hS?ƝԸuN]jI?Z'䥏jܩC;y?Z'ԥƝ>GĝwRN]jܩK;uNƝDuNwRN^z|{~ߨwws}NܩC;y龿Q'ԥƝԸ豿Q'ԥƝԸ^uNFcNܩAN^zoԉ;qĝߨwwPNzoԉ;uq'/7ĝB;7ĝwRNFSq'mNܩAN]jܩK;yRNjIXwPN]jK:q.5${~D:q'w㥏:q'}N)ԸSxN^zOԉ;uq.%B5ԇ5BSwRN^JܩK;uq'ĝ4:qƝw 5$ԉ;uq.5@5ġwPN@SwcNܩK;uq'/=q'm&7ݸSgwӉ;woKq:q.5ԥĝ<8x?N'ԥƝԸtN]jI>N'jIsߦwpN]jI(qPN};y龿M'ԥƝtN}ZN]jKq:q.otNq:q'/wwvNLwcN)Ը}NܩK;uq'/'q'NKo NܩkܩK;y?Y'$O։;>'ո?Y'ԥƝԸw}O։;uq'/='ĝߞlė}NKuN]z}}/'ĝD:;qĝ_wĝN'ԥƝ\_wPN^zN}\N]jKu:q.%:5iI7YDu:q~;uq'/ĝƝ_wRNjCuw~Kå?ŝw^h;9sOŝwr9q煖sA;/ĝwr9qwq9q煖sA;8wr9q煖sA;9wr9q ǝZA;9wr9qǝh;w13qg Ɲw)a9qg ƝA;9 bĸ3q ǝA;wrĸ3qgA;w13qg ŝcw1 by% b?13qgA;w>A;wrĸ3qgA;w13Hqg Ɲw1 b9qgm3*ǝA;wrĸ3qg -qg ƝA;9 bs ƝA;wrĸ3q ǝA;w13qgA;w1 b9qg ƝA;1aĸs ƝAA;/ĝA;wrĸ3qgA;w13qg Ɲw1 R9qg ƝA;9 bĸ3q ǝA;wrĸ3qgA;w1w1 bĸsƝA;9 zߨ% b9qg ƝA;9 bĸs ƝA;wrĸ3q Ɲ1røs ƝA;9 bĸ3q煖3qg Ɲw1 b9qg ƝA;9 RøsƝA;wrĸ3q ǝA;w03qg Ɲw1 b9qgΠ@9w)a9qg ƝA;9 bĸsƝAr]A;w13m3q ǝA;cw)3qgA;w1 b9qgƝrsߦ% b9qg Ɲw1 bĸs ŝ1;wrĸ3q ǝA;w)3/|A;w1 b9qg Ɲw1 b2Kĸ3qgA;w13Hqgcwqĸ3q ǝA;w13qgA;w0 b9qg ƝA;9 bsΠ ƝZ ƝA;9 bĸ3q ǝA;wqĸ3_.wrĸ3q ǝA;cw)3qg Ɲw1 b9qg ƝA;1aĸmqgo(hPΟENܩK;uqĝB;/q.5ĥw҉;wSqPNƝ4ġwPN\:qPN|\Nj܉C'ĥwRN\:q'.Sw 5ǝNܩK;uq'.N)ԸĝB;w4'%җgƝԸwRN]jܩK;y(q5ԥƝD;q;uq.5ĝSq'Q0LSq'QNwRNƝDwoܩK;y)q'/MܩC;uq'/%ĥw%ǝwRN]jISq'}}ĝ4ԥƝ>7ĝƝߨwRNzoԉ;uq.5$zoԉ;uq'/=7ĝBm9PGĝB;GĝhpĝtNhSwRN^z։;uq'/=GĝԸSw=GĝԸ?Z'jI?Z'ԏ:q'/GĝԸ}NKոSwkNܩK;y1C/}։;q'ĝԸSw=7ĝB;7ĝ4ԥƝFx鵿Q'5FSw}NܩK;uq'cNܩK;uq'/7ĝD:q'FS?Ɲߨw҉;y鱿Q'%ԡƝ<ߨwRN^oԉ;woԉ;7ԥƝD:qPNFS?ƝԸSwӥĝ:Ը>Q'ԡƝԸuN]jItD^uN|''KuNDSqƝ؟wRN]JCjܩkC:q.5ԥƝS_wMIwnK:qPN@SwRN^zTN:q'5yԉ;uq'/=ĝԸSwswiN}Ӎ;uq'8SqƝtwRN]JCoӏ>l؉;tN]jܩK;y?N'ԥƝDtNƝ4m:q'~'ԥƝD;tN};y龿M'ԥƝtN}ZN]jKq:q.585iI?oĝĝݸS?Ɲ_w 5$z_wRN]jKj܉C'ġwswwRN^zO։;nuNz5$O։;uq.5dS׸Sws'q'ݿ=Y?z:/q'd>'ĝ?^zO։;3u:q'w҉;y鵿N'$Ӊ;ycNܩK;y鹾N'ԡƝ/~ĝƝԸtN]JCuj)ӸotNwRN^zӉ;q;y鱿N'ԥĝ:Ը%җK?ĝ c;9wr9q ǝh;9s -q ǝw^h;9s 9s -q ǝwqy%s !@mq ǝw^h;9s -q ǝw^h;9ĸsOŝA;wrĸ3qgA;w03qg Ɲw1 bĸs ƝA;9 bĸ3q ǝA;wrĸ3qg1;w1w1 wrĸ3q ǝAo; ƝA;9 bĸ3q ǝA;wr3qgA;w13趿QKĸs_Ɲ*ƝA;9 bĸ3q煖3qg Ɲw1 R9qg ƝA;9 bĸs ƝA;wrĸ3q ƝA;wrĸ3qgA;cw13qg ƝZ ƝA;9 ow13qgA;w1 b9qg ŝcw1 bĸs ƝA;wrĸ3q ǝA;w13qg -qg ƝA;1aĸsΠZ Ɲw1 bĸs ƝA;9 bĸ3q ǝA;wbs۟(ǝ1;9 bĸs ƝA;w^h;w1 b9qg Ɲw1 bĸs ŝ1;1aĸ3q ǝA;wz0 b3q ǝA;w13qgA;w1 Ry% Røs ƝA;wrĸ3q Ɲ1;~Ɲw1 b9qg8-qgA;w0 R9qg Ɲw1 bĸs ŝ1;/3涿MKĸs ƝA;9 bĸ3q ǝA;cw13qgA;w1 R9qg_Ɲ2Ɲw1 bĸs ƝA;9 bĸ3Hqe3qg Ɲw1 b9qgƝA;8 bĸsΠd-qgA;w13Hqg Ɲw1 bĸs ƝA;8 0 by% bĸs ƝA;wrĸ3HqǝA;.q ǝA;wr3qg1;w1 b9qg Ɲw1 bĸsƝA;?w*|/qOA;tN\:q.5ԥƝ_w 5ĝԸN܉K'j tNƝB;wGиNܩC;qĝB;q;uq'NܩK;qĝhܩK;wN܉K'ԥƝԸN܉K'j tNƝB;eww~KI\N]jK;y)q.5ԥĝGĝwRN]jܩK;uNƝDuNwRN^z|{~ߨwws}NܩC;y龿Q'ԥƝԸ豿Q'ԥƝԸ^uNFcNܩAN^zoԉ;qĝߨwwPNzoԉ;uq'/7ĝB;7ĝwRNFSq'mNܩAN]jܩK;yRNjIXwPN]jK:q.5${~D:q'w㥏:q'}N)ԸSxN^zOԉ;uq.%B5ԇ5BSwRN^JܩK;uq_Ɲ4:qƝw 5$ԉ;uq.5@5ġwPN@SwcNܩK;uq'/=q'm&7ݸSgwӉ;woKq:q.5ԥĝ<8x?N'ԥƝԸtN]jI>N'jIsߦwpN]jI蹿M'7޸tN]jܩK;y?N'ԧ5ԥƝwRN^zSNƝD[ܙ/Kܩۍ;3iK:qPN:q.5ԥƝtߟƝ8tN:q'/=18q>q.5d>Y'$XWNdSwRN^zO։;q;uq'/='ĝߞlė}NKuN]z}}/'ĝD:;qĝ_wĝN'ԥƝ\_wPN^zN}\N]jKu:q.%:5iI7YDu:q~;uq'/ĝƝ_wRNjCuw~Kå;ǶA^ rg;ye3˝A\ r /wq3˝ .wqs;cA^ rg;c9˝A\ r /wq3˝A\ .wq3˝ .wrg; -˝EZ,rg;n)rg;Y-wqH˝EZ,rg;Y"-wqH˝EZ rg;Y .wiH˝A\,rg;"-wis;YQ;Y"-wqB"-wi3˝EZ,z_U .wiH˝A\,rg;"-wi3˝Erg;n_"-wqH˝EZ,r /wiH˝EZ rg;"-wiH˝A\,rg;Y"-wi3˝EZ,rg;Y"-wqH˝EZ,rg;kY .wiH˝EZ"-wi3˝Erg;Y"-wqH˝EZ,rg;Y.wiH˝EZ rg; .wiH˝A\,rg;"-wis;Y"-wiF˝EZ rgFyH˝A\,rg;"-wi3˝EZ,rg;Y"-w=Ys۟(.wh3˝EZ,rg;Y"-wrg;Y .wiH˝A\,rg;",wh3H˝5Z,rg;Y"-wqH˝EXrg;Y"-wqH˝EZ rg;Y1^,rg;Y"-wi3˝EZ,rg;kYrB;Y"-wqmY .wa恡",wpH˝EZ rg;Y .waF˝Ys&/wi3˝EZ,rg;Y"-wq˝5Z,rg;Y .wiH˝EXrg-w˴rg;Y .wiH˝A\,rg;9˝EZ,rg;Y"-wq˝5Z,rg ;Y .wiH˝EZ rg;",whH˝A\,rg;"-wa3˝E:ys;Y .wiH˝EZ rg;"-werg;Y .waF˝EXrg;Y .wiH˝A\,rg;-wiBrgo;5BK9q ǝw~-sA;/ĝwry%sA;/sA;/ĝwb9q煖sA;/ĝwr9q煖sA;9wr9q煖sA;8D[ĸ3q ǝA;w13Hqg A;w1 b9qg ƝA;9 bĸs ƝA;wrĸ3q ǝA;w)3qg -qg 8q ǝA;wr bĸs ƝA;wrĸ3q ǝA;cw13qgAOƝAZ Ɲw~A?*Ɲw1 bĸBKĸ3qgA;w)3qg Ɲw1 b9qg ƝA;9 bĸs ƝA;wrĸ3qgA;cw13qg ƝZ ƝA;9 bĸ3q ǝA;wrĸ3qgA;w)3qg Ɲw1 bĸs ƝA;9 ow13qg -qg ƝA;1aĸsΠZ Ɲw1 bĸs ƝA;9 bĸ3q ǝA;wz*OƝw1 b9qg ƝA;/ĝA;w13qgA;w1 b9qgƝw0 bĸs ƝA;9 b3q ǝA;w13qgA;w1 Ry% RøsΠ@-qgA;w1ĸ3qg\s ƝA;9 z% b9qgƝA;8 bĸs ƝA;wr3qwi;wrĸ3q ǝA;w13Hqg Ɲw1 b9qg ƝA;8 ˸3_Ƹs ƝA;wrĸ3q ǝA;w)w1 bĸs ƝA;9 Rø3HqǝA;wrĸ3qgA;w13Hqg Ɲw1 bĸs ƝA;8 0 by% bĸsΠ:-qgA;w)3qgп]%3qgA;w0 R9qg ƝA;9 bĸs ƝA;wbø3q'Π_ŝwry%sA;?wr9q ǝZA;9wr9q ǝr9q ǝZA;1BK9q ǝZA;9BK9q ǝw^h;9BK9q Ɲcw~- bĸs ƝA;wr3q ǝA;w13qg Ɲw1 b9qg ƝA;9 bĸsΠ~9qg1;w1w1 wrĸ3q ǝAo; ƝA;9 bĸ3q ǝA;wr3qgA;w13趿QKĸsΠ;U;9 bĸ3q煖3qg Ɲw1 R9qg ƝA;9 bĸs ƝA;wrĸ3q ǝA;w13qg Ɲw0 b9qg ƝA;/ĝA;wrĸ3qgA;w13qg Ɲw1 R9qg ƝA;9 bĸ3q ǝA;wrtߨ% b9qg ƝZ ƝA;wbø3q ǝAoĝA;9 bĸ3q ǝA;wrĸ3qgA;w1ĸ3?Q;cwrĸ3q ǝA;w1w1 z~{~ĸs ƝA;9 bĸ3q ǝA;cwbø3qgA;w13qgƝw1 bĸs ƝA;9 bĸ3Hqe3Hqg A;nĝA;9 bĸsƝAr]A;w13m3q ǝA;cw)3qgA;w1 b9qgƝrsߦ% b9qg Ɲw1 bĸs ŝ1;wrĸ3q ǝA;w)3/|A;w1 b9qg Ɲw1 b2Kĸ3wrĸ3q ǝA;cw)3qgA;w1 b9qg Ɲw)aĸs ƝA;wrĸ3HqǝAƝA;/ĝA;wrĸ3qgA;w)3qgп]%3qgA;w0 R9qg ƝA;9 bĸs ƝA;wbø3q'ΠĝKKv:qgorЉ;qĝԸSw~K)ԸwRN\:q'.Sq'Љ;w 5j܉AN:q5ĥw 55ԡƝ8tN\:q.5ĥw҉;uqPN|܉;qĝLܩK;qĝtNƝ@'j)Sq?/qĝDð>q.5ĝSwRNJܩC;uq'QN~\N]jܩK;y)q'/%jI? %jIS?ƝSq'}}ĝwRN^JKwPNjK;qĝD;q'ĝԸSw%jI6Ct_ߨ/q~;uq'/%䥏:q>q'/7ĝuN]jܩK;uN]jK:qPN_ߨ~sNI?Z'׷GK'ĥw=GĝԸSwk}NܩC;y?Z'ԥƝԸ?Z'ԥƝD:qPN:q~;uq'/GĝԸ}NKոSwkNܩK;y)q'/}։;q'ĝԸSw=7ĝB;7ĝ4ԥƝFx鵿Q'5FSw}NܩK;uq'cNܩK;uq'/7ĝD:q'FS?Ɲߨw҉;y鱿Q'%ԡƝ<ߨwRN^oԉ;woԉ;7ԥƝD:qPNFS?ƝԸSwӥĝ:Ը>Q'ԡƝԸuN]jItD^uN|''KuNDSqƝ؟wRN]JCjܩkC:q.5ԥƝSwRN;i^uN}ߍ;y?P'jItwRN]jKj܉C'ġƝ4:q.5@SwRN^zTN>Mܩoq4$zw 57޸tN]jܩK;yqǟ;q'}NܩKӉ;y?N'ԥƝDtNƝ4m:q'~'ԥƝD;tN};y龿M'ԥƝtN}ZN]jKq:q.585iI?oĝĝݸS?Ɲ_w 5$z_wRN]jKj܉C'ġwswwRN^zO։;nuNz5$O։;uq.5dS׸SwsNܩK;yI|;'ĝ?Y'ԥgk}NIyӉ;MNKu:q'mNKtN]jKu:q5'5ԥƝ_wRNSNƝDG_wиSwkNܩkKu:q.%ԡƝ<\_/qĝ?\!вA^ rg;ye3˝A\ r /wq3˝ .wqs;cA^ rg;c9˝A\ r /wq3˝A\ .w=A^ rg;y3˝AZr煖"-wi3˝EZ,rg;Y-wqH˝EZ,rg;Y"-wqH˝EZ rg;Y .wiH˝A/-wiH˝EXrg;9˝EZ,ҿH˝A\,rg;YW;"-wiH˝A\,rg;Y-wi3˝EZ,rg;n"-wq诖;UZ rg;YA^,rgs"-wa3˝EZ,rg;Y"-wqH˝EZ,rg;Y .wiH˝EZ rg;Y -whH˝A\,BY"-wrg;"-wiH˝A\,rg;Y"-wi3˝EZ,rg ;Y"-wqH˝EZ,rg;YΠ;Y"-wqH˝EZ"-wiH˝AZrg;YQ^,rg;Y"-wqH˝EZ rg;Y .wiH˝AZO;k"-wi3˝EZ,rg;yH˝EO΋"-wi3˝Erg;Y-wiF˝EZ,rg;Y .wi˝5Z rg;Y .wiH˝A\,rg;9˝EXrg;Y"-wqH˝EZ rg;~]Nrg;Y .w폓;",wh˝1\,rg;^Z,rg;",whs;kn"-wqH˝EZ rg;Y .waF˝EZ rg;΢8y˝1\,~;Y"-wi3˝EZ,rg;Y",wrg;Y .wiH˝A\,rg;"-wi3˝EZ,rg;Y"-wq˝5Z,rg;Y"-wqH˝EXrg~F˝EZ"-wi3˝EZ,rg;Y",wpH˝EwY"-wi3˝EXrg;cY"-wi3˝EZ,rgK˝EZ,rg;Y"-w^hY,rwry%sA;?wr9q ǝZA;9wr9q ǝr9q ǝZA;1BK9q ǝZA;9BK9q ǝw^h;9BK9Ϸ!Ɲcw~- bĸs ƝA;wr3q ǝA;w13qg Ɲw1 b9qg ƝA;9 bĸs ƝA;wqĸ3q煖3qg@ĸs ƝA;9 z1 b9qg ƝA;9 bĸs ŝ1;wrĸ3q ǝAZ Ɲww~A?U;w1 by% bĸ3q ǝA;wqĸ3qgA;w13qg Ɲw1 b9qg ƝA;9 b%ĸ3qgA;n*w1w1 b9qg ƝA;9 bĸs ƝA;wrĸ3HqǝA;w13qg Ɲw1 b9qg ƝA;9 bĸBKĸ3qgA;cw13m3q ǝA;w13qgA;w1 b9qg Ɲw'qg A;w13qg ƝZ ƝA;wrĸ3q ǝAZ Ɲw)a9qg ƝA;9 bĸs ƝA;cwrĸ3?PK9qg Ɲw1 b2K3q ǝA;w13qgA;cwu;9 bĸsΠqZ Ɲw)as ƝA;9 bĸ3q ǝA;cw^qgm3q ǝA;wrĸ3qgA;w0 b9qg Ɲw1 bsΠ;e;9 bĸ3q ǝA;wrĸ3qg,qg ƝA;9 bĸs ŝ1;wqĸ3q ǝA;w13qgA;w0 b9qg ƝA;9 bsΠ ƝZ ƝA;9 bĸ3q ǝA;wqĸ3_.wrĸ3q ǝA;cw)3qg Ɲw1 b9qg ƝA;1aĸmqgoΏϓKĸs ƝA;w^h;w1 b9qg Ɲw1 bĸsƝA;9 b3q ǝA;wrĸ3qgA;w1 b9qg Ɲw1 RøBKYHqg"ŝE;w1,BY3qg"ŝE;w),zo{w1,RY3qg"ŝE;w),RĸHqg"ĝ1;w)丳Hqg@\3qg"ŝA;w>E;w1,RYHqg"ŝE;w!QY3qg"ŝA;n帳Hqg"ŝEww),RYs"ŝE;w1,RY3qg"ŝE;w),RĸHqg"ŝA;w) bYHqg ƝE;3Hqg"ŝA;w),R9qg"ŝA;w),RĸHqg ƝE;w) bYqg "ŝE;w1,RYHqg"ŝE;w),RY3qg"ŝw),RY3Hqg"ŝA;7qg ƝE;w) bYHqg"ŝE;w1,RY3Hqgmw( bYHqgЇ"ŝE;wrYHqg ƝE;w1,RYHqg"ĝ5;w(,RY3qg"ŝA;w!QĸHqgsw1,RY3qg"ŝE;8,BY3qg"ŝE;w),RFqgѯ\W3qg"ŝA;qg ƝE;kw!aYHqg"ŝE;w1,BYsΚ69,RĸHqg ƝE;w) bYFqg ƝE;w1,RYqg _~! ƝE;w) bYHqgЇ"ŝE;wqYHqg ƝE;w1,BYqg "ŝE;w),RY3qg"ŝA;w(,RĸHqg"ŝA;w!aYQYs"ŝE;w),RY3qg"ĝ1;weuĸHqg ƝE;kw!aYHqg ƝE;w1,RYHqgŝE;/ĝE;o%|%~?=qg&/ѸNܩK;uqĝB;/q.5ĥw҉;wSqPNƝ4ġwPN\:qPN|\Nj܉C'ĥwRN\:q'.Sw 5ǝNܩK;uq'.N)ԸĝB;w4'%җ(5ԥƝwRN]JC;uq.5$JɏKܩK;uq'/%ĝB;aĝB;wGиw 5$oԗSxN]jK;yiNjܩC;y)q'.(q'>ĝSwRNĝB;|%ԏq.5ĝQ'5FSwcNܩK;uq'sNܩK;y鱿Q'jIQ'_S9_:q~&;y҉;qĝKJ5#=%/X9E0f`C*s$z։;uq.5hSwsNܩK;uq'kNܩK;uNƝD:q~;uq'/=GĝԸ?Z'jܩC;y?Z'ԥĝ>GĝwRN]jܩK;N)Ը辿Q'ԏq.57K:q>q'/7ĝ:ԸuN]jܩK;uN]jܩK;y齿Q'$oԉ;>7ĝ4FNK:q>.q5FSwcN)Ը辿Q'7޸Sw=7ĝB;nuNwRN]jKooOwPNDSwRN^zOԉ;u?Q'$zOԉ;񍟸^ߞ/}Oԉ;uNƝwsNܩK;u)q'q>q'=ĝԸSwRN]jܩK;&yԉ;}7@Sq'cNܩK;u\Ҹ>ĝ8Ը?P'ԥƝwRN]jKjIsߧ;M7ԙƝDq:qPN};y?N'ԥƝ}=`'$zӉ;uq.58Swĝ@;intNNܩK;wĝwcNܩK;u)q'=ĝƝԸtN]jKqj)ӸoqgrqPNLwsN)Ը辿X'ԥƝոN܉C'7'5ԥƝޟw'ĝDnI؟wRN]jK:q>q.5dSwۓ_['%$O։;ysNܩKdh?_w>q'.tN:>ĝԸ^tNjKwYOܩkܩK;y鵿N'ԥĝ<_Ɲ2;&(q':Sw{NܩkKu:q.%ԡƝ¿+˝A\ .wq3˝ .wrg;cA^ rg;y3趿Qrg;y3˝Ams˝A\ rg;/,wq3˝A\ .wis; .wrg;9˝A\ rg;y3˝A\ .wq3˝ .wqs;cA^ rg;ye3˝A\ .wq3˝ .wrg;A^ rg;x3˝A\ r /wq3˝A\ .wqs; .wrg;ye3˝A\ r .wp3˝Qrg;y3˝A\ r /wq3˝ .wqs;A\O;c9˝A\ zOԲ .wqBrg;A^ rg;y3˝A\ r /wi3˝ .wqs;A^ rg;c9˝A\ rg;y3˝A\Π@-˝AZ̲.wrg;A^ rg;q3˝A/'Dps;A^ e3˝.wis;A^ rg;9˝AZr煼sߦe3˝Π6-˝A\ rg;y3H˝1\ r /wq3˝ .wis|;y3˝A\ r /wq3˝ .wi2rg;A^ rg;y3>Yrg;x3˝A\ .wq3˝ .wrg;cA^ rg;9˝A\ r/wg -˝A\ r /wq3˝A\ .wis;/~uY .wiY rg ;9˝A\ rg;y3˝A\ .wq3˝ .wArg?,w~?~qg ƝE;w)丳Hqg"ŝA;w) bYHqg ŝ5;w1,RYFqg"ŝE;w),RY3qg"ŝE;w),RĸHqgŝw ĝE;By΃w)<ĝE;By΃w)<qA;BY ĝ!,Ry΃wHqA;BY ĝ!9eOa;9q89eq596cL^cKa.yגcKa+ycXJa(9eIa%94cHa!9eGa9ueGX_%22#Wg"ǰ1l"01 "ǰ2!02L!G!vq9Fq9 c@1K8֏c?^cX>^vc=axGc<axC#/74:著uG]jK uG]jKy齿Q'$o >7$F NK:!>.%5FRZCcN) 辿Q'7&RE=7dB"nuHFRH]jKooOGPHDBRHRI^zOԩ$u$#zO)%T^ߞ/}Oԩ%uzI[LsN3K&u)$ݤ>$=ꤓvROk~KORI (iuJ}m(y?PjFIRRKJ]jJKjLCġ4:A.@RURJ^zTJ>MYoiδ$ө+Wo_Kq:.5ԥ4<8x;%cNhK--u%/=Ėڒ>NjpIsߦ\pK]jtI赿M7tK]j{K/y?N'ԧԥ`RL^zS+Lf~0? 1ZbgubL֘D:=.5ԥ؟68tL:U&/18]>a.d6>Y$\wLdBShRM^zO֩4q4u&/'딚Tߞ:/&}NKuM]z}/'DD:n 7q锛_nԛNԥZ_pPN^z*N}\3N]jKu:%.%:5iI7YDu:A~-:uI'/DV_uRNjCuv~Kå;?wm*2[<ĵ Eq/B`d]A f Fq52 .Gq:r#c8A ~d$c 9Aܐ ziDrW$8# Id$%1A^ d$yP2A䅖Q"JiV2E,Ҳd%-YqKq^HE,d'&1Y"LqfH;E d&5Y MinH{A,d&'9"Nivrw'4f2Y ndi$H+A,Nf29SEʬXfZ,\f24"Mfi33H5Z,u6BA,rf3Y?N^,|f3"LhpCH#EZ fv44Y% NiaKFcYs&iiP3E,ҦfG5YY"jqX˚5,Ҷf5Yy ki`H E،BlqfH;E,f6Y_,minH{E"MnisHA\,fv78YMoa{3EZ,f74Y"MpqH#EZ gv8k4Y% NqiHcEZ g80E΢6949ȫE,.g?e"Msi3EZ,YƝD:q.5ԥƝܟwwRN^zO։;u)q'==Y?zu_Nd>'ĝ?^z:q'~湿N'7}N\:q'/%ԥƝDu:q'/}Ӊ;uq'/ĝ:ԸﲞS׸SwkNܩK;y豿N;ew}MsNܩ@N]jKu:q>q'/=ĝSwk}ĝ_wp釸^;9˝A\ rg;/,wq3˝A\ .wqs; .wrg ;9˝A\ rg ;y3˝A\ .wq3˝ .wqs;A^ rg;cyeH˝EZ rg;YΠ-waF˝A\,rg;"-wiH˝A\,rg;Y"-wi3˝EZ,rg;Y",wpH˝E/'yH˝Ei3˝EZ,rg;>_U"-wqH˝EZ,rg;Y .waF˝EZ rg;΢FyH˝A\,rg;Y;UZ,r /wiH˝EZ rg;lrg;"-wi3˝EZ,rg;Y"-wqH˝EZ,rg;Y"-wiF˝EZ rg;YA^,rg;Y"-wi3C˝EZ,rg;Y"-wq辿Q\rg;Y .wiH˝EZ rg;"-wiH˝A\,rgkY"-wi3H˝5Z,rg;>7˝EZ rg;Y .wiH˝A\,rg;"-wi3H˝5rg;Y"-wqH˝EZ,r /wiH˝EZ rg;ϟyH˝EZ rg;k-wiH˝A\,rg;Y",wh3˝Erg;Y"-wqH˝EZ,r/waF˝A\,rg;"-w˝5Z,u9B˝A\,rg;Y?N^,rg;Y",wpH˝EZ rg;Y .waF˝Ys&/wi3˝EZ,rg;Y"-wq˝5Z,rg;Y .wiH˝Eu3_΢B.wqH˝EZ,rg;Y .wiH˝EX"-wiH˝A\,rg;>Y-wa3˝EZ,rg;Y"-wqH˝EZ rg;kY .w'˝EZ rg;΢;9˝EZ,rg;Y"-wqH˝EXrg;z3˝EZ,rg;Y",wpH˝EZ,rg;Y .wiH˝EZ rg;ye|釸.n;9wr9q ǝwr9q ǝZA;9wr9q ǝr9q ǝZA;1BK9q ǝZA;9BK9q ǝw^h;9BK9q ƝcwA[ĸ3q ǝA;w13Hqg A;w1 b9qg]ĸ3q ǝA;wrĸ3qgA;w13qg ŝcw1 by% b?13qgA;>w>A;wrĸ3qgA;w13Hqg Ɲw1 b9qgm3q ǝA;wr{rTw^h;w1 b9qg ŝcw1 bĸs ƝA;9 bĸ3q ǝA;wrĸ3qgA;w1 b9qg Ɲw1 bĸBKĸ3q ǝA;w13qgA;w1 b9qg}wqĸ3qgA;w1 b9qg Ɲw1 bĸs ƝA;/ĝA;w1ĸ3qgA;>7j;wrĸ3qgA;w13qg Ɲw1 zNĸ3?Q;cwrĸ3q ǝA;w1w1 bĸs ƝA;9 bĸ3q ǝA;cwbø3qgA;w13qgƝwj;wrĸ3q ǝA;w)w)a9qg ƝA;9 bĸsƝAr]A;w13c3q ǝA;cw)3qgA;w1 b9qgΘ89ow13qgA;w1 b9qgƝA;9 bĸs ƝAǝ_cw:3qg Ɲw1 b9qg ƝA;/ĝA;w13qgA;w0 R9qg Ɲw1 bĸs ƝA;9 Rø3q ǝA;w13qg1;3;w^h;w13qg Ɲw1 zw1 ˺ĝw1 b9qgƝA;8 bĸ3q ǝA;wrĸ3qgA;cwi;n%?6߉/qOA;tN\:q.5ԥƝ_w 5ĝԸN܉K'j tNƝB;wGиNܩC}'j܉kܩC;qĝtN]j܉K'ĥwRNƝw҉;uq.5ĥw҉;wSqPNƝĝ_w?q.5ĝSwRNJܩC;uq'QN~\N]jܩK;y)q'/%jI? %jIS?ƝSq'c}ĝwRN^JKwPNjK;qĝD;q'ĝԸSw%jI1CXߨ/q~;uq'/%:q>q'/7ĝuN]jܩK;^uN]jK:qPNFSq'F/wN;^uN]jܩK;y>Z'ԡƝwRN]jIwRNhSq'}NܩAN]jK:q.5$։;yswPNz։;uq'/%:q'>ĝSwRNhSq'}Չ;#hܩK;y{NܩkK:q5FSwRNFSwRN^zoԉ;nuN:q~;y鵿Q'ĥwsNܩKܩC;y赿Q'ԥƝߨw FuN};uq'cN)Ը趿Q'ԏq.5ԥƝFt)q5$zOԉ;uq.5DSw==Q?D;yD?Q'jܩoq'/='ĝԸSwkwwsNܩK;uq'/%ԥƝԸhN@SwN^zԉ;w=ĝԸSwswЉ;qq'kNܩK;y?P'ԥƝԸ^ո涿Ownܩ3;tNƝwcNܩK;u)q'==N?k{NIwRN]jKq:q.5$Ӊ;wĝSw%$zoӉ;76SnSNzӉ;i;uq'/ĝԸ>Nĝ:q'aNƝ4bSq'}NܩK;uq'/='q'NKo NܩkܩK;y?Y'$O։;>'ݸ?Y'ԥƝԸuN}\N]jK:q.%Ƿ'C￶NKItߟwdSKu:q'~湿N'7}N\:q'/ĝDu:q'/}Ӊ;uq'/ĝ:ԸﲞS׸SwkNܩK;y豿N;ew}MsNܩ@N]jKu:q>q'/=ĝSwk}ĝ_wp釸o-˝A\ .wq3˝Z; .wrg;9˝A\ rg;q3˝A;q˝A\ rg ;y3˝A\ .wq3˝ .wqs;A^ rg;cyeH˝EZ rg;Y .waF˝A\,rg;"-wiH˝A\,rg;Y"-wi3˝EZ,rg;Y",wpH˝EZ"-wvT .wiH˝A\,W;trg;Y .wiH˝A\,rg;"-w7˝Erg;Y"-wqH˝Ei_A^,rg;"-wa3˝EZ,rg;Y"-wqH˝EZ,rg;Y .wiH˝EZ rg;Y -whH˝A\,rg;9˝EZ,rg;Y"-wqH˝EZ rg;Y .wi˝1\,rg;"-wiH˝A\,rg;Y"-wi3˝EZ,r /wiH˝EZ rg;΢rg;nZ,rg;"-wi3˝EZ,rg;Y΢]AZO;k"-wi3˝EZ,rg;yH˝EZ,rg;Y .wiH˝EZ rg;k-wiH˝A\,rg;Y",wh3˝EZ,rg;Y"-wqH˝EZ,r/waF˝A\,rg;"-wi3H˝5Z,u9B˝A\,;Y?N^,rg;Y",wpH˝EZ rg;Y .waF˝Ys&/wi3˝EZ,rg;Y"-wݴY-wi3˝EZ,rg;~_W>a3˝E?\ rg;Y .wiH˝A\,rg;9˝EZ,rg;Y"-wq˝5Z,rg ;Y .wiH˝EZ rg;",whH˝A\,rg;"-wa3˝E-wis;Y .wiH˝EZ rg;"-werg; .waF˝EXrg;Y .wiH˝A\,rg;-wiBrg?-wIXs -q ǝwrmq ǝwry%s -q ǝwry!ǝcwry%s1;/ĝwry%sA;/ĝwr9q煖sA;/ĝwb9qŝA;wrĸ3qgA;w03qg Ɲw1 bĸs ƝA;9 bĸ3q ǝA;wrĸ3qg1;w1w1 wrtW'ĸsΠO Ɲw1 bĸs ƝA;9 Rø3q ǝA;wrtߨ% b9qg Ɲw1 oqgq煖3qg Ɲw1 R9qg ƝA;9 bĸs ƝA;wrĸ3q ǝA;w13qg Ɲw0 b9qg ƝA;/ĝA;^ g9 bĸ3q ǝA;wrĸ3qgA;w)3qg Ɲw1 bĸs ƝA;9 bĸ3q ǝA;w^h;w1 b9qg Ɲw}ow13qg Ɲw1 b9qg ƝA;9 bĸsΘD9a9qg Ɲw1 bĸBKĸ3qgA;w13qg Ɲw)a9qg ƝA;9 bĸs ƝA;cwrĸ3qgA;w13qg ŝY ŝ1Z ƝA;wrĸ3q Ɲ1;~Ɲwi;9 % b9qgƝA;8 bĸs ƝA;wr3qwi;wrĸ3q ǝA;w13Hqg Ɲw1 b9qg;;wqCs ƝA;wrĸ3q ǝA;w)w1 bĸs ƝA;9 Rø3HqǝA;^ĝA;w13qgA;w0 b9qg ƝA;9 bsΠ ƝZ ƝA;9 bĸ3q ǝA;wqĸ3_.wrĸ3q ǝA;cw)3qg Ɲw1 b9qg ƝA;1aĸΠ;ֶs ˸ðs 1:ès 1L:/s 19/s k19ǰ S!,90伌;18Ǩˆ2n80Â28ǰ|s 8vs 1,7/ps 16/js 1j60cb3Ff?Y5cTk(֌Q9f Jci(ӌQHs %1*4cha<3Fuƙ1j3cfƨ03F]f12ceƨɌA9Efq3FQ9)fJca|ogbTa(3F f c_(Q}9e 1*/0Qwr ˘긹Qr9ec[ƨ=< "1*-cZƨ2Fe "!l,cXƨQ`9}eՕcWƨQZr u1*ǰQT2FI1 *cS(2D1eZ1L)cTR(QGyg1(c^TưQB2F1'cTOa<v2Fd1w1&cMa5h2Fd1,&cLƨQ.9dbcJƨQ(Nr 3U1$/F2Fd cG(Q9qd8Q9ade1"0Q$r 1!cCa 2F-!ar 3U1 ǰQ2Fe?(Qq 1*0|Q1FF1hC(P EF}#hKy)"/}o)qMy齿Q'VԥԊ<ߨ+RE]jHߨ,RE^zo-7ꔋBM>7ċFK?ՋW|OHS0RF]jK:5chQZ2RSFhQZ3=GB uF4RF^zu]#}NKնQ7{NިKy)#/}IqqDQ9=G넎B-uZG;RkG^z~{~ߨ=7ꤏQ?{NHtߨ@}oI #hK:$. uBH}\JHj C:1.FRA$}NoM.5$zo"E7ꔑ4ԥ8^ި.%ԡD:5ԥ6ڟSIR3IǷ'GޟSJ?$/=Q?^ܟSK='B &DfRMRIz/TI}XIz/I'u.5ԓ|ROM@IPnCK:P3J@RZRRSJ^zTcJ:5%5y *uE%/=4ԨRZUkUiJ}M+u8?N'7޾t K]jbKi,yq_v2K8RZZRSK^zӉ-u%}}No 涿M'4(%kNwo%/=餗R_sN~OkK 0y?N'Kbs}NICS%~M1y鹿X'jIt_cRL]jKjC'ġSekefRL^zOi3nuLz$zO)4u.dJSLSikNKI5yRk'y?^zӉ63u:&n)7y齿N$ө7ysNK 8y鵾N'ԡ6/~Tft 9uwYԘS5'd=ԥ&_uZusNשK ;ue'K/q~;m*r"/EZ E^ Fb OFf䅖A^ -<9ˑ<y!oGx G^hA -ܐ -+<#9;<$yeIr$yKr$/I I^hEAM?h dg%yW2ÒA\ oKi\2뒃[9_͠W7 .libs7693A f6yj3辿X mqn3{Aܼ̲ nnqtsW78A f 79A\ oq3 A pqsg8! .qg885A g9x3h?M r^hY ,g{a .sq3ۜ<u s>g:.đ tLgv:c81 Vg:9sA ` /vq3Avqچ;neZ Ɲw1 bĸBKĸ3qgA;w13qg Ɲw0 b9qg ŝ1;9 bĸs ƝA;wrĸ3qgA;w13qgƝZ"ŝE;w),RY3qgŝA;w),RĸHqg"ŝA;w) bYHqg ƝE;dw),RY3qg"ŝw),w1,RY3qgΧHqg ƝE;w) bYHqg"ĝ5;w1,RY3qgmw) bYHqg"ŝE;~;rPw),RĸHqgƝE;w) bYHqg"ŝE;w=w),RĸHqg"ŝA;w),RFqg ƝE;w)丳Hqg ƝE;w) bYHqg"ŝE;w1,RY3qg"ŝE;w),RY3qg΢F9,RYHqg"ŝE;9,RYHqgŝE;w}o"ŝA;w),RĸHqg ƝE;w) bYHqgΚD1QĸHqg ƝE;w)丳Hqg"ŝA;w) bYHqg ƝE;kw)QYHqgCqg"ŝA;w!QĸHqg"ŝA;w) bYHqg1;w( bYHqg ƝE;w)QY/U( bYHqg΢qrY3qgŝE;cw),RĸHqg"ŝA;w(ĸ涿M;w1,RY3qg"ŝE;w!QY3qg΢w+w),RY3qg! ƝE;w) bYHqg"ŝE;wqYHqg ƝE;w1,BYqg "ŝE;w),RY3衸Hqg ƝE;kw) bYHqg ƝE;w0,(,R9qg"ŝA;w),RĸHqgƝE;: bYHqg"ĝ5;w0,RYHqg"ŝE;w),RY3Hqg"ŝZ΢;5; jӼw҉;uq.5җSq%ԥƝtN\:qPNw 5j)Ը?Ɲ8tNj܉K'j܉kܩC;qѸNܩK;qĝtN]j)ԸwN\:q.5ԥƝtN\:qPNw 5J)ӸK_N_5ԥƝwRN]JC;uq.5$JɏKܩK;uq'/%ĝB;aĝB;wGиw 5$zoԗSxN]jK;yiNjܩC;y)q'.(q'>ĝSwRNĝB;>|%ԏq.5ĝQ'5FSwsNܩK;uq'kNܩK;y鹿Q'jItߨw 5$ߨwåw寧|}NwRN^z։;uq'/=GĝԸSwGĝԸ?Z'z?Z'$z։;uq'/=GĝԸ?Z'jܩC;y?Z'ԥƝ>GĝwRN]jܩK;uNƝD:q~;uq'/=Q?^zoԉ;q;y鵾Q'ԡƝߨwRN]jIߨwRN]jK:q'mNIQ'ԏq'/7ĝtN^zoԉ;q;uq'7ĝԸuNƝD:qƝԸ豿Q'jItߨwGиSwRN^z}{~Sw='ĝ:ԸSwkNܩK;ߞ{N܉oĝDxsNI؟w 57޸uN]jܩK;y赿P;a;y蹿P'ԥ uN^JܩK;uq'ĝ4:qƝw 5$zԉ;uq.5@5ġwPN@SwsNܩK;uq'/q'm&7ݸSgwĝB;78SwRNz~{~q.5d>Y'$\wNdSwRN^zO։;q;uĝԸSwۓ_['%$:q'/}Ӊ;uY^_wgtN|'ĥw{NIt_w:Swk}NܩC;y_.;q;uq'/ĝԸSq'd=ĝ4ԥƝ_wwsNܩK;uq'K/q~;Nwry%sA;-sA;/ĝwry%sA;/sA;/ĝwb9q煖sA;/ĝwr9q煖sA;9wr9q煖sA;83qgA;w1 b9qgy A;w1 b9qg ƝA;9 bĸs ƝA;wrĸ3q ǝA;w)3"q煖3qg@ĸs ƝA;9 1 b9qg ƝA;9 bĸs ŝ1;wrĸ3q ǝAZ Ɲw1 b9qg ƝA;/_| ƝA;9 bs ƝA;wrĸ3q ǝA;w13qgA;w1 b9qg ƝA;1a% bĸ3q煖3qgA;w1 b9qg}s ƝA;wrĸ3HqǝA;w13qg Ɲw1 b9qg ƝA;9 bĸBKĸ3qgA;cw13c3q ǝA;w13qgA;w1 b9qg Ɲw'qg A;w13qg ƝZ ƝA;wrĸ3?QKĸ3qgA;w0ĸ3qg Ɲwj;9 b3q ǝA;w13qgA;w1 Ry% Røs ƝA;wrĸ3q Ɲ1;~Ɲw1 b9qg8-qgA;w0 R9qg Ɲw1 bĸs ŝ1;/3涿MKĸs ƝA;9 bĸ3q ǝA;cw1n3_{k;w1 R9qgA;w1 b9qg Ɲw1 b2Kĸ3qgA;w13Hqg ŝcw1 b9qg ƝA;9 bĸs ŝ1;wrĸ3qgA;w)3h?ø3q煖3qgA;w1 b9qg ŝcw1 ˺ĝw1 b9qgƝA;8 bĸ3q ǝA;wrĸ3qgA;cw13_5i4qON܉K'ԥƝԸK_NƝܗSw҉;qĝB;N)ԸSqPNwЉ;uq'.Sq'>q5ġw҉;uq'.NܩK;wN܉K'ԥƝԸN܉K'z':qPNĝ2; |;%$z\N]jK;y)q.5ԥĝq'ĝԸSwRN]jܩK;&yԉ;u7@Sq'QN};uq.5@5ġwPN@Sw}NܩK;uq'/=q'>Mܩ/q4$w 5޸ntN]?N;yq;q'mNܩK;uq'/ĝԸc}N Ը}N܉o;uq'QN6S_xN^oӉ;uq.%8Sָ^ĝ:qƝԸոSq'qPNw}N)ԸcNܩK;uq'/'q'NK_ NܩkܩK;y?Y'$z_w}Oֳq'mNܩK;uq'/'ĝƝԸuN]JCO֯N[IN'u:q.=<믗tN}N܉/ĝtN^zӉ;ĝN'ԥƝX_wPN^?zN}\N]jKu:q.%:5N'$Ӊ; hܩK;y鹿N'5:SwPNzӷoq/~;-BK9q ǝw~-sA;/ĝwry%sA;/sA;/ĝwb9q煖sA;/ĝwr9q煖sA;9wr9q煖sA;8B[ĸ3q ǝA;w13Hqg A;w1 b9qg ƝA;9 bĸsНqg ƝA;9 bĸs ƝA;wqĸ3q煖3qgBĸs ƝA;9 zӿ1 b9qg ƝA;9 bĸs ŝ1;wrĸ3q ǝAĝA;9 bĸs ƝA;w^Hq7ͯbĸs ƝA;8 bĸ3q ǝA;wrĸ3qgA;w13qg Ɲw1 bĸsƝA;9 bĸ3q煖3qgA;w1 b9qg Ɲw1 bĸs ƝA;8 bĸ3q; ƝA;wrĸ3q ǝA;w13qg -qg ƝA;1aĸsΠZ Ɲw1 bĸs ƝA;9 bĸ3q ǝA?1ĸ3}w03qgA;w1 by% bĸ3q ǝA;wrĸ3qgA;w0ĸ3qg Ɲw1 b9qg ŝ1;9 bĸ3q ǝA;wrĸ3qg,qgƝw1 bĸs ƝA;1a"wrĸ3q ǝAoĝA;9 Rø3HqǝA;wrĸ3qgA;>i;/3}3q ǝA;wrĸ3qgA;w0 zw6Ww13qg ŝcwwrĸ3qgA;w13qg ŝY ƝA;wrĸ3q ǝA;cw)3qgA;w1 b9qg Ɲw)aĸs ƝA;wrĸ3HqǝAƝA;/ĝA;wrĸ3qgA;w)3qgпY%3qgA;w0 R9qg ƝA;9 bĸs ƝA;wbNK3?ŝ_wry%sA;wr9q ǝZA;9wr9q ǝr9q ǝZA;1BK9q ǝZA;9BK9q ǝw^h;9BK9q Ɲcw~- bĸs ƝA;wr3q ǝA;w13qg Ɲw1 b9qg ƝA;9 bĸs ƝA;wqĸ3q煖3qgBĸs ƝA;9 zӿ1 b9qg ƝA;9 bĸs ŝ1;wrQK9qgF-qgA;w13qg ƝZΠwW1 b9qg ŝcw1 bĸs ƝA;9 bĸ3q ǝA;wrĸ3qgA;w1 b9qg Ɲw1 bĸBKĸ3q ǝA;w13qgA;w1 b9qg ŝcw1 bߨ% bĸ3q ǝA;wrĸ3qgA;w1w1 bĸsƝA;9 zߨ% b9qg ƝA;9 bĸs ƝA;wrszA;c'qg A;w13qg ƝZ ƝA;wrĸ3q ǝA;w13Hqg A;cw1 b9qg Ɲw1 Røs ƝA;wrĸ3?PKĸ3qg,qgƝw1 bĸs ƝA;1a"wrĸ3q ǝAoĝA;9 Rø3HqǝA;wrĸ3qgA;w0ΘmZ Ɲw1 b9qg ƝA;9 R:|mWrs ƝA;9 bĸ3HqǝABǝw1 bĸs ƝA;9 bĸ3Hqe3qg Ɲw1 zOw)as ƝA;9 bĸ3q ǝA;wr3qgA;w1 b9qg ŝcwgw1w1 b9qg ƝA;9 bs ƝAgYs ƝA;9 Rø3HqǝA;w13qgA;w1 b9qg Ɲ_h;K@%CiX)>C'U%4ԝ w *Y)us}ZSLcJyI)q%$ԝ::$ĝ6ӄR>C'i?)>C$ԝW;9$>ݤgGc}uN;m#u綾:i):'*wEW$0-"eW7ĝ֐Rw?^_$ę29$4ĝVX@NHۏG7\?O;ow>G紏29#LG|u>:zĝFQgQgsrGi;u'#4uĝ2:<'d[9c}rNQ>9'pĝӼQwӸ6>ӴQ>9'lĝvs_S5NFiӨ;i(83mΈ#e>洌0M5dԝܜw1N*Fxn~;gyN(s[0NEi;9"]؞S.6 EdZĝF2ieksE| u綾6'Wĝ֊Xg^tu :">"4TԝLwZ)}}(4Q5PiwDݹoЉa&|o)qa"KԝJ|}DϜ&QwOj;u>BFy"|nг%m}N;qG4&Qw#tCI~3og|)us}oNw;ϟ?۝ޜPf=r_ߛSzOp u繾76y_ߛޜwc{oNf3 ugⳚN Cy q'yq!HB? ;oW; u繾7'*g)ԝޜwL{Bylͷo1/w~ o^"9KA\ Rd"/,Eq)2KA\ .Eq)r"ĥ .ERd "9KA\ Rd "y)2KA\ .Eq)2K\ Rd"9KA\ R /Eq)2HK1\вY"-Eq)HKEZ,Rd"Y .Ei)HKEZ Rd"Y .Ei)^vc=axGc<axC|,RHc E@ bYH WE A) R YH-dcȢrY(E*"D bY*HYd"E*#F,RY:2HydD1Q!T"YFHd+"eE$Jr)YTHdb ֒E%K1,R1YdHd"T5&M(,R9Yt2d"ՓA'O!QAĄH e""UA(Q) bIYH-eb1)S֨ bPYHIe FE*UQXY'*V,R\Y2ye89,RaIJe""T1,Y) biYԲHeb ֖E-k[bpYMN.\1,RuY2eE0_uy"ė5/_,RY3 f"EE0cab,RYH1fs"A 2Td),B9Qf"eE2f,R6qf"13h bYFHf* fE4j,BYVHfk"E5l,RYf3f~FfA7Tn) bYxHf E 8Pp0,RY/~g3"uE 9Xr!QY35gr"E :Xt),RĨHUg"uA ;kTv)v-%<=qg"/tN\:q.5ԥƝ/};woq.5ĥw҉;wSqPNƝ4ġwPN\:qPN|\Nj܉C'ĥwRN\:q'.Sw 5ǝNܩK;uq'.N)ԸĝB;w4|w-$_q;uq'/%ĝԸSwPNjܩK;wwRN]jK;y)qPNe(qPNĝ4ĝB;n-޸SwRN^SwPN^J܉K'$J܉;q'/%ԥƝԸ(qPN7F};-hܩK;y)q'/}oԉ;q;y鹿Q'ԥĝ'ĝD:qPN};y?Q'ԥƝ ոSָ uN]jܩK;y)q.5ԥƝDw<ĝwcN)Ը?P'ԥƝԸոN܉C;iuN]jK:q.5ԥƝƝ44qƝ:ӸcN)ԸS_xN^Ӊ;uq.%CĝDq:q.5ԥƝtwRNq:q'PNm:q''ԥƝD;t~᯺ʷ:q/;uq.%bSָSwsNܩK;y龿X;eww 5oq'/%$J)ԸcNܩK;uq'/'q'NK_ NܩkܩK;y?Y'$z_w}Oֳq'mNܩK;uq'/'ĝƝԸtN]JCӯN[IN'u:q.=<믗tN}N܉/ĝtN^zӉ;ĝN'ԥƝX_wPN^?zN}\N]jKu:q.%:5iI'YEu:q;uq'/=ĝƝt_wRNjCuw-/qٖ;yBr /wr /w~ms;ys;/,wr /w^hYA^ ys;yBr /wr/w^hYA^в9˝9˝Z;ys;yBr /wr煖A^1^Brg;9˝A\ rg;y3H˝1\ .wq3˝ .wqs;A^ rg;9˝A\ r /wq3˝AZ .wqBrg;_; r /wq3˝A .wqs; .wrgmA^ rg ;9˝A\ r /woԲAO.wq3˝ .wqBrg;rg~;y3˝AZ .wq3˝ .wrg;A^ rg;y3˝A\ zB9˝A\ rg;q3˝A\ .wq3˝Z;A^ rg;9˝A\ r /wq3˝A\ .wis; .wrg;A^ oԲ9˝A\ rg;y3˝A\в .wqs;cA^ zߨe3˝ .wqs;A^ rg;9˝A\ r .wƼO;c9 .wqs;ΠD-˝A\ rg;y3˝A\ .wq3˝.wrg ;A^ rg;y3˝AZr /wq3˝A\ .wqs; -w^fY Բ9˝A\ rg;y3˝A\.w^Nr /wq3˝?Nrg;y3H˝1\ r/wiY .wq3˝.w^˝1۴,wqs;zU9sAq5ġw҉;uq'.NܩK;wN܉K'ԥƝԸN܉K'j ٸSqPNƝחŝD?5ԥƝwRN]JC;uq.5$JɏKܩK;uq'/%ĝB;aĝB;w[иw 5$oԷS_xN]jK;yiNjܩC;y)q'.(q'>ĝSwRNĝB;|n-Էq.5ĝQ'5FSw}NܩK;uq'cNܩK;y龿Q'jIQ'jIQ'7K'ĥw=7ĝ[9qN7SwPN^։;uq.5$z։;uq'}N)ԸcNܩoAN]jK:q.5$wh5ԡƝ<wRN^JKuN|܉;y)q.5ԥƝD:qPN:q;uq'/q'/=7ĝ:ԸnuN]jܩK;uN]jܩK;y鹿Q'$zߨw}oԉ;-hK:q'.uN}\NjC:q.5FSq'FS_xN]jItߨw 5$zߨw[иSwRN^zx~Sw'ĝ:ԸSwcNܩK;n?_sN܉/ĝDzsNIt۟w 5޸uN]jܩK;y豿P;a;y辿P'ԥƝԸwRN]jI4q'sNܩq'/=ĝB;nuN]kNKj܉C'ġƝ4:q.5@SwRN^zTN}S_tNiI?N'jܩ/q'/ĝԸSw?vN8SwRN^Ӊ;uq'8q'6߀WIf~sNI?X'snuN]jܩK;y辿X'ԧ5ԥƝ_wRN^/VNƝD럷ƝB;oK:qPN:q.5ԥƝt۟Ɲ8tN:q'/=18q>q.5d}}NI>YƝDO7YԸSw}NܩkܩK;y鱿N'ԥĝq5ġw҉;uq'.NܩK;wN܉K'ԥƝԸN܉K'j tNƝB;ew|;__w=׸SwRN^JܩK;u)q'%ԡƝԸ(q'?9.5ԥƝw 5$_w 5$JܩoAN^J)Ը趾QN};uq'/%䥉;uq5ĝtNĝwRN]jܩK;w 5$z!oԷS߂ƝԸwFS׸uN]JC:q.5ԥƝD:q.5FSq'FSq'F?ި_.NIߨw?wtN};uq5hSwRNhSwGĝB;>Gĝ4ԥƝtwRN:q'/}VNjC:q.5ĝ?Z'ǝwRN]jItw 5$w[иSwǣwwc}NܩC;y鶿Q'ԥƝԸ辿Q'ԥƝԸuN:q'FS߂Ɲߨw҉;y龿Q'%ԡƝ<ߨwRN^oԉ;w}oԉ;7ԥƝD:qPN:q;uq.5Ǐ7K;uq'}}NܩC;uq'/='ĝԸ='ĝOKOԯ>'ĝD:qPN};y?Q'ԥƝ ոSָ uN]jܩK;y)q.5ԥƝDw<ĝwRN:q'mNܩK;uq'/q'w<ĝԸuN]jܩK;y?P;iiN}э;uq'8SqƝtwRN]JCӯ>l؉;ntN]jܩK;y?N'ԥƝDt_~OĝSw%$z։;7`SwRN/։;i;uq'/=ĝԸոSq'qPNw}N)ԸcNܩK;uq'/'q'NK_ NܩkܩK;y?Y'$z_w}ӳq'QN}A;wrĸ3qgA;w13Hqg Ɲw1 b9qgF-qgA;w13qg ƝZ ƝA;^ǝͯbs ƝA;wrĸ3q ǝA;w13qgA;w1 b9qg ƝA;1wrĸ3qg -qg Ɲw1 bĸs ƝA;9 bĸ3q ǝA;wqĸ3qgA;w1 b9qg Ɲw1 bĸs ƝA;/ĝA;w1ĸ3qgA;7j;wrĸ3qgA;w13qg Ɲw1 b9qgD9a9qg Ɲw1 bĸBKĸ3qgA;w13qg Ɲw)a9qg ƝA;9 bĸs ƝA;cwrĸ3qgA;nĝw1 b2K3q ǝA;w13qgA;cwƝw1 b9qg8-qgA;w0 R9qg Ɲw1 bĸsWMf~ϘgΘZ Ɲw1 b9qg ƝA;9 Rø3q ǝA;wrĸ3qg1;?o;9 bĸ3q ǝA;wrĸ3qg,qg ƝA;9 bĸs ŝ1;wqĸ3q ǝA;w13qgA;w0 b9qg ƝA;9 bsΠ ƝZ ƝA;9 bĸ3q ǝA;wqĸ3_,wrĸ3q ǝA;cw)3qg Ɲw1 b9qg ƝA;1aĸ -qg;7m?7Akvs4攝wuNΗwU0:_~ַwtswN Ӟ99'LkNƜ0m9_ޛr>sJNi8aqV8ӈpsNi 8_9&4߄iNi7q&|}焛nksMF0?&/ߊ͗w2?g5ĝ֚sQjNSMI3 5q&4ӔIJ;m4qԝ03eY1ƙ2i3{o;)3afܶW[U&4ԝ4gc"gdNzwN)gSwbNSLi)m{uEĝ&Sw>W旺\__NK)/q%yΩ.qѥW$0-.e>W0-eWĖI-_9c}uNg;,yr~Q*K~ni,qgӾwWCiX)>C'U%4ԝ wZT|)us}ZSLcJyI)q%$ԝ::$ĝ6ӄR>C'i?)>C$ԝg;:$>ݤgGc}uN;m#u綾:i):'*wEW$0-"eW7ĝ֐Rw?^_$ę29$4ĝVX@NHۏG7\?O;ow>G紏29#LG|u>:zĝFQgQgsrGi;u'#4uĝ2:<'d[9c}rNQ>9'pĝӼQwӸ6>ӴQ>9'lĝvs_S5NFiӨ;i(83mΈ#e>洌0M5dԝܜw1N*Fxn~;gyN(s[0NEi;z :E#2tצlThQ&͢c}N'䊸Zw+}}Nj; u繾A'SĝVs_ߠ6 Me?^ a'B_9Q3Iԝ7S$$N{Dyͩe޷洈2{l(s[ߛ!N3Di;9 "> "@ԝޜw{ۙg2{sC\ߛiv繽7':YszCyͩ e洆74ĝޛL+CF4&Pw{sBI^3i\ҶPOhf{sBNBy͉ Ym u羾7(ĝ8ӞPg{vj—wNL;Ą}#ĥA^ Rd"ye)2KA\ R /Eq)2Kĥ .Eq)r"cĥA^ Rd"c9KA\ R /Eq)2KA\ .Eq)2Kĥ .ERd"å -KEZ,Rd"Y"-Eq)K5Z Rd"Y .Ei)HKEZ RdίHKA\,Rd"ĥ"-Ei)2KEZ,Rd"cY"-ERd"_)Rd"Y .Ey*Rd"Y"-Ei)2KEZ,Rd"Y"-Eq)HKEZ RdFy)蹿Q^,Rd"Y"-Ei)r"Y"-E*-Ea)2KEZ,Rd"Y"-Eq)HKEZ,Rd"Y .Ei)HKEZ Rd"Y -EGKA\,Rd"9KEZ,Rd"Y"-Eq)HKEZ Rd"Y .Ei)K1\,Rd"ĥ"-Ei)HKA\,Rd"Y"-Ei)2KEZ,R /Ei)HKEZ Rd"ĥȢRd"Y"-Ei)2KEZ,Rd"Y"-Eq)HKEZ RdDq)Y .Ei)HKA\,Rd"9KEZ,Rd"Rd"ĥ"-Ei)HKA\,Rd"Y"-Ei)2KEZ,Rd"Y-Eq)HKEZ,Rd"n .Ei)HKEX",Eh)2KEZ,Rd"Y"-Ei)FKE/KZ Rd"ĥȢqRd"Y-Ea)2KEZ,z"̯|d#4Y G~CXR .Eּ""-Ei)2KEZ,Rd"Y-Ei)2KEZ,Rd"Y",Ep)hƥ .Ei)HKEZ Rd"ĥ"-Ei)KcY"-Ei)2/-Ei)HKA\,Rd"å"-Ei)2KEZ,Rd"Y"-Eq)K5Z,Rd"Y"-Eq)HKEXRd~FKEZ"-Ei)2KEZ,Rd"Y",Ep)HKEgYĥ"-Ei)2KEXRd"cY"-Ei)2KEZ,Rd"Y"-Ei)FKEZЛ"RVŝw^h;9s/ŝwr9qr9q ǝZA;9B;8BK9q Ɲcw^h;9BK9q ǝw^h;9s -q ǝw^h;9ĸs/ŝA;wrĸ3qgA;w03qg Ɲw1 bĸs ƝA;9 bĸ3q ǝA;wrĸ3qg1;w1w1 _wrĸ3q ǝAo7 ƝA;9 bĸ3q ǝA;wr3qgA;w13}3q ǝA;wrĸ3qg 9 bĸ3q砿^ǝ4JqǝA;w13qgA;w1 b9qg Ɲw1 bĸs ƝA;wbø3q ǝA;w1w1 b9qg ƝA;9 bĸs ƝA;wrĸ3HqǝA;nĝw1 bĸs ƝA;9 bĸ3q ǝA;w^h;w1 b9qg Ɲwow13qg Ɲw1 b9qg ƝA;9 bĸsΘrøs ƝA;9 bĸ3q煖3qg Ɲbĸ3q ǝA;w13Hqg A;cw1 b9qg Ɲw1 Røs ƝA;wrĸ3q ǝA;w)w)a9qg ƝA;9 bĸsƝA.q ǝA;wr?NKĸs ŝ1;^Ɲj.>X|.>rĸ3qgA;w0ΘZ Ɲw1 b9qg ƝA;9 Rø3q ǝA;wrĸ3qg1;?o;9 bĸ3q ǝA;wrĸ3qg,qg ƝA;9 bĸs ŝ1;wqĸ3q ǝA;w13qgA;w0 b9qg ƝA;9 bsΠ ƝZ ƝA;9 bĸ3q ǝA;wqĸ3_,wrĸ3q ǝA;cw)3qg Ɲw1 b9qg ƝA;1aĸ mqg;؟k9q煖sA7Ɲw~-sA;/ĝwry%sA;/sA;/ĝwb9q煖sA;/ĝwr9q煖sA;9wr9q煖sA;8B[ĸ3q ǝA;w13Hqg A;w1 b9qg ƝA;9 bĸs ƝA;wrĸ3q ǝA;w)3qg -qg 8q ǝA;wr owrĸ3qgA;w13Hqg Ɲw1 b9qgF-qgA;w13qg Ɲzsĸ3qgA;[ܙ_s ƝA;wrĸ3q ǝA;w}w1 b9qg ƝA;9 bĸ3q Ɲ1;wrĸ3qg -qg Ɲw1 bĸs ƝA;9 bĸ3q ǝA;wqĸ3趿QK9qg ƝA;9 bĸs ƝA;wrĸ3q煖3qg Ɲw0 b9qgF-qgA;w1 b9qg Ɲw1 bĸs ƝA;1yߟ(ǝ1;9 bĸs ƝA;w^h;w1 b9qg Ɲw1 bĸs ŝ1;1aĸ3q ǝA;wrĸ3Hqg A;w1 b9qg Ɲw1 b2K3q ǝA;w13qgA;cwƝw1 b9qg8-qgA;_*>cX|is ƝA;9 bĸ3q ǝA;cw^qg`-qgA;w13qg Ɲw)aĸs ƝA;9 bĸ3HqǝA7ǝw1 b|f ƝA;9 bĸ3Hqe3qg Ɲw1 b9qgƝA;8 bĸs ƝA;wrĸ3q ǝA;cw13qg Ɲw1 R9qg~qg -qg Ɲw1 bĸs ƝA;8 b/~u;9 bĸs ŝ1;wqĸ3qgA;w13qg Ɲw0 b3ĝ|ܾǝw}"NܩK;uqKNƝ?[ܩK;qĝtNƝ@'j)ԸSq';qĝ:ԸN)Ը׸S>wЉ;qĝԸN܉K'ԥƝB;q'ĥwRN]j܉K'ĥw 5:qPNĝ2;_ŝ/};a}\N]jK;y)q.5ԥĝGĝwRN]jܩK;uNƝDuN} wRN^x~wwc}NܩC;y鶿Q'ԥƝԸ辿Q'ԥƝԸuN:q'FS߂Ɲߨw҉;y龿Q'%ԡƝ<ߨw/7ĝB;>7ĝwRNFSq'FS߂ƝԸSwۥĝ:Ը>Q'ԡƝԸuN]jItDuN|'Ǐ'KuNDSqƝtߟwRN]JCjܩkC:q.5ԥƝSwRN;iuN}ݍ;y?P'jItwRN]jKj܉C'ġƝ4:q.5@SwRN^zTN}S_tNiI?N'jܩ/q?/-+ouO}->u)q'Xj'$/։;uq.5bSw}/։;wҼ։; 8q.5$JIw {wRN]jܩK;y辿X'ԧ5ԥƝ_wRN^/VNƝD럷ƝB;oK:qPNq:q.5ԥƝt_Ɲ8tN:q'/=18q>q.5:}}NINƝDu:q.5ԥƝt_wwRN^zӉ;u)q'~Nz:oq':>ĝ^zӉ;3u:q'w҉;y鹿N'$z_w:Swc}NܩC;y_,;q;uq'/=ĝnԸSq'ϟdĝ4ԥƝ_ww}NܩK;uq'=[ҷ~;i߶ .wrg; -˝A\ rg;y3˝A\ .wq3˝ .wrg;A^ rg;y3˝A\ r /wq3˝A\ .wqs;.w^hY,rg;Y"-wi3˝EXrg;Y"-wqH˝EZ,rg;Y .wiH˝EZ rg;"-wi˝1\,rg;yH˝Ei3˝EZ,rg;ziH˝A\,rg;"-wi3˝EXrg;Y"-wq}Y .wiH˝A\,rg;9˝EZ,rg;Y;"-wiH˝A\,rg;Y"-w};Y .wi?Z^ rg;Y -whH˝A\,rg;9˝EZ,rg;Y"-wqH˝EZ rg;Y .wi˝1\,rg;"-wiH˝A\,rg;Y"-wi3˝EZ,r /wiH˝EZ rg;΢rg;Y"-wi3˝EZ,rg;Y"-wqH˝EZ rgDqF˝A\,rg;Y΢CEZ"-wiH˝A\,rg;Y"-wi3˝EXrg;kY"-wqH˝EZ rg;Y .wiH˝EZ rg;"-wi˝cY-wqH˝EZ,rg;Y -whrB;YzUm_9 y/<49o˝5Z,rg ;Y .wiH˝EZ rg;k9˝5"-wqH˝EZ rg;Y .waF˝EZ rg;"-wi˝1\,Zq3˝EZ,rg;Y"-wqH˝Eur/wiH˝EZ rg;",wh˝1\,rg;Y"-wi3˝EZ,rg;Y"-wqH˝EZ,rg;Y.wgYA^,rg;Y"-wi3M˝EZ,rg ;Y/~˝A\,rg;Y-wa3˝EZ,rg;Y"-wqH˝EZ,rg;kY -˝Eis;9wr9q ǝ_h;9s -q ǝw^h;9s 9s -q ǝwqy%s -q ǝwry%sA;/ĝwry%s1;w1 b9qg ƝA;9 Røs ƝA;wrĸ3qgA;w13qg Ɲw1 b9qg ƝA;8 bĸBKĸ3!b9qg Ɲw|w13qg Ɲw1 b9qgƝA;9 bĸsΠZ Ɲw1 b9qg ƝA;/ĝA;w13u l9 @9 bĸ3q ǝA;wrĸ3qgA;w13qgms ƝA;wbø3q ǝA;w1w1 b9qg ƝAĝA;wrĸ3qgA;w)3qg Ɲw1 bĸs ƝA;9 bĸ3q ǝA;w^h;w1 b9qg Ɲwow13qg Ɲw1 b9qg ƝA;9 bĸsΘrøs ƝA;9 btz1w1 bĸs ƝA;9 bĸ3q ǝA;cwbø3qgB-qg Ɲw1 Røs ƝA;wrĸ3q ǝA;w)w)a9qg ƝA;9 bĸsƝA/~Um_sϠ7ĸsΠZ Ɲw)as ƝA;9 bĸ3q ǝA;{KnJ-:#}kk)VH_mvmeә-aB;c.ĝA;9 bĸs ƝA;wr3qgA;w13qg ŝcwwrĸ3qgA;w13qg ŝ/ĝA;w13qgA;w0 R9qg Ɲw1 b_% bĸs ŝ1;wrĸ3qgA;w)3h?ø3q -qg Ɲw1 bĸs ƝA;8 b/~u;9 bĸs ŝ1;wqĸ3qgA;w13qg Ɲw0 bmqgĝ_=ϸ(hPwN܉K'ԥƝԸqP#ԥƝtN\:qPNw 5j)Ը߂Ɲ8tNj܉K'j܉kܩC;qĝtN]j܉K'ĥwRNƝw҉;uq.5ĥw҉;wSqPNƝ?ϗ~ĝDkܩK;y)q'/=tq.%ĝ:ԸSw%%ԥƝԸwRNƝD0QNƝD;-hK;w]7Gܩ/q.5ĝ4q5ԡƝNIwN^JܩK;uq'QNƝD_w>Dw[иSwRN^zoԉ;q;y鱿Q'ԥĝq.5:Sw㯭w}Ӊ;y鹿N'ԥg}{鱾N'$ĝO܉K':貿N':Sw}}NܩC;y_,;q;uq'/ĝԸSq'd}ntN}wRN^zӉ;q;y鶿N'ԥĝ:Ը#|Gŝe3˝ .wq .wq3˝ .wrg;A-wp3˝ -wps;A^ rg;9˝A\ rg;y3˝A\ .wi3˝/,wiH˝A\,rg;q˝5Z rg;Y .wiH˝EZ rg;"-wiH˝A\,rg;Y"-wa3˝EZ,r /wiH"-wqH˝EZ rg_^EZ,rg;Y"-wqH˝EZ rg;kY .wiH˝A\,o;"-wi3˝EZ,rg;yH˝EZ,rg;Y_;Y"-wi3"-wi3˝EZ,rg;Y"-wqH˝EZ,rg;Y"-wiF˝EZ rg;YA^,rg;Y"-w=G˝EZ,rg;Y"-wqH˝EXrg;Y .wiH˝EZ rg;"-wiH˝A\,rg;yH˝EZ,rg;kY .w}o;"-wiH˝A\,rg;Y"-wi3˝EZ,rg;k.-wqH˝EZ rg;YA^,rg;"-wi3˝EZ,rg;.Z,rg;Y"-w=˝EZ,rg;Ytrg;Y"-wqH˝EZ rg;Y1^,rg;YySH_9"yqγHsE Ҝg<>)Th3˝EZ,rg;˝EZ rg;kY.wiH˝A\,rg;",whs;k."-wqH˝EZ rg;Y .waF˝EZ rg;"-wi˝1\,Zq3˝EZ,rg;Y"-wqH˝EZ,r/wiH˝EZ rg;",wh˝1-wiH˝A\,rg;"-wi3˝EXbH˝A\,rg;"-wa3˝E-wis;Y .wiH˝EZ rg;"-werg;Y .waF˝EXrg;Y .wiH˝A\,rg;-wi΢ZƝwwr9q ǝwr9q ǝ/ĝwrBK9q ǝw1;9|%s1;_h;9󅖸sA;9|%sA;_h;9󅖸sA;83qgA;w1 b9qgƝw1 * b9qg ƝA;9 bĸs ƝA;wrĸ3q ǝA;w)3qgZ ƝAqA;w13Kĸ3q ǝA;w13qgA;w0 b9qg Ɲw]7j;wrĸ3q ǝA;w1|% bĸ3q ǝA;S9qg ƝAOw1 b9qg ƝA;9 bĸs ƝA;wrĸ3qgA;cw13qg Ɲ/ĝA;wrĸ3qgA;w13qg Ɲw1 R9qg ƝA;9 bĸ3q ǝA;wrĸ3qgA;w1|% bĸ3q Ɲ1;wrQKĸs ƝA;wrĸ3q ǝA;w=7j;w1ĸ3?Q;cwrĸ3q ǝA;w1|% bĸ3q ǝA;wrĸ3qgA;w0ĸ3qg Ɲw1 b9qgΠ+~+q ǝA;w13qgA;w1 R2;?*>cX|rw13qgA;cw}Ɲw1 b9qgb-qgA;w0 R9qg Ɲw1 b_% Røw\k;wrĸ3q ǝA;w13Hqg Ɲw1 b9qg ƝA;8 Z93qg Ɲw1 b9qg ƝA;_f;w1 b9qg Ɲw)as ƝA;9 bĸ3q ǝA;wr3qgA;w1 b9qg ŝcwgw1|% bĸs ƝA;wrĸ3HqǝA;ϲ.q ǝA;wr3qg1;w1 b9qg Ɲw1 b_'ǝ1;wA[t/qXb;wrĸ3qgZ ƝA;wrĸ3q ǝA;w=wbø3q ǝA;w03qgA;w1 b9qg ƝA;9 bĸs ƝA;cww),RĸHqg"ŝA;w( bYHqg ƝE;w) bYHqg"ŝE;w1,RY3qg"ŝE;cw),R9qg"Hqg"ŝE;w}|w) bYHqg ƝE;w1,BYHqg"ŝE;w]7qg ƝE;w1,RYHq ǝE;w) bYcy Z7h"ŝEOA;w) bYHqg ƝE;w1,RYHqg"ŝE;w)QY3qg"ŝE;9,RY3qg"ŝE;w),RĸHqg"ŝA;w!aYQ;w1,RYHqg"ŝE;w),RY3qg"ŝw),RY3Hqg"ŝA;7qg ƝE;w) VYHqg"ŝE;帳Hqg ŝ5bY3qg"ŝA;w),R9qg"ŝE;w),RĸHqg"ŝA;w( RYHqg ƝE;w1,RYFqg"ŝE;w1,RY9IW,RYy!QĸHqg"ŝA;w) RYOU( bYHqg΢rY3qgŝE;cw),RĸHqg"ŝA;w(ĸ?X;w1,RY3qg"ŝE;w!QY3[qg"ŝA;w),BøhƸ3qg"ŝE;w),RĸHqg"ĝcw),RY3qg"ŝA;w(,BøHqg ƝE;w) bYHqg"ĝ5;w1,RYHqg"ŝE;cwgw)丳Hqg ƝE;w) bYqg "ŝEgYw1,RY3qgŝE;cw),RY3qg"ŝA;w),RFqgZ΢;W[9q -q ǝwrmq ǝwrBK9q ǝ/ĝwr9q 9sZA;1󅖸sA;_h;9sZA;9󅖸sA;_h;9ĸs?h;w13qg Ɲw)a9qg ƝA;9 bĸ3q ǝA;wrĸ3qgA;w13qg ŝcw1 bBKĸ3 b9qg Ɲw}|w13qg Ɲw1 b9qgƝA;9 bĸsΠF-qgA;w13qg Ɲ/ĝA;w13qg11̯bĸ3q ǝA;wrĸ3qgA;w13qg Ɲw1 bĸsƝA;9 bĸ3q -qg Ɲw1 bĸs ƝA;9 bĸ3q ǝA;wqQKĸs ƝA;wrĸ3q ǝA;w13qgZ ƝAZA;cw13k3q ǝA;w1͸3qgA;w1 b9qg Ɲw\'qg A;w13qg Ɲ/ĝA;w13qgA;w1 b9qgƝw0 bĸs ƝA;9 b3q ǝA;>ǝBJ\| Ҝg ƝA;ww)a9qg ƝA;9 bĸsƝA.q ǝA;wrXKĸs ŝ1;wqĸ3q ǝA;w13Hqg rs% b9qg Ɲw1 bĸs ŝ1;wrĸ3q ǝA;w)3hs ƝA;wrĸ3q ǝA;w)|% bĸ3q ǝA;wr3qg1;w13qg Ɲw1 b9qgƝA;9 bĸ3q ǝA;wqaĸ󅖸3qgA;w1 b9qg ŝcw1 ?˺ĝw1 b9qgƝA;8 bĸ3q ǝA;wrĸ3qgA;cw13?wԸ3}/tN\:q.5ԥƝ/;w~q.5ĥw҉;wSqPNƝ4ġwPN\:qPN|?I{lwЉ;qĝԸN܉K'ԥƝB;q'ĥwRN]j܉K'ĥw 5:qPNĝ2;?~ĝ/;a}\N]jK;y)q.5ԥĝq'/=7ĝnuN]jܩK;uN]jK:qPN:qPN:q'/=~Qo.w7ĝԸSwc}NŝU:qƝԸSwGĝԸ?Z'jI?Z'Էq.5hSw}։;y?Z;uq'=GĝԸwsN܉;q'/%ԥƝԸ?Z'jI?Z'Էq.5ۯGhS׸uNjK:q.5ԥƝD:q.5ԥƝߨw]7ĝD:q;y龿Q'ĥwmNܩKܩC;y辿Q'ԥƝtߨw 5$ߨw oܩK;uNƝD:q;uq.57ݥĝ:Ը>Q'ԡƝԸuN]jItDE:q'wsNItݟw 5޸nuN]jܩK;y辿P;a;y趿P'ԥƝԸwRN]jjFS|cNt_w 5$։;uq.5j5ġwPNjSwmNܩK;uq'/Wq'e&ݸSgw}/։;w oK:q.5ԥĝq.5:貾N'$zӣq'uNܩK;uq'/ĝƝԸtN]JC_CNGIN':S:h?s_w>q'.tN:tN]jKu:q5'5ԥƝt_wRNSNƝD-Ӊ; hܩK;y鱿N'5:SwPNӏq^zw7Erg;y3˝A\ r -˝A\ rg;y3˝A\ .wq3˝ .wrg;nXr /wq3˝ .wqs; .wrg;9˝A\ rgS˝/,wiH˝A\,rg;",wh3˝EZ,rg;Y"-wi3˝EZ,rg;Y"-wqH˝EZ rg;Y.wiH˝Y"ێ"-wi3˝E_}ziH˝A\,rg;"-wi3˝EXrg;Y"-wq貿Q^,rg;Y .wiH˝EZ"-wiH˝A\,rg;c}|SWiH˝A\,rg;Y"-wi3˝EZ,rg;Y"-wqH˝EZ,rg;kY .wiH˝EZ"-wi3˝EZ,rg;Y"-wqH˝EZ,rg;Y.wiH˝EZ rg;Y .wiH˝A\,rg;"-wis;Yt(/wiF˝EZ rgFyH˝A\,rg;"-wi3˝EZ,rg;Y"-wi?Q\rg;Y .wiH˝EZ"-wiH˝A\,rg;Y"-w='˝EXrg;kYyC_9 yiγHsA,ҜgcX|gk;9 bĸs ƝA;cwrĸ3qgA;w13qg ŝ/ĝA;cwrĸ3qgA;w1ĸ3qg矸`9qg Ɲw}/w13Hqg ŝcw1 b9qg ƝA;9 Røw\i;wrĸ3q ǝA;w13Hqg Ɲw1 b9qg ƝA;8 Z93qgms ƝA;9 bĸ3Hq,qg ƝA;9 bĸs ŝ1;wqĸ3q ǝA;w13qgA;w0 b9qg ƝA;9 bsΠ Ɲ/ĝA;wrĸ3qgA;w)3qgпY%3qgA;w0 R9qg ƝA;9 bĸs ƝA;wbø3qŝAwk9q -q ǝwrmq ǝwrBK9q ǝ/ĝwr9q 9sZA;1󅖸sA;_h;9sZA;9󅖸sA;_h;9ĸs?h;w13qgM?ĸs ŝ1;9 bĸ3q ǝA;w13qgA;w1 b9qg Ɲw1 bs ƝA;_h;wA;9 bĸsΠ/O Ɲw1 bĸs ƝA;9 Rø3q ǝA;wrtߨ% b9qg Ɲw1 bĸ󅖸3qg Ɲw1 R9qg;w13qgA;wGk;9 bĸs ƝA;wrĸ3qgA;cw13qg Ɲ/ĝA;wrĸ3qgA;w13qg Ɲw1 R9qg ƝA;9 bĸ3蹿QKĸ3q ǝA;w13qgZ ƝA;wbø3q ǝA_ĝA;9 bĸ3q ǝA;wrĸ3qgA;w1ĸ3?Q;cwrĸ3q ǝA;w1|% bĸ3q ǝAOc~%A.>X| b9sA;cwbø3?[K9qg Ɲw1 Røs ƝA;wrĸ3q ǝA;w=Wk;w03qg Ɲw1 b9qg Π?qs ƝA;9 % b9qgƝA;8 bĸs ƝA;wr3q 9ow13qgA;w1 b9qgƝA;9 bĸs ƝA;wq~s9qg ƝA;9 bĸs ƝA;ww1 bĸs ƝA;9 Rø3HqǝA;wrĸ3qgA;w13Hqg Ɲw1 bĸs ƝA;8 0 zw1 b9qg ƝA;9 bs ƝAgYs ƝA;9 Rø3HqǝA;w13qgA;w1 b9qg Ɲw]KwjtN\:q.5ԥƝ/;w~q.5ĥw҉;wSqPNƝ4ġwPN\:qPN|\Nj܉C'ĥwRN\:q'.Sw 5ǝNܩK;uq'.N)ԸĝB;w4w~#$q;uq'/%ĝԸSwPNjܩK;wwRN]jK;y)qPNa(qPNĝ4ĝB;#޸SwRN^SwPN^J܉K'$J܉;q'/%ԥƝԸ(qPN;F;-hܩK;y)q'/=7ĝƝߨwRNoԉ;uq.5$oԉ;uq'/7ĝB;7ĝB;7ĝFtN\:q'}NܩK;uq'/=7ĝ:Ը/;nuN};uq'}NܩK;nuNƝDuN} w?stwRN:q'/=Gq5hSwRN^z։;q'ĝԸSwGĝB;Gĝ4ԥƝthww}}NܩC;y麿Q'ԥƝԸ趿Q'ԥƝԸuNF蹿Q'Էq'/7ĝtN^oԉ;q;uq'7ĝԸuNƝDuN};uq'uN)Ը貿Q'ԷߨwRN^z]JܩC;nuNjܩK;y?Q'ԥƝD_O[D}W4pO^z)>uNƝwmNܩK;u)q'gq>q'gĝԸSwRN]jܩKl5y։;u7jSq'uNܩK;uq'/Wq'wWĝԸnuN]jܩK;yq'e&ݸSgw}Ӊ;w oKq:q.5ԥĝq.5:貾N'$zӣq'uNܩK;uq'/ĝƝԸtN]]ĝ/w~*WrγHsE geϘA;w13qg Ɲ/ĝA;w13qgA;w1 b9qgƝw0 bĸs ƝA;9 b3q ǝA;w13qgA;w1 R2K3q ǝA;nĝw1 b9qg Π?qs ƝA;9 % b9qgƝAOǝA;wrĸ3qgA;w0|!ǝ1mZ Ɲw1 b9qg ƝA;9 Rø3?NKĸ3q ǝA;w)3hs ƝA;wrĸ3q ǝA;w)|% bĸ3q ǝA;wr3qg1;w13qg Ɲw1 b9qgƝA;9 bĸ3q ǝA;wqaĸ󅖸3qgA;w1 b9qg ŝcw1 ?˺ĝw1 b9qgƝA;8 bĸ3蹿NKĸ3q ǝA;w1ĸ3qg?h;.%E~ĝFAwtN\:q.5ԥƝ/;w~q.=w҉;qĝB;N)ԸSqPN| wЉ;uq'.Sq'>q5ġw҉;uq'.NܩK;wN܉K'ԥƝԸN܉K'j tNƝB;ew~;?_w?q.5ĝSwRNJܩC;uq'QN~\N]jܩK;y)q'/%jI? %jIS߂ƝSq'u}~ĝwRN^JKwPNjK;qĝD;q'ĝԸSw%jI5Ct]ߨq;uq'/%FS׸uN]JC:q.5ԥƝD:q.5FSq'FSq'Fި7N܉K'$oԉ;uq.5FSw&JܩӍ;E6$։;uq'mN)Ը{NܩoAN]jK:q.5$wswPNz։;uq'/%hwN^JܩK;uq'mN)Ը{NܩoAN]jK_K:q>q'/Gĝ:ԸNܩK;uq'mNܩK;uq'/=7ĝD:q'sNܩoAN^oԉ;qĝtߨwwPNoԉ;uq'/]7ĝB;7ĝwRη򻲱?\jItS|SZ|RN^z]JܩC|OYN~XNjܩK;y龿['ԥƝD_[߭w ?q'/[o/=wĝD:qPN};y鶿['ԥƝոSָnuN]jܩK;y)q.5ԥƝDw3Hc8Mgrf3c1\͌hf63p23F1̌^eh-3Fc1-eh(s w2c4d72c41Ȍ>f1c91ƌ4.c\y.ff1p3F1I-bh3F{c85ah s 0c!1 fV0c491x3F1_h2Fӗc|/f0p 3FK1ŒyOg0c1fm}<9h2FCcsrY_"\hr 7.c4q1Ѿe-cn2Ѷe-cl9Ö1ڵѬZh2F1E Zhr,Cf1mYe,c4d9;1eF,p2F1ZрWh2Fc8^MW`E<\VjeF+cY1\`e*h2Dk1U9S1ZPT|ύW*c4R91 BeSh2Fc8NmMShr )cKYʗ*ee}mII1\ e(p2Fk1NQ`2DC1ڡPhr 7(c4A Pdۋc8>MOhyr 'c;1\d6'c09"^d&c479k1NM`i2DC1ؙ™Lhdr 7&c41 Ld%c.91ؖ Ѵd%pX2F1ѪJhS2C(ўd$_k1іNIhI2FC1ڑH`Dr7$c4!$p?2F1ZlGh:2ˑC8Fh5r G#c1\`dm}o<9Fk!VLE\RoVrNBKO8A A[S8Q WrX8e -i n .|!cr`BKa8ȉ 6cRrf8ȝ - rkBKl8ȵ 熃rq8 - GXqvma = b|p 1 @ b1 WA!1D1)b[AX#1G b8Ab &$1J b,q A,_hI&A9O b@q Š/mN F\)1S bPqK Al9V RsߨW`1bAn.TA[ brq AX/В/_ bĂq 6AǸb bc>wbU.2e15cs 4h b8Mc VAk bIJ1i 1X7rľ1c Z 6Ar b1 AL:r1c{AX<)y1c f=1| bq ƏA9 b2 'Al A*O_~% ƑA#1a@r ɠZr D b&r VA" bt%62qdA#c.@2 'Al$Ir%L2dCZJ Al%Kr-\2 A,&Lh2Hd A&cN b:9d ֓O R@Âr 6A(dA(RrIĔ2-ebʗYj 1)9 bQĤ2M GA*UbWð2E02qeA+i ,XXrb2e*1,Y12e[ Ɩ\[)aoB.c.۴$Al.9 bur A,/^r{2eA/`3 f# Ucabr3-fcA1c 3Ef 5/DA2e03efAn3gư R9}f h bJs3 vA 5 RV3 ךA5k=i)6lh3h?l3 -f n1 b|s A*88 b/~u89 bĐsK 1l9sqĜ3=gA.:t3Ug vvư bmmgĝw13qg Ɲ/ĝA;w13qgA;w1 b9qg Ɲw1 Røs ƝA;9 bĸ3q ǝA;w13qgA;w)aBKYHqg"ŝE;w1,BY3qg"ŝE;w),RYD8ĸHqg ƝE;w) bYHqg"ŝE;w0,RYs"ŝEq ƝE;w1,),RĸHqg"ŝA;w) bYFqg ƝE;w1,o"ŝA;w) bYHqgA;w),RĸHqgƝE;w3qg"ŝA;w),RĸHqg ƝE;w) bYHqg ŝ5;w1,RYHq ǝE;w1,RYHqg"ŝE;w),RY3qg"ĝ1;w),RĸHqg"ŝA;w) BlTYHg"E*>yHqg"ŝA;kw) bY?\;w1,RYHqg"ŝE;w),RY3qg"ŝA;k.ŸFqg"ŝE;w),RYs"ŝE;w1,RY3qg"ŝE;w!QFqg"ŝA;w) bYqg ƝE;w=qg"ŝA;w),B9qgŝA;w),RĸHqg ŝ5;>] ƝE;w1,'ǝE;w!QY3qg"ŝA;w),RĸqgA;k.丳Hqg"ŝE;w),RY3qgŝE;w),RĸHqg"ĝ1;o;w),RY3qg"ŝA;w),B9qg"ŝE;w),Rĸqg"ĝ1;w) bYHqg ƝE;w1,BYHqg"ŝE;w1,RY3qg~FqgA;w) bYHqg ƝE;w0,RY/~qg"ŝE;w!QY3qg"ŝE;w),RĸHqg"ŝA;kw)|%,C#%>=qg"_ĝtN]jܩK;?_w 5q?N]j܉K'ĥw 5:qPNƝB;-h܉C'ԡƝtNƝƝ:ԸN܉K'ԥƝtN\:q.5j܉;q'.SwRN\:q'.Sq'Љ;w %i;#|GI? wRN^JK;uq.%ĝ:ԸSw%%ԥƝԸwRNƝD0QNƝD;-hK;w]7Gܩ/q.=wRN^SwPN^J܉K'$J܉;q'/%ԥƝԸ(qPN;F;-hܩK;y)q'/%jܩkK:q.%FSwRNFSwmN)Ը{N)ԸkNK_oԛK'ĥw7ĝԸSwc}NܩC;y鶿Q'KU;uq'}NܩK;nuNƝDuN} wRN^։;uq'hոSwcNܩK;y)q'/=GĝwRN]jܩK;nuNƝDuN} wRN^z^z։;q;y>Z'ԡƝtw}F+[||OpSZ|RO^z)>.uNpS߂ƝN܉K'pSSw}NܩK;y?\'jI?\'޸Sw]ĝB;.uN} wRN]jK_׻K;uq'm}NܩC;uq'/?[5ԥƝD_O[؟w ?q'/=Qo/='ĝD:qPN};y?Q'ԥƝ ոSָn uN]jܩK;y)q.5ԥƝDw<ĝw}N)Ը?P'ԥƝԸnոN܉C;iuN]jK:q.5ԥƝtƝ4}S_tNiI?N'jܩ/q'/%8Sw;q'uNܩK;uq'/ĝԸ{}N Ը沿M'7ĝԸ(q'}Nܩ/q'/]ĝԸSwmNܩOkܩK;y?N'ԥƝtƝ2;o;wq'/ĝB;w oܩK;uq'/]שq'NK/NܩkܩK;y鱿N'$Ӊ;hIt_wRN]jKu:q>q.5:Sw㯭w}Ӊ;y鹿N'ԥg}{鱾N'$ĝO܉K':(q>q'/=ĝԸtNjKgYOܩkܩK;y龿N'ԥĝ bwrĸ3HqǝA;w13qg Ɲw1 b9qg ƝA;9 bĸ󅖸3qg Ɲw0 b9qgp-qgA;w1 b9qg Ɲw1 bĸs ƝA;1OƝw1 b9ɸ3qg Ɲ/ĝA;w13qgA;w1 b9qgƝw\1 b9qg Ɲw1 Røs ƝA;wrĸ3q ǝA;w)|% Røs ƝA;wrĸ3q Ɲ1;>]A;w13k3q ǝA;cw)3qgA;w1 b9qgƝ/3沿MKĸs ƝA;9 bĸ3q ǝA;cw13qgA;w1 R9qgq ǝAqZ Ɲw1 b9qg ƝA;_f;w1 b9qg Ɲw)as ƝA;9 bĸ3q ǝA;wr3qgA;w1 b9qg ŝcwgw1|% bĸs ƝA;wrĸ3HqǝA;ϲ.q ǝA;wr3qg1;w1 b9qg Ɲw1 bĸsƝA;- ;ߍ5|7/:ĝtN]jܩK;?_w 5q?N]j܉K'ĥw 5:qPNƝB;-h܉C'ԡƝtNKN|\Nj܉C'ĥwRN\:q'.Sw 5ǝNܩK;uq'.N)ԸĝB;w4w~#$\N]jK;y)q.5ԥĝq'/=7ĝnuN]jܩK;uN]jK:qPN:qPN:q'/=~Qo.NItߨƝԸSwc}NܩC;y鶿Q'ԥƝ{]ܙ_uwwRNhSq'hS߂ƝԸuN]jI?Z'h5ԡƝP'ġƝ4:q.5@SwRN^TN>Mܩ/q4$w 5޸tN]jܩK;yqz{?N'ԥƝԸntN]jI>N'jIsߦwpN]jI辿M'޸tN]jܩK;y?N'ԧ5ԥƝwRN^SNƝDƝB;߸ntNƝDtN]jܩK;y麿N;qĝ8tN^9pN}\N]jKu:q'e}NI\_GN:SwRN^Ӊ;q;uq'/ĝ^w_<;q;y鹿N'ԥg}{鱾N'$ĝO܉K':貿N':Sw}}NܩC;y_,;q;uq'/ĝԸSq'd}ntN}wQvGqXGEg&*p{*#v_s}M[YɥuZܩ+~wj)SCŝ y y Ɲ{F; w6l$9qg#F;w6l$ܙpg#F;w6LDHpgDĝ; w&"l$Hpg"F; w&"l$H3qg#Fm;'2s#Fwnܹpg#΍~Ɲw6s#΍; wnܹpF;7pF=~o#6l$ܹpF;7sqg΍;7LDܹpFF;7pF~;;7l$ܹpFw6s#F;pFw6~;7l$ܹpF;7s#Dĝwnܹpg#΍;7ws#΍;OspF;7s#FwnHs#΍~Ɲ߫$>7s#F@|nHs#΍?w&"s#Fwnܹpg#΍;7l$ܹpFw6sqg΍;7pFwnHs#΍; wnܹpF;73qFwns΍; wn~;7l$ܹpFw6s#Fwnܹpg#΍;7lܹD wnHs#΍; wnܹpF;7s#FwnHs#΍;7l$ܹϸsFwnܹpg#΍;7l$ܹpF?m; wnܹpF;7pF=J3 qF?m; wnܹpF;7p6w[w6s#F'΍; wn3sqg΍;7l$ܹpFw6gܹ pg"ms#FwnHs#΍;7l$ܹϸs΍; wnܹpg#΍;7gFspg#΍;7pFw6s#΍~Ɲi;7s#FwnHsq6;wnܹpg#΍;7pFw6gܹ pF;7s#Fwn3l#ܹ=ܹpg"΍;7l$ܹpFw6sqg΍;7?JHs#΍; wn3sqg΍;7pFw6s#΍;wnܹpDƝO?7w~sQq7E-N-wj/SQqwjK;SQq'ŝ;w**ķC;5T܉ŝ;qŝ*N,-Rq'wbiq;wwbiq;T܉ŝXZܩNEŝ;wΟ;TɥN.wjSK Pq;w;TܩN.wr)SQq'aQpNFwr)SQq';wjK\ܩN wr)KO7|q'>nq';TܩNF;aqQ_pŝZ*Rp'~oN}\q'>7jq;9ߨŝZ*Rq'F-Rq'SQq'ZܩѯZɥN,-NFZܩN-wr|wjKZܩN-rwͯzޏooK%[~V|R񩥊O.}/N-w2z_ŝ\}dŝ*-Rq';~wwr)SKŝZ*d_ŝ;/N} ;Tɥ/ٷKKSWɥ-Pq'>lq;Tq?\;TܩN.}oNFoZܩoAq'K;ߨŝN wryQ;TɥZܩF-^ܩNFSQq'ZܩoAq;TɥowK*d8ŝ*Rq'SKŝ>x>'jq'ŝ\zD}~w2ŝ;wrq?Q;TܩN=SVɡB-Rq;ܩN-w2~w.~w**dܩ/SKŝZ*~;1CŝlSKŝ\zN-wjK*dvO;Ewj8-TTܩ/K㴸SKŝZ ۡ]NF㴸SKŝZ*~wj8-DT~wSKŝ;=iqN.}oN-wj)CqZܩO+Rq'>iq;N5ŝoŝ;_ɥ8-TT~wjSKŝ\_N -N.=Xܩ+Rq'>iq'uZ:}w2_ŝZ*Rq'봸SWܩN.=iq;9_;߯N._ŝZY]<_ŝ:-K;yN;ݯN._ŝZ*|wjKgYw;Tɥ:-Rp'>שSMq'?qN; (Rq'>iq>KuZܩN wryN_pK_p/};݅;'2|Eȸs"Ή;.9qDƝwwNd9q+:pDƝwNd;1ȸs"Ή;1|Eȸs"WtΉ;'2ȸs"Ή;'2|Eȸs"WtΉ;'"Ƹ;wNdܙM?n3qDƝ;wNdܙ3qg"Ή;w&"LD9qg"Dĝw&"LDܙs"Dĝ;'2LDܙ3p4Ɲ;ww&"L?'"ȸ3qg"Ή;$"LD9qg"Dĝ;'2LDܙs"Di;wNdܙ3qDƝ7;'2LDܙs"Dĝ;ww&"LDܙs"Dĝ;1LDܙ3qD?ʟ痈s"/-g"ZDr&LD9-g"ZDh9'LD˙3-Dih9rNd˙3-g"ZWtXDh9'Lv?\LD9-g"ZDr&LD˙s"[Dd9LD˙3-Dh9r&Ȗ3-g"ZΉl9r&LD9-g"ZD谜h9r&圈3 -g"ZΉl9ߨr&Ȗ3-gFs"[Dh9'LD˙3-Dh9rND˙~l9rNd˙3-Dh9r&|ELD˙3-Dh9rNd˙3-g"ZΉl9r圈3 -g"ZDr&LD9-g"ZDih9'LD˙3-Dh9rNd˙3-g"YWsXDih9'LD˙3-Dh9rND˙3?`s"[Dh9'L~˙s"[Dih9rNc˙3-Dh9r&Ȗ3,gZWd˙~˙s"[Dh9'LD˙3-Dd9<鰜r&LD9-g"ZDd9Lt~Ȗ3-g"ZDr&LD9-g"ZDd9_a9r&LD9-g"ZDr&LC˙Hs[Dh9'LD˙3-Dh9rNd˙H3 -g"ZΉl9r&LD9-g"ZDr&gh9rr&LD9-g"ZDh9'LD˙Hs[Ds"[Dh9'L$˙3,4h9=鰜r&LD9-g"ZDh9'LC˙貜wr~w4Q-wD'ZˉZR-K_,ZΟ?R-'rbi-ZNDk9r*TTˉoA-'rjKk9rj95TˉXZ˩ZN,ZN-r*ǭZN-rjKk9SQ-'j9=j9|?/}W˩ZN.=~~ZR,'b95T˩ZNFXN-rjK\TT(f˩Q,\TT|XN}ᵜZR,'rjSC\ZNFgb9T˩ZNFj9aqQ_,ZR,'~oZN}\-'>7j-b99ߨZR-'FR-'SQ-'Z˩ѯZɥ?ިorbi-'FR-j9yQk95TɥFf~ek9=k-j9=k-ZNFõS߂ZN-rr~rjpP-'>k-j9ɥõKZZNFZ˩pԷSK\zp}y?\k9q\zZN rr~rjSKSKZFdvQk9ߨrryQk9KZ˩P-'SK\ߨj9oZN}ᵜZdqQk9r2zߨrjSK\zF}˩ZNFZ˩ZN-rry?Qk9T'~r _ɥOԷK'j-'Z˩S_x-'SKZ~j9az/ZN-rjKZR-'l>j-ZN.=j-ZNFSKZ~j91ClSK\zZN-rjKdvOc9Erj8TT˩/K㴖SKZۡ]ZNF㴖SKZ~rj8DT~rSKb9=i-ZN.}oZN-rj)CqZ˩OR-'>i-j9ZN5oj9_ɥ8TT~rjSK\_ZN ZN.=X˩R-'>i-'uZ:}r2_ZR-'봖SW˩ZN.=i-b99_b9߯ZN._ZW]<_:Kk9yNk9ݯZN._Z|rjKGWrj9Tɥ:R,'>שSM-'?pqNk9 R-'>i->KuZ˩XN rryN_,K_,/}g9Yix(49 OrNË7AixsqNk8-ix4<9 pN3W8'ix49pN7ix|4<9 /oNÛw7ixus|59 OnNË7itns^9mѭ4:9Ϳti3mѝ4:9 l$9 Olх4:F5y4F54F24F24:Fw2L4:F72D4F2>$<|ut'+9P3mt3cNûit3bQix3NbEix3a949 a-4:F0!$Fg04:F704:F/_4:~F/4|F/4:{FW/4yF'/$eF,!4cFg,$oItr^LitrLit2nWL˕it2VNóit2VNÛit2.Vix2 U&ѵit2nUѩ4T9 Uѝ4:S9 Tё4QD'*4:PF)<4NF)64KW)(4M4:IF) 4GF(4:FD(x .QNCit2PN+i~ύoP ix2 P&48?9 O4=9 OOy;Ld\L7'/Nixo2Mѵixl2nMѩ449 M$:3FW&41F'&4:0F%$.ےd]LÒitWrLitTrޔLitQ2 JߓLsitM2IN[itJ2.INCipG2HIxD2nH ixA2H4:9 G49 OG$:Fw#4FG#f4<F#`$ѵ4:j|+2NEѥiCit'2Dѕix$2nDIx!2D$!u4:F!i4 D!.$< FW!(d݄'!"d ӼA1it 2NA%ȿdDž'|E~p"‰,.B8 DFYNdG8!+:$DoNdL 1'Ȟp"‰H )|E*Ȫp"Wt‰ ',ȴp"‰ '2/|E/p" WtÉl '"2b Ndi0a"bÉ 70a"D4&:LDvp"DH'=LD|0DQ Nd1b")i!&"D|EDLDMD85b"rD$&ID&q"DT%Nd21iD7Љ'OLDBq"Dou DT)&SLD8b"RD_ѡ+&WLD8b"D2-&zI$WlDt.&\LD8b"Dԋ'_LDq"D4Q1NdƘ1!c"JƉH2&"fȚ19c"zDH4NdԘ1Yc"Ɖ Q6&"mȶ1qc"D7&"pL$8c"DD'2sLD瘈1Dh;Nd혈1c"lj,<&y|EzLD1Di(>NdF1D Q@&"2d"*ȉ o!QBNd 21DԐi'2 ADH"DNd*2Yd"WtDd9r&l$H,g"ZFd9r6l#H3-g#YFh9o-g#YDd9r&l$H,Dd9=7ʖ3-g#YFi`9`?/,g#YDd9r&l$H,g"ZFd9r6l$H3-g#YFd9rl$˙,g#YFr6l$˙,g#YFh9r6LDH,g#YDd9rl$H,g"ZFd9r&l$H3-g#YFd9r6l$9-g#YFd9rl$˙,g_eH3-g#YFd9r6l$˙,g#YFh9r6L$~h9r&l$H3-g#YFd9'l$i$˙,g#YDd9r6LD,g"Y6d9r&l$H3-g#YFmd9r6l$H3-g#YFh9r6l9-g#X6h9r6l$˙,g#YDmd9v-d9r6l$˙ѯql$˙,gYFih9r6LDH,g#YD`9rND~l9r&l$H3/YFd9r&lF,g"ZFd9r6l$3 -g-g"ZFd9r&l$H3-g#YF`9l$H,g"ZFd9r6l#3 -g#YFh9r6l$˙,g#YD`9r6LDH,g#YDd9rltr6Ȗ,g#YDd9r6LDH,gZFr&l$H3-g#X6`9r6l$H3-g#YFh9r6l$˙H,g#YWtXFo}>Zr&WKk9T˩ZΟXNE?˩ZN,ZNE~r*TT˩߂ZN P-'r*rjCk9SKXZˉZTTˉ[ˉZR-'rbi-ZNDk9r*TSwyd? j9TɥXN.rjSKP-j9rb9T˩ZN.rr)SQ-'aQ,ZNFrr)SQ-'b9rjK\˩ZN rr)Kk9rrr)SKZd˩W@b9-R-'b9~rj9yQk9ɡFR-j9=7j-j9ߨj9oZNE~oZN.}F}Kk9=7j-j9TɥϟިOrR,j9Ty?\k9Tq?\k9r2zrjKõSKk-'~W-j99y?\k9TɥXN.\R-j9=k-ZNFõS߂ZN-rrprryj-j9qQk9T˩ZNFZ˩ZN-rr~r2zߨ~oZN} j9ߨXZɥFrjCZ˩ZN.}oZNE7j-ZN-r2ߨj9oZN} j9T˩ZN.=x[P-'DP-j9Zdmy?Qk9'ۥDTT˩/?^zOZN-rj)CԇrrqPk9T˩ZN.rjSKrk9j9}ZN-rjKZN ryZN-rrq?Pk9T˩ZN.=>]˩ZNF㴖SQ-ZN.}܏ZN-rj)C?o~u=`k9}܏ZN-rjKqZ˩ZNF㴖Q-'mZˉoZN-r2dߦk9qMk9T˩XN=i->SK\Z~j9r2:r*?~-'㴖SQ-'qZ˩ZN-rr~j91Ck9r`->SK\_i-'Y~rjSK\zܯZN}\-j9_ZӷC],d~Nk9~rj_v|r2g봖_ZN,:dvNk9~rjKuZ˩ZN.]]˩R-'봖SK_ZN5o:7SK\_ZN.=i-b95Tɡ:}?/}.+:rN仜.Dwtw9']Ή|w9']Ή|]Ή|s"w9_rN㻜.+:rN仜.4.D.D9r.D9rN仜9rN仜9+]i|˙w9.D˙w9.g"w9.gw9.g"LĻ.g"LĻxs"LĻxs"LĻx3rN仜x3rN仜x3r&]i|3r&]WtLĻ/7JĻ.g"LĻ]D¿+r&]Ή|3r&]D9r&]D9r&]4˙w9']D˙w9']DouLĻ.g"LĻ.g"LĻxw9.g"LĻ.gr4+us.g"LĻ.g"LĻ.g"LĻxs"LĻxs"LĻx3rN仜x3r&]Ήx3 r&]Ή|3ћœx3r.g"LĻ.g"LĻxs"LĻxs"LĻx3rN仜x3|x3r&]Ή|3r&]D9r&]D9r&]D˙w9']D˙w9_q3r&]D9r]D:r&uQ]D9r&]D˙w9']D˙w9']D˙w9.D˙w9.D˙~|3 rN仜x3rN仜x3r&]WtLĻx3rN仜x3rN仜'˙w9']D˙w9']4˙w9.D˙w9.D˙w9.gw9.g"LĻ.g"LĻ.g"LĻtw9.gw9.g"LĻ.g"LĻ.gL9r&]Dq:r&u?N]D9r&]4˙Hw9]D˙w9']D˙w9.D˙Hw9.+]4otLĻ.g"LĻ.g"LĻxs"Lix3rN仜x3rN仜˙Hw9]D7w9.g"LĻ.g"LĻ.g"LĻtw9.g"LĻ.g"LĻ.g"LûtsLĻxs"LĻx3rN仜x3rN仜t3 r&]Ή|3r&zޯqs"LĻtsLt.g"|E]D˙w9']D˙w9.D˙w9.4˙w9]=rN仜x3rN仜t3 r&]i|3r&]D9r&]D9r&]D˙w9']4˙w9?q찜r&LD˙3-g"ZDr&LD9-g"ZDh9'LC˙s"[Dd9rNd˙3-Dh9r&Ȗ3-g"ZDr&LD9-g"ZDih9_a9r6LDH,g#YD`9r&l$H,g"ZFd9r&l$H3-g#YFd9r6l$˙,g#YFih9r6Ȗ,g#,g"ZF D~|r6LDH,g#YDd9r&lF,g"ZFd9r6z([Fh9r6LDH,g#YΉl9r6l$˙_3rl$H,g"ZFd9r6l$H3-g#YFh9r6l$˙,g#YFd9r6LDH,g#YΉl9r6LDH,g#YDd9r&zl$H,g"ZFeH,g#YDd9r6LDH,g"ZFd9r&l$Hs"[Fd9r&l#yQ~o-g#YDd9r6LDH,g"ZFd9r&l$H3,gl#˙,g#YDd9r6Ȗ,g#YFh9r6LDH,g#YD`9r&l#H,g"ZFd9r6lF3-g#YFd9r6l$˙,g#YFr6l#˙,g#YFh9r6LFя?`B3-g#YFql~l9r&lF,gZFd9r6l$H3-g#X6ry&[Fh9r6LDH,g#YD`9r6LDH,g"ZFd9rlt~LDH,g#YDd9r&l$H,4d9r6LDH,g"ZFmd9rl$H3-g#YFd9r6l$˙,gYFh9r6l$˙,g#X4YFr6l$˙,g#YFh9r6L&H?U[Dd9r&lF,gZFd9r&l$H3-g#YFd9rl$;rNd9-Dr]s"[Ήl9'|EȖs"[WtXΉl9'ȖrNc9-+:,DrNc9-D谜rNd9-+:,DrNd9-D谜rND9-e9r&Ȗ3-g"ZDr&LC9-g"ZDh9'LD˙3-Dh9rNd˙3-g"ZΉl9r&Ȗ3-g"ZDr&LD˙3@s"[Dh9'LK瓈3-Dh9r&Ȗ3-g"ZΉl9rLD9-g"ZDr&zߨr&Ȗ3-g"ZΉl9r&LD˙3-g-4WXg#ZDr&LD˙s"[Dh9'LD˙3-Dh9rNd˙3-g"ZΉl9r&LD9-gZDr&LD˙3-g"ZΉl9r&LD9-g"ZDr&LD˙s"[Dd9LD˙3-Dh9r&Ȗ3-g"ZΉl9r&LD9-g"ZD谜h9r&圈3 -g"ZΉl9ߨr&Ȗ3-g"ZDr&LD9-g"ZDh9'LD˙s"Z4oe˙s"[Dh9'LD˙3-+:,g"ZDh9'LD˙s"[Dh9rNd˙H3 -Dih9r&Ȗ3-g"ZΉl9r&LC9-g"ZDh9'LD˙s"[DouXD氜d9rNd˙3-g"ZΉl9r&M3 -g.-Dh9rNd˙83-Dd9r&Ɩ3-g"ZΉl9r&LD9-g"Y4Ȗ363-Dh9rNd˙3-g"ZΉl9rLD9-g"ZDr&LD˙Hs[D7[Ήl9r&LD9-g"ZDr&LD˙H3-g"ZDr&LD9-gu:,g"Yil9r&Ȗ3-g"ZDr&LD9-g"Y4h9'LD˙3-Dh9rNc˙螡LD˙3-Dh9r&Ȗ3-g"Yil9r&?zXΉl9r&Ȗ3,gZDr&LD˙s"[Dh9'LD˙3-Dih9r]3d9D/ZN-rj/SQ-rjKk9SQ-'j9r*ķCk95Tˉj9qZN,R-'rbi-j9rrbi-j9TˉXZ˩ZNEb9rb9^b9ZN-rr)KZR,'b95T˩XNFXN-rjK\TT(f˩rr)SQ-'b9rjK\˩ZN rr)Kk9rrr)SKZd˩ѯ;Fr[P˩ZN.rrFrr~rj)CZ˩ZN-r2zoZN-rrqQk9r2zߨj9ߨ\fi-'r2zF4+ZNrr|rjKZ˩ZN-r2zZN-r2zZNEk-ZpR-'ZɥU˩ZN}ZN-rr)Kk-'>n-'b9T˩ZNFZ˩pԷSKoo]I\ߨZN.=7j-j9qQk9T˩ZNFZ˩ZN-rr~r2zߨ~oZN} j9ߨXZɥFrjCZ˩ZN.}oZNE7j-ZN-r2ߨj9oZN} j9T˩ZN.=x[P-'DP-j9Zdmy?Qk9'ۥDTT˩/KZ˩ZN-rryPZN=j-j9TɥXN-rjXN6S_w-'SQ-'Z˩ZN-rrq?PZˉZN6Z˩ZN.=j-j9Tɥ@ryߧk95S~r*^ɥqZ˩ZN-rr￮l-'qZ˩ZN-rrq?Nk9T|r"dvMk9 X˩ZNF۴S_x-'>i-j9ɡ8ԧrjK㴖SK\z܏S-ZNFZNEǯ~r*d~?Nk9T˩ZN.}ܯS-'rbh-'_rjK봖:d|>k9}ܯZN-rjKuZ˩R-'봖SKuvE|i-'~߯ZN-}.}ZNF~r^ˉ\_i-'~߯ZN-rryNk95Tɥk9qZ~rj)CT˩џ?m_rjK봖SWɥ:R,j99<_//󿗾!圆rNC9 4T7✆si(8_4Ӑoi7ݜtPnNB9 1ۜjsIh6_4l{i5֜XjNC9 4Ns2i4_44ӈhNBws4i3L#F63h4i3eNCF*3PfiH2HdL#9 9fi4˜bL#Fs:4bi0!L#F3 $i/ӈ_4—i4P^L#w9 e_ۙ4Bid.!L#qF24i-[NCk2eAi,ӈY2X2|eXWL#[FXVV`& ƖۈUNCUF2 L$$i$*T24eaie)ӈRL#H9 e14RQL#BFr4i'HON#N#|t=NCF1|tLH<xL#jH;vL#8 cI49sL#Fq4 I$ypL"ߘF1t4čidӈ6NC٘F1 \ci5iL#8 Ec4Ӑ3fL#̘2dL"8 c14RiaL#˜Fq$i~ҋ/]L#8 b_scFlq4@IdӀ,NBF`14i+UT1 bAWC|m)NCFD14iӈ'N81 lb4&KL#8 Ub42i@'HLsG14ba4Ӑ"DL#8 b14Ri_ b4i?L#~Fp4ID@NBxF04Ri90ayi @&6L#k8 aI4i !3L#ep4爄aWc_F0t4ąid ӈ,0\aI $Ӥp4i !'LMD0 ,$i$ #0a!ihӈ L#@8`4҃7L?;1zc-A-j/PQ jKPQ!!J **&ķC 5TOBEB bhQ!VjK PKJ qk PKՅZ*/B,-0TTahCE*ß_K_!_UjԐK߽_ nȡxC jQ!?.PKEZ:R!2q}zCFTr)PQ!" jKA\ QCu\ DJDF\ FR5#**Hdk6F}1%j*Ka\}Q q\ߨZ N~'j>QKDQK5\zo*EEe7jJEF7j">xv'dK1~,jbQK%\<EZ~-jpQKõvQKŋõ|QQ"ZoA jq?\T~2rp2jCõQK\gZш[ȥF-5j~5**ld~?\K-mRq#Q.}oF}{#QC5\ߨUZ*sR#FtRjyQozGF7jţ%\zoԢG,z~=5TȡF}R#>7jGFR_x j }o*HEe7j!Z*R-$Q-ECj|Dj"RK%\zOԢH-UE26WFrZ~G*^ ɥD-R$9_2I}X$ RRKZR%T.h$Z1dKZ4j@Rᤖ*'I -P$@R%RK5Z*~(ټ@J}ѕ)d~?N)US /8-REB*9qv_8Ra*+Z*d~>N+Wyߦ,R% KFmZf/ΒK۴RKZ~V[-ToɥqZqK.=ǩRM%[ݥKW^rq?Nk/_2zZR&>שCk01K/a0TɥuZ|c2}N嘌>iA*2Tɥ:-Uej,KuZL}:};"LFo>i&{qN4EBM.}ޯRMFoXKi5<_*?EM-߯ӺM-}-Enr~j7o2W~S߀N-Upr~p8_eZP!'rrwrrNd9-DG蝖s"[Ήl9_a9'Ȗs"[Ήl9'|ErNd9-DrrNd9-+:,DrNd9-DrrNd9-+:,DrNcwtYDh9'LD˙3-Dd9rNd˙3-g"ZΉl9r&LD9-g"ZDr&LD˙s"[Dh9'LD˙3,4h9rr&L?'Ȗ3-g"ZΉl9$LD9-g"ZDh9'LD˙s"[Dih9rNd˙3-D7개h9'LD˙s"[D~?1ʟgr&zr&Ȗ3-g"Yil9r&LD9-g"ZDr&LD˙s"[Dh9'LD˙3-Dh9r&圈3 -g"ZΉl9r&LD˙3-Dh9r&Ȗ3-gF3-g"ZDr&L$9-g"ZDh9'LD˙3-Dh9rNd˙3-g"ZΉl9r&|ELD˙3-Dih9rNd˙F3-D7개h9'LD˙s"[Dh9rNd˙3-Di'ʖ3 -Dh9rNd˙3-g"ZWtXDh9rNd˙3-Dh9r&Ȗ3,gZΉh9r&LD9-g"ZDr&L$˙s"[Dh9rNd˙3-Dh9r&|5L$˙s"[Dh9rNd˙3-Dih9v)h9'LD˙s"[D鰜h9'L$˙3,4h9rNd˙3-g"ZΉl9r|Ei鰜h9'LD˙s"[Dh9rNd˙H3 -g"ZΉl9r&Ȗ3-g"ZDr&:rNd˙3-g"ZΉl9r&Ȗ3-g"ZD氜h9r&Ȗ3-g"ZΉl9rL$9-g"ZDr&LD˙s"[DtXDih9rNd˙3-g"ZΉl9r&Ɩ3=C˙3-g"ZΉl9r&LD9-g"ZDr&L~tr&LD9-g"Y4d9LD˙3-Dh9rNd˙3-g"ZΉh9r&;,grGj9ӡZN-rj/SQ-rjKk9SQ-'j9r*ķCk95Tˉj9qZN,R-'rbi-j9rrbi-j9TˉXZ˩ZNEC?XΟXNFϿR-']{XN-rj)CϿ_,j9rb9T˩ZN.rr)SQ-'a'N'd˩oA-'b9r28ߨ/S_x-j9ɥ1k95TɥXN,dˉ[ɥXN-rjQ,ZNF|}o˩oA-j9ɥSWɥZ˩XN=7j-j9TyQk9TɥFTT~r*d7_q?\k9^ˉõSKZpP-'õSKZdZdj9ZN} j9TɥZ˩ZNFõKSCZR,'~ZN|ZN.rjSKõSQ-'Z˩oA-j9v~rj9<ߨFR-j9=7j-j9TɥZ~r2}Qk9-~rbi-'S˩ZN=7j-j9qQk9r2zߨk9T~r*i-j9ɡ8ԧrjK㴖SK\z܏S-ZNFZNEǯ~r*d~?Nk9T˩ZN.}ܯS-'rbh-'_rjK봖:d|>k9}ܯZN-rjKuZ˩R-'봖SKuvE|i-'~߯ZN-}.}ZNF~r^ˉ\_i-'~߯ZN-rryNk95Tɥk9qZ~rj)CT˩џ?m_rjK봖SWɥ:R,j99<_//󿗾O]D9r&]D˙w9_q3r&]D9r&]D9r&]D˙w9']4˙w9']D˙Hw9.D˙w9.D˙w9.g"w9.g"LĻ.g"LĻ.g"Lixw9.g#LĻtr6]Dw9h9rNd˙3-g"ZΉl9r&Ȗ3,gZDr&LD9-g:,g"ZΉl9r&r4Wx~h9r&|ELD˙3-Dh9rNc˙3-g"ZΉl9r&Ȗ3-g"ZDr&LD9-g"ZDh9'L~?\LD9-gZDr&LD˙3-g"ZΉl9r&LD9-g"ZDr&LD˙s"[Dd9LD˙3-Dh9r&Ȗ3-g"ZΉl9r&LD9-g"ZD:,g"ZDh9'LC˙s"[D7개h9'LD˙3-Dh9rNd˙3-g"ZΉl9r&圈3DrȖ3-g"ZΉl9r&LD˙~˙s"[Dh9'LD˙3-Dd9rND˙3-g"ZΉl9r&Ȗ3-g"Y4r&LD˙s"[Dh9'LD˙3,9,g"Y4r&LD˙s"[De˙3?`s"[Dh9'L~˙s"[Dih9rNc˙3-Dh9r&Ȗ3,gZWd˙~˙s"[Dh9'LD˙3-Dd9r&Ȗ3-g"ZΉl9r&L$9-g-Dh9r&Ȗ3-g"ZΉl9r&L$j˙3-g"ZΉl9r&Ȗ3,gZDr&LD9-g"ZDh9'LD˙s"[Dih9rNd˙3-g"ZΉl9r&Ɩ3=C˙3-g"ZΉl9r&LD9-g"ZDr&L~tr&LD9-g"Y4d9LD˙3-Dh9rNd˙3-g"ZΉh9r&;,gr>:˙s"[Dh9rr&LD˙s"[Dh9'LD˙3-Dih9rNd˙3,gZΉl9r&Ȗ3-g"ZDr&LD˙s"[Dh9'LD˙H3 -+:,g#YFh9r6l$˙,gYDd9r6LDH,g#YDd9r&l$H,g"ZFd9r6l$3 -g#YFOr6l?7LDH,g"ZFw>d9r&l$H,g"ZFd9r6l#H3-g#YFh9o-g#YD~?0JLDH,g#YΉl9r6l$˙,g#X4d9r6LDH,g"ZFd9r&l$H3-g#YFd9r6l$H3,gYFh9r6l$9-g#YFh9r6l$˙,g#YDd9r6LDH,gZFd9r&zr6l$H3-g#YFh9r6l$˙,gFr6l$H3,gYFh9([Fh9r6l$˙,g#YDd9r6LDH,g"Y6oEF3-g#YFh9r6l$9-g#YFd9r6l$˙,g#YFh9rL$F,g#YDd9r&l$,g"ZFd9r&l$H3-g#YF`9lF3-g#YFd9r6l(Z6~h9r6LD8r6LlF,gZFd9r6l$H3-g#X6ry&[Fh9r6LDH,g#YD`9r6LDH,g"ZFd9rlt~LDH,g#YDd9r&l$H,4d9r6LDH,g"ZFmd9rl$H3-g#YFd9r6l$˙,gYFh9r6l$˙,g#X4YFr6l$˙,g#YFh9r6LCH?U[Dd9r&lF,g,g#YFd9r6l$˙,g#YFd9r6|El?YCszZDrbi-j9T˩b9TˉXZ˩ZNEj9r[PˉZNEZN rbh-'rjKk9SKj9qk9SKZZN,TTˉh-ZNEjj9|?/}a}\-j9ɥXN-rj)CR-'XN~\,j9TɥXN.r*d? 3TD}rr)SQ-'b9rjK\˩ZN rr)Kk9rrr)SKZd˩ѯ;Fr[P˩ZN.rrFrr~rj)CZ˩ZN-r2zoZN-rrqQk9rw̯|j9\fi-'r2zZN-rjKõSC\zZN-rj~rj~r*d~?\k9-R-'>k-j9ZN.ZN rr~rjK\}?\k9qk9˩ZN-r2zoZNE7j-Z7ۥZ˩|rjKSKoZNFZ˩ZN-rr~r2zߨ~oZN} j9ߨXZɥFrjCZ˩ZN.}oZNE7j-ZN-r2ߨj9oZN} j9T˩G,'Q-rj|rjSK\zOZN-r26rrZ~r*^ɥDR-b99_ZN}X-' SKZR,j9Th,'Z˩KZ˩@R-j9ZN P-'@R-'SKZ~j9ټXN}ѵd~?Nk9r 8R-㴖C>i-j9Tɥ8R-'qZˉ67`-j9r2zoZN}ᵜ\ߦZR,'㴖SV˩ZN.}ޏZN-rrq?Njj9j9rKqZ˩8R-j9qNZˉ\z9SW˩ZN.}ޯZNFo봖udqNk9T˩ZN.=i->SK\zޯZN-rrۡϿ.r2z_\}Nk9珯~yNk93uZˉ/z-'rr~r2z_\}Nk9Tɥ:P-'rjKuZ˩XN}ܯS-ZNF~rP˩ZN.}ޯZN}\-'봖SK|XΟX^rOλ.+:rN仜.Dwtw9']Ή|w9']Ή|w9']Ή|s"|E9rN仜9rNĻ.+:rN仜.+:rN仜.D.D9r.D9r.D9rN㻜G]D˙w9']D˙w9.D˙Hw9.D˙w9.g"w9.g"LĻ.g"LĻ=x3r&]D9r&]D9r&]D{ˎJ4:#XK점Slz :I>w99ƻA .煖] r7 . r}j, rqsw9] r.gw99ȻA.gw9y3A]ΠF-Aw9e+=~. rq3Aв] rqsw9]1 .gw99ȻA zײ] rqsw9]A .gw99ȻA .gw9q3A] rq3Zv9]A .gw99ȻA . rq3A] risw9] rzp3A . rq3] rqsw9] -A .gw9q3A]ΠZv99ȻA .gw9y3A] rq3] r.gm]A .gw9y3A .煖] rq3] r.gw9]A .gs] rqsw9]A .gv9c9ȻA .gw9y3A] rq3HYv9]A .gw99ȻA . rp3XBw9y3s]A e3 .g w99ƻA . rq3A] rpB匹oӲ]A .gw9y3A . ri3A] rqsw9] r.g.gw9]A .gw9y3A .e] rq3] r.gv9c]1 .gw9y3A . rq3]rqsw9] r.gw99ƻArqB.gw99ȻA .gw9y3A] r]]v9y3s]A .g w99ƻA .gw9y3A] rq3] rA.gr)q9fcXq1K9 &cXp^co^ƛcnayCnaygcXmQ9ela9eka9ƚq9cj^ƝfcXi^Ƒ6cha,fcXg(ΌQ4s !20ˌQ(3FM&1*2cdƨ3F5fb1l1cbƨČQ9f2UcaƨQs1//2Fer 1.0(Qs9e1-0Qmr [!*-cZag2FF1Qb/|]0Q_r ŕ1j+cV^eeu1*ǰQTr1 *cSaN2>En)cRƨQH9e2UcQƨQBrSe1'( Q;tr 1&cM^d5cLƨQ0^r sՒ1%ǰQ*R2Fv1$cPIa$F2Fd 1 $cG(Q9qdcXF(Q,r E1j"/$2FEdcCQ 9-d긄Q9d2U1 ǰQr 1cT?a1F!aq E1j0yQ1Fe;ƨvQq S1 ǰsQ1F61HC1D}cՍc7ƨmQ8ect!7c-ah1Db !,c,ƨW\1Fbbc*ƠT Qxv!qHq %1*0PQ<1FuƉ1hC&ƨL01F]b1c%ƨIA8Ebۋ=1c#ƨE1F%bB1c!ƨBAx71JcT (@0Fa1c(=Ay8aecX(:Qsp 1 07Am0Fc. cƨ30Fa "!l c#* c^}aՅcƨ-QZp u1 *QTH1, cƨ'Ü05abCƨ$QHp 3U1ǰ!QB0F!cT1K<sO61zA'ĥRB]jAҷP R+B\:!.P!!)  %jLoAkB:9'ĥ (5)ԡ68tB\:U.5+ĥ uePB|ܳm!.PZRB\:}!.P!I  =2|3$z\KC]jjK߽bC]jmK y(58ԥDIqiuѡ.:dP!QK²zPCć>B@Q R"D^ Q!P;D^JKD$J;-"/%Fԥֈ(=PDF}k-hKy)Y"/}o q-y鵿QMԥĉ<ߨ'RD]jHߨ(R?̯|ש)S$z)>봊prԊtrEp`QZ,RE^z׉u"/=tpQZ.=봋x?\'_jH?\`Է .apQoNǨkK_ՔQ2kNͨKy)=#/})q'i4ԨQZ5=7tB >7ꤍmԥƍFz鵿Qo5pFQ8}NKu#cNKMu#/7ԎD:#FQ߂&ߨ=ҩy鱿Q{%|ԡ<ߨ>RG^o?}o) 7ԥ6D:P3HFR߂RBۥԐ:>Q'ԡ$uH]jItD^uH|᧌'K_uHD&.P^tRM:X䚺^tMjKGWOkK6y鹿N'ԥ Oe(8A A eg(y2CA\  oQq2kw>Ej9r,RYH-g["Ej9rQY3-gZ΢-L37t.Ej9r,RĖH-gZ"r,RY3-gZ"1l9r,RĖH-gZ Ej9r bYH-g["Ej9r,RYH-gZEj9r,RYs["EOt2Al9r,RĖH-gZ Ej9r bY-g ["Ej9r,RYH-g["Ej9r,RY3-gZ"r,RY3H-gZ"Al9>7-gZ Ej9r bYH-g["Ej9r,RY3H-gmr֨ z,RY3-gZ"Ej9,RYH-g["Ej9r,RY3-gZAj9kr,RĖH-gZ Ej9r֨ bYH-gZ Ej9r,RY-Eh9k喳H-gZ"Al9r RYU bYH-g[΢qrY3-gZEh9cr,RĖH-gZ"Al9r֨Ė涿Mn9r,RY3-gZ"Ej9rQY3-gZ"Al9r,BÖhƖ3-gZ"Ej9^j9r bYH-gZ1n9r,RĖH-gZ Eh9kraYH-g["Ej9r,RY3-gZEj9r,RY3-gZ"1l93j9rrYH-g["Ej9r,RY3-gZ΢n9r,RĖ-gZ"1l9r,RĖH-gZ Ej9r RYH-煖Zο_ϵBK9- rA[9- r^hi9BK9- r^-r^hi9Ės[ -- r^hi9s[ -- rrys[ -- rqm-g[ r bĖs[ 1l9 bĖ3- Al9r3-g[An9r b9-g[ r bs[ Al9/Al9 r b9-gЇ'-g[An9r b9-g[ raĖs[Π-L3RcAn9nõAl9r b9-g[ Al9/Al9r3-gZ1n9r b9-g[ r bĖs[ Al9 bĖ3- Al9rĖ3-g[An9r by bĖs[ Al9rrQK9-g[ Al9 bs[ Al9rrĖ3-g[An9r3-g[ r by bĖ3- 1l9rrQKĖs[ Al9rrĖ3- Al9r3-g[Al9cn3-[ Al9 bĖ3-煖3-g[ r b9-g[ Al9 RÖs[Al9rrPK9-g[ 1l9 bĖ3- Al9rrĖ3-gZ,-gZr bĖs[ Al9a"rrĖ3- A㴴Al9 RÖ3H-Al9rrĖ3-g[An9rư弐[Θ6--g[An9r3-g[ raĖs[ Al9 bĖ3H-A7r bĖs[ Al9 bĖ3H-e3-g[ r b9-gZAj9Ǹ bĖs[ Al9rrNK9-gZAl9 bĖ3- Al9rqaĖBKĖ3- Al9r3-gZ1n9r]]ZAn9r3H-g [ cr bĖs[ Al9 bĖ3- 1l9rA[tO-r>Ԗ3|:-'.SrR[Bm9ܷSri9q鴜Bm9N)ԖS-P[N| ri9u-'.S-'>-ġri9u-'.N˩Km9rNˉKԥԖNˉKj tZNBi9er|k9_rԖrRZN]j˩Ki9y(-ԥDi9qi9u-.䥴S-'Q0LS-'QZN} rRZNDr o˩Km9y)-'/M˩Cm9u-'/ĥrǝrR[N]jIS-'}}ԥ7괜SrRZNzoi9u-^ziW~i95ԥr $r $r˥ri9uZN]j˩Km9y>\ԡrR[N]jIrR[NpS-'pS߂ԖuZN]jI?\䥯j˩Cm9y?\ԥ7괜rRZN]j˩Km9uZNDuZN} rR[N^zx~ߨrrs}N˩Cm9y龿QԥԖ豿QԥԖ^uZNFkN˩oA[N^zoi9q鴜赿Qm9u-'=7괜ԖuZNDuZN}m9u-'}N)Ԗ趿QԷ-.ԥFv)-$zOi9u-.>'괜ԖSr鴜Bm98SrRZNzx~=?NԥԖtZN]jI>NjIsߦrpZN]jI蹿MޖtZN]j˩Ki9y?NԧԥrR[N^zS[NDﷶBm9-'/=鴜Bm9>鴜ԖSr}ri9q贜rജԖ^tZN:k}^m9tZN]j˩Km9y鱿Nǵԥ_rRZNx~=k"DtZN^_r珯z鵾N$<鴜OˉK:趿N䥯u:-.:SrҿrrR[N^zi9u)-'ש-L[N?+zi9 h˩Km9y鵿Nǵ:SrP[Nzӷo-^g] r.gw9] -A .gw9y3A/r.gw9]A.gw9y3A. rq3] rqsw9] r.gw99ȻA .g w9/riHA,.gv9]΢qv9Y]"ri3E,.gv9Y]"rqHE,.gw9Y] riHE.g'e"r.gv9i3E,.gw9>zwiHA,.gv9]"r7ʻE.g]7f~%:ޏu~C .gmY] riHA,.gv99ȻE,.gv9Y]"rpHE,.gw9Y] riHE .gv9]"riHA,.gv9]ri3KE,.gv9yHE .gv9Y] r}ow9Y]"ri3E,.g w9Y]"rqHE,.gw9Y] riHE .gv99ȻE,.gv9Y]"rqcY] riHE .gv9^]"riHA,.gv9Ys۟(rh3E,.gw9Y]"r.gv9Y] riHA,.gv9]"rh3H5,.gv9YP .gv9Y] riHE .gv9]"ricY]rqHE,.gw9Y] rhXBv9Y]"rqcY] raFE.gv9^]"riHA,.gv9q涿M,.gw9Y] riHE .gv9kY] riHA,.gv9]΢w9Y]"ri3E,.gw9Y]"r.gv9Y] riHA,.gv9]"ri3E,.gv9Y]"rq5,.gw9Y]"rqHE.g~FE]"ri3E,.gv9Y]"rpHEGW]"ri3E.gv9cY]"ri3E,zw9Y]"riFEвYt/}k9rr9- rr9- ZZAn9rr9- r9- ZZAn9BK9- ZZAn9BK9- r^hi9B_n9Ės[?hk9r3-g[ ra9-g[ Al9 bĖ3- Al9rrĖ3-g[An9r3-g[ cr by b?3-g[An9>w>Al9rrĖ3-g[An9r3H-g]_><-g[ rki9rrĖ3- Al9rr bĖs[ Aj9Ǹ bĖ3- Al9rrĖ3-g[An9r3-g[ r bĖs[Al9} bĖ3-煖3-g[An9r b9-g[ r bĖs[ Aj9Ǹ bĖ3- Al9r3-g[An9r b9-gF--煖3-g[ rư b9-gF--g[An9r b9-g[ r bĖs[ Al9匹O[r b9-g[ Al9/Al9r3-g[An9r b9-gZrư bĖs[ Al9 b3- Al9r3-g[A_l9r Ry RÖs[ Al9rr?PK9-g [Π?`s[ Al9  b9-gZAj9Ǹ bĖs[ Al9rr3-rii9rrĖ3- Al9r3H-g [ r b9-g[ Aj9Ǹ Z3-g[ r b9-g[ Aj9/Al9r3-g[An9rư R9-g[ r bĖs[ Al9 RÖ3- Al9r3-gZ1n93l9r^hi9r3-g[ r}[1n9r]]ZAn9r3H-g [ cr bĖs[ Al9 bĖ3- 1l9rA[tO-AZAn9/rr9-rr9-煖s[An9/rr9-rq9-煖s[Al9Ǹrr9-煖s[An9rr9- ZZAn9rr9-r b9-g[ Al9 RÖs[ Al9rrĖ3-g[An9r3-g[ r b9-g[ Aj9Ǹ bĖBKĖ3 b9-g[ r}|r3-g[ r b9-gۖ]_ȱ r b9-gm3- Al9rrĖ3-g[ --g[ Al9 bs[ Al9rrĖ3- Al9r3-g[An9r b9-g[ Al9aߨ bĖ3-煖3-g[An9r b9-g[ r bĖs[ Aj9Ǹ bĖ3- Al9r3-g[An9r b9-gF--煖3-g[ rư b9-gF--g[An9r b9-g[ r bĖs[ Al9匹O[r b9-g[ Al9/Al9r3-gk3-g[ ra9-g [ Al9 bĖs[ Aj9crrĖ3-g[An9r3-g[ YZ 1l9 bĖ3- Arư zvl9 bĖs[ΠqZZ ras[ Al9 bĖ3- Aj9cr^-gm3- Al9rrĖ3-g[An9rư b9-g[Π8--g[ Aj9Ǹ Z3-g[ r b9-g[ Aj9/Al9r3-g[An9rư R9-g[ r bĖs[ Al9 RÖ3- Al9r3-gZ1n93l9r^hi9r3-g[ r R9-g[ΠK9-g[ ras[ Al9rrĖ3- Al9rĖ3-g[?hk9n+_Z?=]Ԗ3tZN\:-.ԥ/}k9ro-.ĥri9rS-P[NġrP[N\:-P[N|\[NjˉCĥrR[N\:-'.Sr ǝN˩Km9u-'.N)J tZNBi9er|k9_rԖrRZN]j˩Ki9y(-ԥDi9qi9u-.䥴S-'Q0LS-'QZN} rRZNDr o˩Km9y)-'/M˩Cm9u-'/ĥrǝrR[N]jIS-'QZNԥ7괜ߨr;+ouZN}m9u-.$zi9u-'/=봜Bm9>봜Bm9>봜pr鴜tZNpSrR[N^zi9u-'/=봜ԖSr=봜Ԗ?\jI?\ԥtrR[N:-'/}}J˩Cm9y赿Qԥ7괜rRZN]j˩Km9uZNDuZN} rR[N^zx~ߨrrs}N˩Cm9y龿QԥԖ豿QԥԖ^uZNDi97괜FNK:->.-FSr}N)ԖsN˩/-.$oi9r7괜ԥԖ?ި.ԡD:-ԥܟrR[N'Wڟr ?-'/=鴜@m9intZN|N˩Km9r=鴜r}N˩Km9u)-'=鴜Ԗ^tZN]jKqj)Ӗh֖S-8S-'8SrR[N^S[N:-'_SזSrkNIt[_r}ӫ-'}N˩Km9u-'/=鴜ԖtZN]JCӯ^mYķsNK_tZN]z_/鴜D:_i9q鴜_r鴜Nԥ\_rP[N^?zZN}\[N]jKu:-.:iIWEu:-m9u-'/鴜_rRZNjCurK~rûE .gv9Y]A,.gv9]"ri3E,.gv9Y]"rqHE.gw9Y] riHE .gv9Y] ri] ri5]΃yv9yv9.A,.Aw9.gv9.A<E<a ri r]"r]΃yv9yv9.gv9.A<.gv9.A .A<A,.A<E<㯷~A<E<a ri r~]9Rcfyv9yv9.gv9w9.gv9.A,.A<a3蟿X.r]΃Y]΃yk}yv9.A,.A.gv9.A<E<aHa r]"r]΃yv9y v9zow9.A<A<aHa r]"r]΃Y]΃yv9.gv9.Aw9kyv9.A,.A<aHa ri r]΃Y]΃yv9yv9.A,.1<E:0{1ǰy1,0xYr10v2Nǰt20sq #˸qq 0p¾q 1/q 1L/q 10k1ǰiä2.0hÞ2ǰfØqZ?dIǨd20cÊq #˸aÄq 0`~q)z2ǰ]t2.|-yR-Q8%q8q8Ɗc*^ƩC*1f0R1LǰP10O:2ǨM4q 8L.q ˸J(q 1J/"q=e#a81q8%q8Vc!!K8 c ^cX^CQyxcavxWcas8e\ap8eQm8qj8c^ƙVc^{4c#, 00cp 1 /p 1L ǰ,1 (+1 ?$qQ8AqN8F5Ƅc^)caGxgcXaDx7caA8ea>8?fK;^[<zp A X^hI1" bE8a; \1% bKĘpkA 9( bQ0M GA rWİ0eaAn . b^8}a 1 RdBKfXΰHaK"Ej 6,BnX0a"%Ej:,RvX0a"Al>,R~Hb &Ej!BaXH! EJ"ňA#G bX)RXB(HUb"uAD,R6qb"A(P bXt.GE)S,RRHbZ"Ŋ\+)W,RX`1b"41T-)[,RpHb ET/)_ bXHc"5ET11c,RXH%cREX3)g,RXq"%Ej5j,RX1ac"Al7n,RľHc &Ej9r bXαHcJ Ej;v,RXޱHc"%Ej9z,RXHc?s;HcǢrX1c"EJ @),R HdB"AL!B) R Ys۟(5 "XD),R(HUd"uF,RY62qd"A#H,R"Fd* e5$J b*YVHdk"E%kL,R2YfHd"eE&N,R:Yvr"ԓ5'O),RAY2 e""UA(kQ AL)R) bMY?N)T,BRYQe "eE*V,RZY2qe啃WɅeˠ51,Re̲HeB"AL-Z(,RmܲHe EJ.\!auY~cwHe"A/T_) bYHf1n0a,RH!fJ Eh1kcƌaYHAf"%Ej2e,RY.3afEj3g,RY>3f "$1l434irYPHfS"E5Tk1,RY`3f͢񣫎6Xm),Rpf"17To),RĀHg 6E8Tq) RYH%煘r_Ěo?%??-|%5 ?_N܉K'ԥƝԸoqP-ԥƝtN\:qPNw 5j)Ը߂Ɲ8tNj܉K'j܉kܩC;qĝtN]j܉K'ĥwRNƝw҉;uq.5ĥw҉;wSqPNƝŝDӱ>q.5ĝSwRNJܩC;uq'QN~\N]jܩK;y)q'/%jI?%jIS߂ƝSq'}}ŝwRN^JKwPNjK;qĝD;q'ĝwRNĝB;>/-Էq.5ĝzmίl񩯡qƝԸSwcNܩK;uq'sNܩK;y)q'/ĝDuNƝDuN^zx~tN\:q'sNܩK;uq'/ևq5pSwRNpSw=ĝB;>ĝ4ԥƝtwRN:q'/}oTNjC:q.5ĝQ'ǝwRN]jIߨw 5$ߨw[иSwFS׸uNjK:q.5ԥƝD:q.5ԥƝߨw7ĝD_uN} wsN܉K'FSm;ԸuN]jK:qPNĝD:q.5$oԉ;w7ĝ4ԥƝԸ?ި.%ԡƝD:q5ԥƝܟwRN'Wڟw ?q'/=ĝ@;intN|NܩK;w=ĝw}NܩK;u)q'=ĝƝԸ^tN]jKqj)ӸhָSq78Sq'8SwRN^SN:q'_S׸S}NܩK;ntNuz5$Ӊ;uq.5:S׸SwsNܩK;yu-w}Ӊ;ykNܩK?:h?_w>q'.^tN:ĝԸtNjKGWOܩkܩK;y鹿N'ԥĝ¿ .wrg;/w6+99s;9˝AZrg;y3˝A\Πp-˝A\ .wqs; .w^hY rg;9˝A\ r/wq3˝A\ .wqs; .wrg;9˝A\ rg;y3˝A\ r .wp3˝ .wqBrg}A^ rg;9˝A\ r /wq3˝A\ .wis; .wrg;A^ rg;y3˝A\ r /wq3˝Z; .wJܩC^ r /w}oԲߨe3˝A\ r /wq3˝ .wqs;A\O;c9˝A\ r /wq3˝A\в .wqs;A^ rg;9˝Awps;c .wrg;9˝A\ rg ;y3˝A\ r /wq3˝ .wi2rg;c9˝A\ rg;y3˝A\.wSr /wq3˝?Nrg;y3H˝1\ r/wq3˝ .wqs; y3涿Mrg;y3˝A\ .wq3A^ rg ;9˝A\ r /wq3˝AZΠ;y3˝A\ r /wq3˝ .wi2rg;A^ rg;y3H˝1\ r/wiY .wq3˝ .wrg;cA^ rg;9˝A\ r/wg -˝A\ r /wq3˝A\ .wis;/~tuY .wqs;Π:-˝A\ rg;y3˝A\ .wq3˝ .wAy3_;/fw13qgΠ -qg ƝA;9 bĸs ƝA;wbø3q ǝA;w03qgA;w1 b9qg ƝA;9 bĸs ƝA;cw^h;w) bYHqg ƝE;kw1,RYHqg"ŝE;w1,RY3qg"ŝE;w),RĸHqg"ĝ1;w)丳Hqg\3qg"ŝA;>@E;w1,zw6+ߐ ƝE;w1,BYHqg"ŝE;wqg ƝE;w1,RY腟丳Hqg"ŝA;w!aYHqg ƝE;w1,RYHqg"ŝE;w),RY3qg"ŝE;w(,RĸHqg"ŝw),RĸHqg"ŝA;w) bYHqg ƝE;w0,RYHqg"ŝE;w1,RY3qg"ŝE;w),R9qg"ŝE;w(,Rĸcw7qg"ŝE;w),RĸHqg"ŝA;w) RYs۟(Ɲ5;w),RĸHqg"ŝw),RY3qg"ŝA;w),Rĸqg ŝ5;w) bYHqg"ŝE;kw1,RYHqg"ŝE;w),RYs"ĝ5;w),RY3Cqg"ŝA;kw ŝA;w) bY?N;w1,BYqg "ŝE;w),RY3qgŝwqg ƝE;w1,RYHqg"ĝ5;w1,RY3qg"ŝE;cww1,RYHqg"ŝE;w),RYs"ŝE;w1,RY3CqgŝE;cw),RĸHqg"ŝA;w) bYFqg ƝE;w) bYqg ΢"ŝw),RĸHqg"ŝA;w!aY_ ƝE;w1,BYqg "ŝE;w1,RY3qg"ŝE;w(,RywWS{}q ǝZA;9A;9BK9q ǝZA;9B;8BK9q Ɲcw^h;9BK9q ǝw^h;9s -q ǝw^h;9ĸs?h;w13qg Ɲ>w)a9qg ƝA;9 bĸ3q ǝA;wrĸ3qgA;w13qg ŝcw1 by% b?!13qgA;>@A;wB̯Ԝg Ɲw1 b9qgƝA;9 bĸsΠp-qgA;w13qg ƝZ ƝA;wrĸ3HqƝA;w13qgA;w1 b9qg Ɲw1 bĸs ƝA;wbø3q ǝA;w1w1 b9qg ƝA;}0 bĸs ƝA;wrĸ3HqǝA;w13qg Ɲw1 b9qg ƝA;9 bĸBKĸ3qgA;cw13c3q ǝA;w13辿QK9qg ƝA;9 bĸsΘD9a9qg Ɲw1 bĸBKĸ3qgA;w13qg Ɲw)a9qg ƝA;9 bĸs ƝA;cwrĸ3qgA;w13qg ŝY ŝ1;9 bĸ3qƝA;wbø3OE03qgA;>i;wr3qg1;w13qg Ɲw)ay!ǝ1mZ Ɲw1 b9qg ƝA;9 Rø3q ǝAqZA;w1 R9qgq ǝA;w13qgA;w1 Ry% bĸ3q ǝA;wr3qg1;w13qg Ɲw1 b9qgƝA;9 bĸ3q ǝA;wqaĸBKĸ3q ǝA;w13qg1;w]]A;w13Hqg ŝcw1 bĸsΠ Ɲw1 bĸsƝA;wWS=|%5 ?_N܉K'ԥƝԸoqP-ԥƝtN\:qPNw 5j)Ը߂Ɲ8tNj܉K'j܉kܩC;qĝtN]j܉K'ĥwRNƝw҉;uq.5ĥw҉;wSqPNƝŝDӱ>q.5ĝSwRNJܩC;uq'QN~\N]jܩK;y)q'/%jI?%jIS߂ƝSq'}}ŝwRN^JKwPNjK;qĝD;q'ĝԸSw%jI1 DtFK2+S|S_CN^JK_uN}\N^z׉;u)q'=ĝԸSw=ĝԸuNƝDuNƝDuN^zx~tN\:q'sNܩK;uq'/ևĝ:ԸuN]jܩK;uN]jIw 5$\p-Էq.5FSw}oԉ;ykwPNzoԉ;uq'/%䥯:q'>ĝSwRNFSq'FS߂ƝԸ?ި_/7ĝƝ\ߨwPN^oԉ;uq.5$zoԉ;uq.5F趿Q'$ߨw[иuN\:q'/=7ĝĝ:ԸuN]jK:qPN:qƝԸ辿Q'jItߨw[иSwRN^zx~Sw='ĝ:ԸSwsNܩK;?_kN܉/ĝDzkNItߟw 5޸uN]jܩK;y蹿P;a;y豿P'ԥƝԸwRN]jI4q'kNܩq'/=ĝB;uN]jܩK;y?P;qĝ8Ը?P'ԥƝwRN]jKjIsߧ;E7ԙƝDtNƝw}NܩK;u)q'=~z/|6+5Y9 y~CZ,rg;Y"-wq˝5Z,rg;Y .w˝EZ rg;"-wiH˝Y"-wi3˝E;y ˝1\,rg;trg;"-wiH˝A\,rg;Y"-wOSqH˝EZ,rg;kY .wiH˝EZ"-wi3˝EZ,rg;Y"-wqH˝EZ,rg;Y.wiH˝EZ rg;Y .wiH˝A\,rg;"-wis;Y"-wiF˝EZ rgFyH˝A\,rg;΢Fy3˝EZ,rg;Y"-wi?Q\rg;Y .wiH˝Erg;Y .wiH˝A\,rg;trg;k-wiH˝A\,rg;Y",wh3˝EZ,rg;Y"-wqH˝EZ,r/waF˝A\,rg;"-wi3H˝5Z,z;P .wiH˝A\,'/wi3˝EXrg;cY"-wqH˝EZ,rg;YA\o;"-wi3˝EZ,rg;Y-wi3˝EZ,rg;Y",wph .wiH˝EZ rg;"-wi˝cY"-wi3˝EZ,rg;Y",wܴY"-wqH˝EZ,rg;Y .waF˝EZ rg;Y .wi˝1\,hH˝Y"-wqH˝EZ,rg;Y.wi_誗;Y"-wq˝5Z,rg ;Y"-wqH˝EZ rg;Y -whH˝˝Uq ǝZA;9A;9BK9q ǝZA;9B7Ɲcwry%s1;/ĝwry%sA;/ĝwr9q煖sA;/ĝwb9qŝA;wrĸ3qgA;w03qg Ɲw1 bĸs ƝA;9 bĸ3q ǝA;wrĸ3qg1;w1w1 ⟐wrĸ3q ĝP Ɲw1 bĸs ƝA;9 Rø3q ǝA;wrt% b9qg Ɲw1 bĸBKĸ3qgA;w)3qg Ɲn;w13qg Ɲw1 b9qg ƝA;9 bĸ3q Ɲ1;wrĸ3qg -qg Ɲw1 bĸs ƝA;9 bĸ3q ǝA;wqĸ3qgA;?gw$F/ VWG $>dCR;w&"ȸ3qg"Ή;w&"LD9qg"Dĝh;w&"3 qg"Ή;oԂ;wNdܙ3qg"Ή;w&"ȸ3qg"Dĝw&"LD9qg2LC9qg"Dĝw&"LDܙ-3qg"Dĝw&zOԂ;'2LDܙ3qDĝ;wNDܙ3qg"Ή;w&"ȸ3qg"4ĝw&"LDܙs"Dĝ;'2LDܙ3pYpg"4ĝw&"LDܙs"Dĝ;'"LCܙKA9qg"Dĝw&zw&"ȸ3pgDw&"LD9qg"Dĝ;'2L$ܙwyߦw&"ȸ3qg"Ή;w&"LD9qg"4ĝ;'2LDܙs"Dĝ; wNcܙhf9qg"Dĝ;'2LDܙs"Dĝ; ww&"LDܙs"DuZpDƝ;w&Ƹ3qg"Ή;w&"LD9qg"Dĝw&LCܙs"Dĝ;wNdܙ3p4Ɲ3ĝ;_т;w&"ȸ3qg"Dĝw&"L$9qg"DÏ.s"Dĝ;'2L$ܙ3p4Ɲ;w&"ȸ3qg"Ή;w&"LD9qgDĝ;:~?͍NS諹;vN]'uzDSg}3S+:sA'zߛ9Ts)DS?{)gęB\ljϪę"\K8q;p~M)DSg]k7qtw*7swDS{s&M4LwM5*ĝjM9,UYM)ĝHM ę:M)T ĝM)ԝM DS&Uui3f⟽4Sw"3fyl7*w2u'&Sw~VdLAc~rL5јŘ;S&ߌgx}C`N D`]*ԝ)wb/uOѕSx;ujSt%]YK.T\X-є[y[-u\j+-<ק:K)ĝ*Kܞk,qRw]`;X+YŕS[k}u.T:U⟽w*u籾:TNEչRwWg)us}u.ĝJJ ԝչϺRw(qwJ(՜չMչzœS;;W;s$>nRw۫s$Mc}u.ĝI)TsWrIܩĝbI\_K%ռ΅jW2IWIs}u%sWI|V|$ΔGs}u.ĝHyΕh #|e"q(Rc}u.DS}}u?{9$TCN1G߿uףӝѹQc}t|DSQw\;E>QgSO*xԙ9;N#;N#:NJ>'2G|U\kє8yOS߈;卺s'36~Qs}r.lĝF9sU#5NM<'Qg؎T3Xkє2kdԝ\Lj;eŨ33_,/%jss#/Nxwj|l͕7JɯZĝE51jks"Ey劸S;:sRE|T"*\;UsFIW"Ds'Y&X+q0wu籾7U(3$sDܩGԝQ\k{o>+<:D)Cĝ*D9{s ">w*u繾7NKHKmHKKmKiHKKHKKFKq)6y)"q)"i)2"i)"i)2"a)"i)2ч"i)"q)"i)"p)KHKHKHKKHK9"i)"i)2"i)"q)"h)"p)"i)2"i)"i)2"i)"q)"h)"q)"i)"q)"a)2 "gHKy)"i)2"i)"i)2"i)"p)"?D\lFZLĥFXlFXLåFZlFZLĥFZlD\lFZlDZlFZ|Ev),EvjL;4|5Ʈ՘uT1|56ƤOWcj94 |5֜ƘriL9_%1,՘q*WbY 1|5pWcj74 |5tXnij6_fQhl4؜`szWc9 4ĚjSi$5'!|5vӐiNC9 櫱ќDs i4_}4Pgih3!͜2fNC9 Y櫱ʜ(siD2_E4ci9 5447e9wyBWc9͛g*i0_ 4$P`NCj>/!_N#{9 4ri._4SiH._4[si-!OPi(-!՘YNCe9+r i,_}4PWih+!VNCW9 Y嫱riH*_E4SNCNj)'!՘RNCI9 !4tQNCE9 嫱r i(_4POih'!rNNC79+hr,dXLNC09 4䒯Zrbih%_4JNC'j$HOiH$@GNB9 u1m}u9 e1.ri"_Q44ӐDi"XCNC 9 -!}}t !'|5fPANCjl !r?!qWc8 4qiz|5F1Dw>õ!ʼn)&SLD8b"RD+&VLC^q"DH'YL?\ZLD8b"D.&]LDz-|1b"D0&aL$8c"2Dt'dLDʘq"cDԌ3NdИ1ID6Q5&"kȮ1ac"D6!nLD8yc"D(_B8&"r1c":DY:&"uLD8c"jD䎉'2xLDHqDDlj>&|LD8c"Dԏ?&LDr"D4 _Ѣ A&LD9%dRDC&zߨC& 2Ed"D4E&LD9]d"DH#'LD:r"4e S??S;y);uS;y(S;uQp'?.S;u;y)SQq'QpNFwRpNF;wRq'/wN*ԡN^ ĥ;w.KʈO/Z(SQq'!F;-(ԥN^ 䥯ẸSWKuq.w;uS;=N]*䥳?\w**d?\w**d?\w_.ĥ;=N]*ԥN^\;up]ܩKŝT蹿QwRq'Qw**dQw[PܩKŝߨ;uF]K_UܩCŝ'N|w'K_uq'D]ܩS_xq'/S;u) Uܩ+䡳PwRq.wRp.wRq'l>N}ŝ;w2zŝTܩKŝt.ġN6S;yŝTܩKŝN64S_tqw2;w \;ys.ԥN:=N?g{.d;uS;yŝTc}.DT}.7N]*d蹿Mw /6]ܩKŝCg.ԧwRq'/}ŝTKg;w2Zw**?~q'/qSQq'qS;uT܉CwŝrN}\q.w:]}}.dNŝtq.wRq'/uSWܩKŝ_;u)N?gcp'uN]WNw2Ϝu_ŝtq'/}ŝN^_;utqw?-_;utq.=NFtq'FŝwRq'/}ŝN^:tq.wPq'=K?}'Ȼ,w&rD^LD\LW,w&rg".w&rD^LD\˝ܙ˝9;p3;'rg".w&rg.wND\LΉܙ˝ܙ˝y3;q3;'rg".w&rD^LDZLW,w6rg#-w&rg#-w6rg#-w&rg#,wrg".w6rg#-w6rg".w6rg#-w6rg;i;q;i;q;i3;i;a3 ;i;'rgߗ;sw"5}F\lFZLFojFZLFZlFZLFZlD\l6ZlD\lFZLFFFZlD\lFZlΉH˝H˝H˝ܙ˝H˝ܙ˝H˝H˝H˝H˝ܙ˝H˝ܙ˝H˝ܙH˝mH˝H˝H˝y;i3;i;i3;i;q;i;q;a3 ;i;i3;i;i3;i;q;i;q;is"/w6rg#-w6rg"-wrg#-w&rgrg#-w&rg#-w6rg#-w&rg#-w6rg".w6rg#-w6rg".w6rg#-w&rgrgOl$rg#-w6rg".w6rg#-w6rD^lFZlD\lFZLFZlFZLFXlDZlFZlD\lFZLFZl6ZLFZlFZLFZlD\lFZli˝mܙ˝H˝ܙ˝H˝F˝~ShD\lFZLFoFZLFXlFXLFZlD\lFZlD\l6Z˝m˝ܙ˝H˝H˝D\l6ZlD\lFZLFZlFXLF7.w&rg#-w6rg#-w&rg#-w6rg".w6rg#-w6r4^lFZlD\lFZLFXlFXLFZlD\lFZlD\lFZLFXlFZLFZlFZLFZl4\lrg#-wNFZlD\lFZlD\lFXLFZl?;q;i3;acܙ˝H˝ܙ˝H˝H˝H˝F˝rgZ/;'2|E ȸs"Ή;Dȸs"Ή;_т;'2ȸ-s"Ή;'2|EƝwNd9qDĝwwNd9q+ZpDƝ=;'2|E ȸs"Ή;_т;'2ȸ-s"Ή;1m3qg"Ή;w&"LD9qg"4ĝw&"LDܙs"Dĝ;wNdܙ3qDƝ;w&"ȸ3qg"Ή;w&"L$9qg"DĝH7_͉;'2LDܙs"DoDĝ;'2LDܙ3qDƝ;wNdܙH3 qg"Ή;w&"ȸ3p-3qDƝ;wNdܙ3cܙ3qg"Ή;w&Ƹ3qg"Dĝw&"LD9qg"Dĝ7j;wNdܙ3qg"Ή;w&"LD9qgDĝw&"LDܙ-3qg"Ή;w&"LD9qg"Dĝw&"LDܙs"Dĝ;1LDܙ3qDƝ;w&"ȸ3qg"Ή;w&"LD9qg"Dĝh;w&"3 qg"Ή;oԂ;wNdܙ3qg"Ή;w&"ȸ3qg"Dĝw&"LD9qg2LC9qg"Dĝw&"LDܙ-3qg"Dĝw&"LD9qg"Dĝ;'2L$ܙs"4ĝ;wNdܙ3qDƝ; w!ȸ3qg"Dĝw&"LD9qg"Dĝ;_͂; w!ȸ3qg"Dĝw&"LD9qgD] Ή;w&"ȸ38-3qDƝ;w&Ƹ3qg"Ή;w&"LD9qg"4ĝȸ36-3qDƝ;wNdܙ3qg"Ή; w!LD9qg"Dĝw&"LDܙHsD7Ή;w&"L%>3qg"Dĝw&"LDܙH,3qg"Dĝw&"LD9qg"4ĝ;1LDܙs"Dĝ;wNdܙ3qDƝ;w&"ȸ3qg"Dĝw&"L$9qg qg"WDĝ;'2LDܙ3qDƝ; wNcܙ3S ȸ3qg"Ή; w!L$9qg"Dĝ;'2LDܙs"Dĝ;wNDܙ3q矈[o,ar4/yщĥk9uSj9r*YN]ĥk9qZNETT˩SQ-'8t-rҵj9q:ˉCrҵTˉKrҵT˩w-'.]˩KTˉKrҵj9]˩SQ,Z߿,YNFԥZN^XN]ԥXNԡZN]dɏԥZN]XN^TT(f˩Q,˩c}YN}ᵜTK4Sj9ub9/Ls~p-'/rR-.r2TTm"c}YN} j9ub9ykrp]˩KׇZN-ԥZN]dߨk9uߨk9r2ߨk9-ԥZN^zoԵTc䥯ԡZNߨk9ub9yk]KT˩KF]˩F]˩oA-.rF]˩F]˩Cߨk9uSj9Sj9u>7ZNFu-'S߂ZN^zoԵt-'/S˩C<ߨk9uu-ZNFu-ZN]dߨk9r2zߨk9-x|oԵTKϿި.rP-'>QrP-.rsԥZNF_D]?Qr*^KgԥZN]Brj9y/ԵT˩K˩KTh,'S_w-'/=ZNEu-.rR-'/ġk9qsԥZN^:u-.rR-'/=>]˩3>ZNEk9y?NrR-.rq?v-'8]˩KTKgԥZNFt-'ZN6t-'rR-'XNFmS_x-'/=ZN]ԥXN:t->Sj9ysԥZN^:T˩XNj9_KgTTcԥZN]:rе8t-'/=SW˩KNr2z__k9}g-':]˩KTKgrR-'/=ZN]_ӏ>X7c䥯uS>/}ӵ3g}-'.]Kt-'uZN]:]˩C?굜ZN]:]˩K<_ZN5NrP˩KNrj9yӵ˩C<\_oK,_r>߾rNd9-Dr69-DrrNd9-+Z,DrNdl9Ȗ-s"[Ήh9|EȖs"[WXΉl9'Ȗ-s"[Ήl9'|EȖs"[WXΉl9'ƖOYDh9'LD˙3-Dd9rNd˙3-g"ZΉl9r&LD9-g"ZDr&LD˙s"[Dh9'LD˙3,4~1߁gr&L?%'Ȗ3-g"ZΉl9/r&Ȗ3-g"ZDr&LD9-g"Y4h9':h9rNd˙}˙s"[Dh9'LD˙3-+Z,g"ZDh9'LD˙Hs[Dh9rNd˙3-Dh9r&Ȗ3-g"ZΉl9r&zob9'LD˙3-Dih9rNd˙3-g"ZWXDh9'LD˙3-Dh9rNd˙3-g"ZΉl9r&Ɩ3-g"ZDr&LD˙s"[Dh9'LD˙3-Dh9rr&LD˙s"Z4h9'LQLD9-g"ZDh9'LD˙s"[Dh9rNth9r&圈3DrȖ3-g"ZΉl9r&zrr&LD˙s"[Dh9'LD˙3-Dd9rND˙3-g"ZΉl9r&Ȗ3-g"Y4r&LD˙s"[Dh9'LD˙3,Y,g"Y4r&LD˙s"[Dh9'LC˙KA9-g"ZDr&zr&Ȗ3,gZDr&LD9-g"ZDh9'L$˙ryߦr&Ȗ3-g"ZΉl9r&LD9-g"Y4h9'LD˙s"[Dh9rNc˙hf9-g"ZDh9'LD˙s"[Ddj˙3-g"ZΉl9r&Ȗ3,gZDr&LD9-g"ZDh9'LD˙s"[Dih9rNd˙3-g"ZΉl9r&Ɩ3~3-+Z,g"ZDr&LD˙s"[Dd9LD˙)rNd˙3-Dd9r&Ɩ3-g"ZDr&LD9-g"ZDh9'LC˙OYDr9-Oj9ZN\Sj9uK,Z?ԥZN\TTˉZNEj9r[PˉCrP-'.]˩W˩C8t-'.]˩Kt-'.]˩Kj9qrҵT˩Kt-'.]˩ѵj9CY/}W˩Kt~~T˩K<˩CT(˩KTK˩Q0Kj9r[PKj9=7^˩KK_1k9oL32c9u^(w-'/rR-.r2TTm"c}YN} j9ub9ykrp]˩KׇZN䥳QrR-.r2zoԵToԵj9}oԵrR-'/=7ZN]dQrFrP-'}oԵTKQrXN]ԥZNFgTTcԷSj9yFxsrs}ԡZN^zoԵT˩KF]˩KTKu-'F]˩oA-'/=7ZN\F]˩ԡZNzoԵTKSQ-'S_x-.r2zoԵj9oԵrR-.r7K:TOԵ:T˩Kܟk9u's~-'/=z~?Qr2zOԵj9rٟk9uSb9y蹿PZN: u-.rR-'/rR-.r2s]KSQ-'@]˩KTKgj9qZNdk9u@]˩KTKdOc9ErL-'qSQ-ZN^zӵT˩Kk9=ZN]ԥZN^:t->Sj9y鹿NrR,'=z~<"YNFt-'/}ӵxs}d9t-'k9qZN^_k9ӵNrR-'/=ZNTrR-'/=ZN]:rdϨuS߀ZN]uSWKgԥXN:}_f9gx7˙s"[Dh9rr&LD˙s"[Dh9'LD˙3-Dih9rNd˙3,gZΉl9r&Ȗ3-g"ZDr&LD˙s"[Dh9'LD˙H3 -+Z,g#YFh9r6l$˙,gYDd9r6LDH,g#YDd9r&l$H,g"ZFd9r6l$S/L3[$Hs"[FFh9r6LD H,g"ZFd9r&l$H3-g#X6˖,g#YD˖,g"ZFd9r6l$Hs"[Fd9r&l$3 -g#YFd9r6l$˙,g#YFh9r6LDH,g#YDd9r6L$F,g"ZFd9rNdH,g"ZFd9r&l$H3-g#YFd9r6l˙,g#YFh9r6l$˙)H,g"ZFd9}o-g#YFr6l$H3,gYFh9o-g#YDd9r6LDH,g"ZFd9r&l$H3,gl#˙,g#YDd9r6Ȗ,g#YFh9r6LDH,g#YD`9r&l#H,g"ZFd9r6lF3-g#YFd9r6l$˙,g#YFr6l#˙,g#YF_eH,g"Y6~h9r6LDml9r&lF,g,g#YFh9r6l$˙,gYΉh9ۼo-g#YDd9r&l$H,g"ZFmd9r&l$H3-g#YF`9r6Zr&l$H,g"ZFd9r6l$s[Fd9r&l$H3-g#X6`9r6l$˙,g#YFh9r6LD,g#YDd9r6LDH,gZFYFr6l$˙,g#YFh9r6LCHSh9r6LD,g#X4d9r6Ll$H3-g#YFd9rl$_Yu.r>9\8 s|u|.o>纹\7s|;ud-l>y纭\5s|{uL.i>纡\4zs|u4.f>׹纕\2Js|m.c_Qʳ:ʳ"ʳ ʳɳɳɳɳɳzɳbɳJɳ2ɳɳɳȳȳȳȳȳrȳZȳBȳ*ȳȳdzdzdzdzcf<˜ztnhb\VlPJD>82,& l~xrlf`ZTNHBl<60*$ מּטּlשּׁﬦﬠ﬚ﬔ﬎﬈fl|vpjd^XRLF@:4.l(" llztnhb\VPJD>82,&l llll~xrlf`ZlTNUզUգUՠ U՝U՚M͗UՔUՑU͎UՋUՈ UӰrZB*⯳ʯjR:" ٮ®zbJ2ꭳҭrZB*⬳ʬcuVuVuVuVuVuV~uV{uVxuVuuVruVou6luViuVfuVcuV`uV]uVZuVWuVTu6QuVNu6KuVHuVEuVBuV?uV}|t'>]ӥ>z/Tq>B]K~TK~TKEus.TT ?PRI.U@<*<:A]*䥳?P R͠. sټB}U:SHc.'TTQ/ti.UR!}=`W2zTrKUtC]*?d>N!"CdMW#pA.$2 Kdߦ'cRԥBE]U䡳?NW,ӊun>E]*`䥳?Nej*48]ۨ8]KuTKu*xġkqG^z9p>QJ ys.dNC2Z_ϢHFu4R#u@:]&ԥbI^z%5C^}o|:]DK_t).}?^\_k*g:]\/J\Ē>BKFt%/}ETwKuR 0y)0qTKu$S2y豿Nj33?Fg7TS5ysǕm_7u)~SJ8y蹾N Y_~lSwv7q.gq-wx7q /&"^"%.^/MMu4Kčև?M-.rR,'/ԡZNXN\Q,'>ZN^ԥZN]d˩Ep}rR-'/rp]˩ẖSb9y׵T˩Ku-.rk9r2k9r2zk9yKrҵu-.rR-'/}oԵ:TKgԥZN]dߨk9uߨk9r2ߨk9-ԥZN^zoԵTc䥯ԡZNߨk9ub9yk]KT˩KF]˩F]˩oA-.rF]˩F]˩Cߨk9uSj9Sj9u>7ZNFu-'S߂ZN^zoԵt-'/S˩C<ߨk9uu-ZNFu-ZN]dߨk9r2zߨk9-ԥZN]_oOb9uYk9uSj9y?QrR-'_OԏD]ˉ/ZN^zDxkd؟k9r 䥳?QrR-.rsj9aZN]ԥZN^zS-']ˉCrsˁk9qTKt-'u:}r2zӵT˩KtZN}\-.rsԥXNz:xE|>ZN^_k9u_:]h?sZN|rҵNr2z_k9ykԥZN^zӵ:TKO^˩ԥZN^zӵCuTSQ1dNrR-'/}ӵZN^:t-.}ӵ<\_oK,_r e3w9'.g7r&.g"re3w9q3w9'.g"r&.DL]DL]Ή˙9w9q3v9ps"r&.g"rN]DL]DȻ˙9w9q3w9'.g"r&.grev9i3w9iv9i3w9av9qv9iv9qv9iv9qv9i3w9iv9}Ӝ_ɱFu~˙H˙KHyv9xHH˙_H˙H˙HmHH˙˻˙HmHyv9iv9qv9a3 w9iv9i3w9iv9qv9.g"r6.g#r&.g#r6.g#r&.g#r6.g#r&.gr6.g"r6.g#r6(r6.g#r&.g#r6.g#r&.g#r6.g"r6.g#r6.g"r6.g#r.g#r6.g#r&.g#r6.g#r&.g#r6.g"r6.g#r6.g/r6.g#rN]Fl]FL]6l]DlQl]Dl]Fl]Dl]FL]Fl]FL]Fl]Dl?Ql]Dl]FL]Fl]FȻH˙HHHm˙Hm/w9qv9i3w9iv9h3w9iv9i3w9iv9qv9iv9.g#r.g"r6.g#r6.g"r6.g#r&.gr6u,v9qv9i3w9폓w9i3w9av9a3 w9iv9qv9iv9}iv9hs"ry&r6.g"r6.g#r&.gm.g#r&.g#r.g#r&.g#r6.g"r6.g#r6.gr6Zq3w9i'r&.g#r6.g"r6.g#r6.4l]Fl]Dl]FL]Fl]FL]Fl]Dl]Fl]Dl]FL]Fl]FL]Fl]FL]Fl]4l.g#rN]Fl]Dl]Fl]Dl]FL]Fl?w9qv9i3w9w9a3 w9iv9i3w9iv9qv9iv9}av9i-.YΉl9_b9'Ȗs"[?f9'Ȗs"[WXΉl9'|EȖs"[Ήl9_-4rrNd9-4hrNd9-DrrNd9-DhrNd9-Dr6˙3-Dh9q"ZΉl9rȖ3-g"ZDr&LD˙s"[Dh9'LD˙w̯xȖ3-g"ZΉl9r&L$9-g"ZDhh9Oɉh9'LD˙s"[DoDh9'LD˙3-Dh9rNd˙H3 -g"ZΉl9r&Ȗ3p-3-Dh9rNd˙3-g"ZWXDh9rNd˙3,4h9r&Ȗ3-g"ZΉl9r&:XΉl9r&Ȗ3-g"ZDr&LD˙s"Z4h9'LD˙3-+Z,g"ZDr&LD˙s"[Dh9'LD˙3-Dh9rNc˙3-g"ZΉl9r&LQLD˙s"[Dh9rNd˙3-+Z,g"ZDh9'LC˙s"[DoXDr&LD˙s"[Dh9'LD˙3-Dh9rND˙}l9rNd˙3-Dh9r&|ELD˙3-Dh9rNd˙3-g"ZΉl9r圈3 -gPȖ3-g"ZΉl9r&LC9-g"ZDh9'LD˙s"[Dh9}b9rȖ3-g"ZDr&LD9-gZD] ZΉl9r&Ȗ38-3-Dd9r&Ɩ3-g"ZΉl9r&LD9-g"Y4Ȗ36-3-Dh9rNd˙3-g"ZΉl9rLD9-g"ZDr&LD˙Hs[D7[Ήl9r&LD9-g"ZDr&LD˙H,3-g"ZDr&LD9-g"Y4d9LD˙s"[Dh9rNd˙3-Dd9r&Ȗ3-g"ZDr&L$9-g -guZ,g"ZDr&LD˙s"[Dd9LD˙)rNd˙3-Dd9r&Ɩ3-g"ZDr&LD9-g"ZDh9'LC˙OYDr_,j9Mt-'.]˩KToSQ-rR-'.]ˉKr*Dt-ZNEj9-ġk9uTTˉԡZNԥZN\ԥZNEk9qZN]ԥZN\TTˉZNEb9rf9r2z\-.rgrR-.rP,rR-'XN~\,.rR-'/rR,ZNF0ߗr2oLOTT>\,Z˩KKc9uSj9y)dˉb9uSj9r*d6>\,TK?\rj9ysԥXN:u-.rR-'p]˩KtZNE>ZNE~}Eĥk9=7ZN]ԥZN^\ߨk9uFrR-.r2zoԵToԵj9}oԵrR-'/=7ZN]dQrFrP-'}oԵTKQrXN]ԥZNFgTTcԷSj9yFxsrs}ԡZN^zoԵT˩KF]˩KTKu-'F]˩oA-'/=7ZN\F]˩ԡZNzoԵTKSQ-'S_x-.r2zoԵj9oԵrR-.r7K:TOԵ:T˩Kܟk9u's~-'/=z~?Qr2zOԵj9rٟk9uSb9y蹿PZN: u-.rR-'/rR-.r2s]KSQ-'@]˩KTKgj9qZNdk9u@]˩KTKdQvwq^MrF 1K|+sztl6),mrꋮL-'q:SQ-ZN.XN-rj)CoӏCXNFq:SKZcR-'q:Q-'6ˉoZd蹿Mr }R-b99c9iZkR-'T˩SQ-k9c9r2c9T˩ZN.שCrbXN.=8SW˩ZN.XNFu::j9XN-rjKu:SW˩ZN.=XN-rruqkc_,'u:Kt,^|ǥ:hyӱұ\zӱnt,'>XN-rr鹾NrjKTrjKu:SKS-ZNFF豿NrP˩ZN.XN}\-'t,b95Tɡ:}X.d9f9'弢rNd9-DrNd9-DWXΉl9'弢rNd9-DWd9-DWXΉl9'Ɩ9-DWXΉnrNdyEȖs"[Ήl9hrNdyEȖs"Zil9DLD˙s"[Dh9rNd˙H3 -Dh9r&Ȗ3-g"ZDr&LD9,;_x~h9rNd˙3-Dh9r&Ɩ3-g"Z+Z,g"ZDSr"ZΉl9r&Ȗ3oEP"ZDr&LD˙s"[Dh9'L$˙3-Dh9rNd˙?\LD9-g"ZDr&LD˙˙3-g"ZΉl9r&Ɩ3-g"ZDr&LD9-g"ZDh9'LD˙s"[DZ,g"ZΉl9r&LD9-gZDr&LD˙˙3-Dh9r&Ȗ3-g"ZΉl9r&LD9-g"ZDr&LD˙s"[Dh9rNd˙3-Dh9=/rNd˙3--3-g"ZDrLD9-gXDr&LD˙s"[Dh9'LD˙3-Dh9rND˙?Qih9'LD˙s"[DZ,g"Z+Z,g"ZDh9'LD˙s"[Dh9rNd˙H3 -Dih9r&Ȗ3-g"ZΉl9r&LC9-g"ZDh9'LD˙s"[Dh9r^b9rȖ3-g"ZDr&LD9-gZD.-Dh9rNd˙8-3-Dd9r&Ɩ3-g"ZΉl9r&zb9'L$˙l9ih9'LD˙s"[Dh9rNd˙H3 -g"ZΉl9r&Ȗ3-g"ZDr&ZrNd˙3-g"ZΉl9r&Ȗ3-g"ZDWXDh9rNd˙3-Dd9r&Ɩ3-g"ZΉl9r&LD9-g"ZDr&LC˙s"[Dh9rNd˙3,4ZDWXDh9'LD˙豿NȖ3-g"Yil9r&?XΉl9r&Ȗ3,gZDr&LD˙s"[Dh9'LD˙3-Dih9r6˙,rpQ-Cˉc9T˩ZK_,ZrjKrbXNETT˩SQ-':SCX:SQ-'>SC:KrjKrbXN-r*ˉc9T˩ZN,ˉc9r":SQ-XN5_,/qZR-b99˩ZN-r2rjSK\R,ZNF0KOrRɥXNEr R-'c94SCR,'dˉ;KZR-'XNE_p}rjK\c9q\zױZcR-j9=XN-rr?\r*d?\r*d{ұX:sR-j9Zߨc95TɥF˩ZN-r2zoԱZdߨc9r2ߨc9-R-'u,j9}oԱ\ߨZN rr赿QrjK\ߨc9qrr)SKZdߨc9r2ߨc9-R-'ި^u,>K:SC\oԱZR-'F˩ZN-rr鵿Qr2oԱ>7XN} j9ߨc9t,'u,>.SCzoԱZ}TTc^˩ZNF:SQ-'F˩oA-j9Tɥ7ꧥXN r2zOԱR-'u,j9ݿ=Q?F:_\z~{~\ܟc9'XNEk9؟c9T˩XN=SVɡB˩ZN-rr)SKZd4k]ɥ@˩}R-j9ZN ˉZN6:SK\zԱZR-'U涿Oc9Erj8˩S_x-'t,j9ɡǷǡ_v,'8˩ZN-rr?Nrj8ˉm7XN-r2dߦc9rr龿MrjSKzӱZN-rr?NrjKqTShV˩S\zӱj9}ӱZR-'Tˉc91t,'_˩R-'^t,':s}^t,j9Tɥ:˩R-'t,b99t:8/:ɥu:SK?k}dr2_c9t,'^t,':ɥu:SK\zӱҿ)c9qZsR,'T˩Q1zӱrjKu:SWɥ:˩XN rr蹾N_,/K?Xy](4Wc9 4dPqi9 4$Pp^4Ӑo^4ěnNCy5nNCy5fPmN#9 ՘lNC9 kNC9 4ĚWc9 4| j^4dPi^44ӈhNBYf4PgL#F4s4I2!L#F(3L4$i$2dǜ3{Zmh1ӈbL#9 f14RaL#s4i/2e64i/]NCv7&eiH.H\L#o9 ei4–ZL"iFr:4bi,!Ls["4XL#^9 ue4iD+Ʋ2`e4bPULS9 Ie4i)!L#MFrZ4i$)RNCGF24Did(ӈP2d4CL{D0 $iӈNCuF0ai(70m{o NCjF0a9i H20:"aFj ӈ.0la4+LV8 Ua)0@ayi @&&LK8 )aI4i!#L#EFp4"i$N#?D|0fin>~ NL&XDbA-jB}AZ"aX:PQ!!# *%TTLoA5!'P=!(TTQ+)PM!*QZ*+qX:PKJ qbB-UjKbCE1TTck2| /}q4rkjPK7P*bTtC.r)PQ?w02 2 >Kᇊׇ@^D.!ri5Tȥ@D,6w,"TrDF at_/&Q߂D-U%r),Ku`>2K:6QKzZOR"pE.=(EEe=7HEF7XE.Q?,=7E-U,jdK:hQCU\zoqZ*\R"FEF:|QQ":Q߂F-0r龿QG1jFȥ*eP-#^u4ȥ:wH#bTԨjdߨ62ߨC-mRq#ި^u|>K:QC5\oQZ*sR#F騥RG-:r鵿QG;2o>7G} Jߨt#uܣ>.QCzoԱZ*~}TTc^HF: RQ$FoA%J!T ɥ7ꧥhH C2zORI$uP"ݿ=Q?F:0_\z~{~\ܟ#'HE $؟C$T# I=LRV'ɡB)RI-Jr)XRKՒZ*d4^k]2ɥ@4j}Rᤖ*'I K-_jKu*1:K/ajKu:m}dNrLFu: SKZ*cUej,Ku:0SK{~zXc:Tq鵾Nh2gt&4t&^t&:ɥu:\SK\z*ҿ)Ճ6qUZ*sR&TxQ1zpjKu:SWɥ:Ʃ8N rr蹾N_(/K?YϿ!ȉ| SD>9AsD>9/B^rr"߄G!h 9BN]ȉ||rȷ!h99CN>-"'ȉ|"HD9D^r'r"ȗ"'+ZnENcZ-"'ȉx0r_m'#fd"W#ld"ލLÑrd"Lۑxd"^Lx?r"L ޟ|'0+yXr"_L䗈g$'D<$$D%$D>'$d"]'%d"dJ&(KN˒xZ2oKN㒉~+K&}ɉ|`2/L&D19L&D<39L&ҡ4ZNMN[xl2MNsnõLċd"ޜLģd"LĻxx˓xz2oO&ɉ|}2O&i|2/P& DA9P&DI7)(e"^g).e"ȗ)4e"ަLW\Lxr"L x2oTN#x2TN;x2/U&ʉ|2U&ҵi|2U&DX9OV&DW2Lf"ɜȇ2Rfʼ"LsߦZf"˜2`f"^̜'3ff"Līlf"LÙx9s"Lۙxę8g"8g"8 g:-'9'M4<ʙW9DYDr/_XDr&LD˙˙3-g"ZΉl9r&Ȗ3-g"ZDrLD9-g"ZDih9'LD˙s"[Dh9rNd˙3-g"ZΉl9r&Ȗ3-g"Y4WXFd9r6l$H3-g#X6h9r6l$˙{iW_O8Dd9r&l$H,g"ZFd9r6l$3 -g#YFr6l?%7LDH,g"ZFAd9r&l$H,g"ZFd9r6l#H3-g#YFh9dr6LDH,g"ZFd9rNdH,g#YDd9rl$H,g"ZFd9r6l$H3-g#YFh9r6l$˙,g#YFd9r6LDH,g#YΉl9r6LDH,g#YDd9r&l$H,g"ZF`9r6l$H3-g#YFd9r6l$˙,g#YFh9r6Ȗ,g#YFd9r6LDFr6LDH,g#YDd9r&l$H,g"ZFd9rO-gYDd9r&l$H,Dd9r6LDH,g"ZFd9r&lF3,gYFd9r6l$˙,g#X6h9r6l?Pd9r&l$H,4`9r&l$H,g"ZFd9rlZr&l$H3-gdH3-g#X6`9r6l$˙,g#YFh9r圈ml9r&l$H3-g#YFd9r6l#H3-g#YFh9r6l˙3-g#YFd9r6l$˙,g#YFr6l$H3-g#YFh9rl˙,g#YDd9r6LDH,g"ZFmd9r&l$H,g"ZF`9r6gd9rNdH,g"ZFd9r&l$3 -g#YFTm9r6l$˙,gYFih9r6l$˙,g#YDd9r6L$F,-?Y?`r^b9'Ȗs"[?f9'Ȗs"[+Z,Dr^b9'Ȗs"[+Ɩs"[+Z,DrNcyEȖs"[+Z,DrNdyEȖs"[Ήl9hrNdyEȖs"Zil9DLD˙s"[Dh9rNd˙H3 -Dh9r&̯ԱFh9'LD˙s"[Dh9rNd˙3-Dh9r&Ɩ3-g"Z+Z,g"ZDSr"ZΉl9r&Ȗ3oEP"ZDr&LD˙s"[Dh9'L$˙3-Dh9rNd˙趿QLD9-g"ZDr&LD˙˙3-g"ZΉl9r&Ɩ3-g"ZDr&LD9-g"ZDh9'LD˙s"[Dh9rNd˙3-g"ZΉh9r&Ȗ3-geE"Z+Z,g"ZDr&LD˙s"[Dh9'LD˙3-Dh9rNc˙3-g"ZΉl9r&LD9-g"ZDr&LD˙s"[Dh9hh9r&圈3 -g"ZΉl9ߨr&Ȗ3-g"ZDr&LD9-g"ZDh9'LD˙s"Z4LC9-g"ZDr&LD˙˙3-g"ZΉl9r&Ȗ3-g"ZDr&LC9-gZDh9'LD˙s"[Dd9rNd˙3-g"ZΉl9r&Ȗ3-g@r^b9rȖ3-g"ZDr&LD9-gZD.-Dh9rNd˙8-3-Dd9r&Ɩ3-g"ZΉl9r&LD9-g"Y4Wd˙涿MLD9-g"ZDr&LD˙s"[Dih9rNd˙3-Dh9r&Ɩ3͖s"[Dh9rNd˙3-Dh9r&弚r&LD˙s"[Dh9'L$˙汿Nr&LD9-g"ZDh9'LD˙s"[Dih9rNd˙3-g"ZΉl9r&Ɩ3>C˙˙3-Dh9r&Ȗ3-g"Yil9r&?XΉl9r&Ȗ3,gZDr&LD˙s"[Dh9'LD˙3-Dih9r6˙_,Ͽb93oӉj9}"':KrjSKXNE?R-'ұj9˩SQ-ZN| j91t,j9t,ZN|\-j91t,'R-'ұZTTˉ;KrjSKX:Kr*Dt,ZNEjj9XK_,'aXW˩ZN.rr)SKZP,j9T(ϥ7L3SBk9˩Q(SQ-'XN} j9˩}}XN}ᵜZR,'rjSC\ұb9qrr)SKZd˩ Fb9-R-'b9?\rj9c9ɡp˩ZN-r2z}NT˩ZN.=7XNE>7XNE~oԱ\z}{~X:Kr2zoԱZR-'^u,j9ߨc9T˩ZNF:SKu,ZNFu,Z}R-':KU˩ZN7XN-rr1Ku,'>XN.rjSKu,ZNFu,oԱ\z|{~\zoԱZN.=7XN rr龿QrjSKu,j9TɥF趿Qr2ߨc9-sұ\zoԱXN rr蹿QrjK:SQ-':S_x-j97XNEnu,ZR-'ިb95T>QrjSK\zOԱZdtD'XN|rrqsdtߟc9r cR-b99_ZN}X-' u,j9TɥXN-rjXN6:S_w-'u,ZNF:SKZcj91t,'j9<XN-rr?PrjSK\zT-'>]˩ZNFt,ZN}ᵜ\ӱZR,'>mرt,j9Tɥ8˩ZNFt,'ZN6m:߀c9T(s^ɥ6˩ZN-rr?Nrj9Tɥ8˩ZN.=ǩSM-'[-ZNrr?Nr*d?NrjSK\S-'б\z9p,>SK\zӱnt,'uzr2ӱZR-'t,>SK\zӱZ"XNFt,'>XN-Ku:>_c9Eˉc9_c9XN.}ӱZs}P-'O˩R-'t,b99t_ZN5c7SK\zӱZN.=XN-rjCub9/}\r.g"w9.g"LĻWLĻx3rN仜x3rN仜x3r&]Ήx3 r&]Ή|3r&]49r&]D9r&]D˙w9']D˙w9.D˙w9.D˙w9.g弢.g#lxr6]F˙w9.gLt]F]wL3R:XHw9.g#LĻtr&]F?r&]FHw9.g#lp3 r6]F9r6]F/5]DHw9.g"lW#lxr6]F˙w9.g#LĻpr6]DHw9.g"lt(lxr6]DHw9.g#w9.g#lxr6]4Hw9.g#LĻtr&]F]F˙w9.g#LĻtr6]DHw9.g#Lmtr&]Fd#w9.g#LĻtr6]DHw9.gr6]FHw9.g#lixr6]F˙w9.g#lxr6]DHw9.g#LĻtrN仜tr6]DFw9.g"l{|r&]FHw9.g"lt3r6]FHw9.g#ltmxr&]FHw9.g#lts"ltr&]FHw9.g#lt3r6]6˙Hw9pr6]DHw9.g"lpr&]FHw9.g"lt3r6]F]i|r]DHw9.g#LĻtr&.glXB LĻtr&]Fw9.g"lmtr]FHw9.g#lt3r6]69ror6]DHw9.g"ltr&]FFw9.g"lt3r6]Fw9.gr&]Fq]F˙w9.g#LĻtr6]i|r6]F˙w9.g#LĻpr6]4Hw9.g"ltr&]FHw9.g#lt3r6]FHw9.g#lix>ts"lt3r6]FHw9.g#linHw9R]DHw9.g"lmtr]FHw9.g"lt3r6]FHw9.glWltOw9ӏrNdyEȖs"[Ήl9DȖs"[Ήl9hrNdyEȖs"[Ήl9Ȗs[Ήl9hh9'Ɩ9-DWXΉl9'Ȗ9-Dr^b9'Ȗ9-Dr6˙3-Dh9r&Ȗ3,gZΉl9f~{%Ȗ3-g"ZDr&LD9-g"ZDh9'LD˙s"[Dh9rNc˙3--3-g")9-Dh9rNd˙"(-g"ZΉl9r&LD9-g"ZDr&LC˙s"[Dh9'Ltߨr&Ȗ3-g"ZΉl9r&LDyELD˙3-Dh9rNc˙3-g"ZΉl9r&Ȗ3m˙s"[Dh9'LD˙3-Dh9r&圈3 -g"ZΉl9r&LDyELD˙s"[Dh9rNd˙3-Dh9r&Ȗ3-g"Yil9r&LD9-g"ZDZ,Dh9rNd˙3-g"ZΉl9r&弢r&LD˙s"Z4h9'L{˙s"[Dh9rNd˙3-Dh9r&Ȗ3-g"ZΉh9'ʖ3 -Dh9rNd˙3-g"Z+Z,g"ZDh9'LD˙s"[Dh9rNd˙H3 -Din2h9rNd˙3-Dh9rȖ3-g"ZDr&LD9-g"ZDd9fd9rNd˙3-g"ZΉl9r&圈3 -g?`s"[Dh9'L{˙s"[DiyDr&LD9-g"ZDh9'L$˙l9ih9'LD˙s"[Dh9rNd˙H3 -g"ZΉl9r&Ȗ3-g"ZDr&ZrNd˙3-g"ZΉl9r&Ȗ3-g"ZDWXDh9rNd˙3-Dd9r&Ɩ3-g"ZΉl9r&LD9-g"ZDr&LC˙s"[Dh9rNd˙3,4:-˙3-Dh9r&Ȗ3-g"Yil9r&?XΉl9r&Ȗ3,gZDr&LD˙s"[Dh9'LD˙3-Dih9r6˙_,_ߐD?XN,˩ZN-r_b9r/SKX:Kr*Dt,ZNEj9-бұj9qбX:SKX:KrjSQ-'>XN,˩ZN-rbXN,˩ѱj9=~C_,/qZR-b99˩Z.aj95rjSK\R,ZNF2XNEb9-R,ZNFb9rjK\˩ZN rr)Kr2ɥXN-rjQ,ZNF/ׇԷSK\z_qsrr?\rj)C:SKZdߨc9TɥF˩F˩:KooKrbXNF:SKZk}P-'u,j9T蹿QrjQ,':F˩oA-j9tߨc9TcFrjC:SK\Fˉ;KZR-'F˩F˩oA-j9Fߨc9q\zoԱ}R-j9=7XN-rjK:mdQr[PɥFˉc9ߨc9qsR-'u,ZNFu,ZN-r2oԱj97XN} j9T˩ZN.=Q?-rjc}P-j9ܟc9T1zOԱD?Qr*^ɥD˩ZN-rr蹿PZN=XN-rjKZR-'l^u,ZN.=XNEu,j9Tɥ@rbXN ryԱZcR-j9ZN6]˩ZNFt,ZN}ᵜ\ӱZR,'>mرt,j9Tɥ8˩ZNFt,'ZN6m:߀c9T(s^ɥ6˩ZN-rr?Nrj9Tɥ8˩ZN.=ǩSM-'[-ZNrr?Nr*d?NrjSK\S-'б\z9p,>SK\zӱnt,'uzr2ӱZ߷駥ZN.=XN}\-j9_c9ɡǡׯE|>XN.}ӱZz}I^t,'}汿Nr>Krr鵿Nr2ӱ\_c9Tɥ:˩ZN.R=SW˩ZN.=XN-rr辿Njj9}:˩o@-j9_c9q\zӱZP-'r_b9mg9UΫQixs䜆94Aixs㜆88-ixj|s✆w8ΫIxs༚8Ixj|~s^ߜ7Ʒ7ixys޼ݜg7ixtj|ssܜ77itns^,6fڜ6fL3fL;ryBLit`3kNit]3kmixZ3.kaixW3jU4:9 ojI49 j=4:4'14F4Ɨ4f4FG44<4:F34VΜ3rfΜw3lf]LffL`f\f]˜2Vfʜ2PfL3W+it$3ndщix!3d}Ix3cq49 Oce4:9͇bY4FG1M4:F1A4F04r^Lit;rLˑIt82FNóit52Fix22.FIx/2:kit,j|+2NEѥix(2m}o|&2DN#it#2 NDN it 2ӗ>9 Cq4 9 OCe$: w!'Y4 FG!&4< F! 4F dF d], ȿMΊ'Nd?8DNdC8DVW0‰'2$ENdJ8-DƄWdM89DW‰, '")ƦT8UDfW‰ ',ȴ[8qDօ^ '20b8DDX6f0DH &"60[nG'28LDq0DF&;0a"Él&>LD~8a"D &r!&B 1b"B+Z$b"RDp"bĉ#&G 1oO"D4%&JLD.q"DH'ML$:1yDQ(Nd趿Q RLD8b":DY*&"ULDX\1b"ʼn,,&Yh1b"Dt.&\LD8b"Dԋ'_LDq"D4Q1NdƘ1!c"JƉH2&"fȚ19c"zDWD$h'2jLD՘1]D(6Ndۘ1uc"Ɖ8&p1c""DT9&sLD蘈q"SD'vLtߨ;&"x1c"+Zc"Dd'"|LCq"D7jя'LD2 D6 QANd2!d"JȉL!B&"2m!DNd$2MDF"E&F&LO$82ud"ȉ#H&LD"9d"!4TILD(Rr"SD%'LD.H^2 DH&L&"j2d"ɉ 'QN&"L$;y5 L$=|r"DZe"ʉl(Q&2 e?]r"SD)'L{Or"D"ih* UNcU2]D(+V&ȸ2te+LsߦEX&"2e"*ˉ,Y&"LDi9e"Y4Ė-'2LDor"D$h. ]Ncuhfw9e"Dh/'2LD}r"D(0`^b0a&z90̉0b&Ĝ3,fbDҘӘc&LD9Ef"D42'LD.s"DiH3fNd:3yf"̉ 4Qh&ќF3>CLP3Dh5k&֜\3f"i,6l&?͉6m&ۜp3fDo&LD~s"DH8'LDę3Dti9Qr6ʙ_,_?oh9'LD˙3--3-g"ZDr&LD9-g"ZDh9'LC˙s"[Dd9rNd˙3-Dh9r&Ȗ3-grNd˙3-Dh9r弢r6l$˙,g#YF`98Jܓl#˙,g#YFh9r6l$˙,g#YDd9r6LDH,g"ZFd9rl$Hs"[FFh9r6LD7",g#YDd9r6LDH,g"ZFmd9r&l$H3-gFr6LDH,g"ZFd9rNdHsl9r6l˙,g#YFh9r6LDH,g#YDd9r&l$H,g"ZFd9r&l#H3-g#YFd9'l$H3-g#YFd9r6l$˙,g#YFh9r6Lsl$H,g"ZFd9r&l$H3-g#YFd9r6l$9-g#YFd9rl$˙l$˙,g#YFh9r6Ltl$H,g"ZFd9rO-gYDd9r&l$H,Dd9=1d9r6l$˙,g#YFh9rL$F,g#YDd9r&l$,g"ZFd9r&l$H3-g#YF`9lF3-g#YFd9r6l$˙H,g?`B3-g#YF~-g#YD`9r6LCH,g"ZFd9r&lFs"Z6ml$˙,g#YDd9r6LD,g#YDd9r&r6l$3 -g-g"ZFd9r&l$H3-g#YF`9l$H,g"ZFd9r6l#3 -g#YFh9r6l$˙,g#YD`9r6LDH,g#YDd9rlr6Ȗ,g#YDd9r6LDH,gZFOr&l$H3],gYFih9r6l$˙,g#YDd9r6L$F,-?Yο_7C>=Q-gc9t,j9T~TTXN-rbXN,˩ѱj9r*ķCrjKr*rjCrbXN-rbXN,˩ZNEc9t,j9Tˉc9t,ZNDr*T˩w|r2qZR,'b9iί,|,ZN rjQ,'?.SKZR,'b9r2ʟr*d˩oA-'b9r2˩/SK\XN rjKX:Q,'>XN.rjSKb9r2=>\_,ZR,'>XN}\-'^oc9ɡF˩ZN-r2zoԱZcTTcTTFɥ׷7ꇥc9t,'F˩ZN-rr鵾QrjK:SKZdߨc9T豿Qr*dQr[P˩ZN.7XN-r2ߨc9QkR-'b9QrR,j9T豿Qr*dQr[P˩ZN.=Q?.7XN}\-'GXߨc9tߨc9T˩ZNF:SKZkdtߨc9}oԱrr鹿QrbXN.=7XN}\,j99ߨc9TɥF˩F˩/SKu,7XNF:SKZR,j9='XN rjK:SKߞDˉ/XN.==Q?.}OԱu,ZN}ᵜ\zOԱZR,' U˩cR-j9˩ZN-r2?PrsTT?PrjSK\zT-'P-'@˩ZN.=XN-rjKdsߧk95ScTt8ɥ8˩ZN-rrqq?NrjSK\zӱZd>Nr"dsߦc9 8SKb9=XN}ᵜ\oӱZR,'t,>SK\zӱZXNFt,'[-ZNrr?Nr*d?NrjSK\S-'б\z9p,>SK\zӱnt,'uzr2ӱZR-'t,>SK\zӱZ"XNFt,'>XN-Ku:>_c9Eˉc9_c9XN.}ӱZs}P-'O˩R-'t,b99t_ZN5c7SK\zӱZN.=XN-rjCub9/}\r>}r^b9'Ȗs"[?f9'Ȗs"[+Z,Dr^b9'rNd9-rNc9--s"[Ήh9弢rNd9--s"[Ήl9'弢rNd9-DWXΉl9'弢rNd9-4r&LD9-g"ZD-;_xȖ3,gZΉl9r&LD9-g"ZDh9'LD˙s"[Dh9rNd˙3-Dh9r&Ɩ3-g"Z+Z,g"ZDSr"ZΉl9r&Ȗ3oEP"ZDr&LD˙s"[Dh9'Lt[ߨr&Ȗ3-g"ZΉl97jh9'LD˙s"[Dh9r^b9r&LD9-g"ZDr&ob9rNd˙3-Dh9r&Ȗ3-g"ZΉl9r&LD9-g"ZDZ,Dih9rNd˙3-g"Z+Z,g"ZDr&LD˙s"[Dh9'LD˙3-Dh9rNc˙3-g"ZΉl9r&LD9-g"ZDr&LD˙s"[Dh9hh9r&圈3 -g"ZΉl9ߨr&Ȗ3-g"ZDr&LD9-gF-3-Dh9rND˙?Qih9'LD˙s"[Dh9r^b9r&LD9-g"ZDr&LD˙s"[Dih9'LC˙3-Dh9rNd˙3,gZΉl9r&zb9'LD˙s"[Dh9r^b9rȖ3-g"ZDr&LD9-gZD.-Dh9rNd˙8-3-Dd9r&Ɩ3-g"ZΉl9r&LD9-g"Y4Wd˙涿MLD9-g"ZDr&LD˙s"[Dih9rNd˙3-Dh9r&Ɩ3͖s"[Dh9rNd˙3-Dh9r&弚r&LD˙s"[Dh9'L$˙3,4h9rNd˙3-g"ZΉl9r&Ȗ3,gZDr&LD˙s"[Dd9Lr&弢r&LD9-g"ZDh9'LD˙Hs[DO.s"[Dh9'L$˙3,4h9r&Ȗ3-g"ZΉl9r&LD9-gZDr&~?LTЉұZR-/SQ-b9Tˉc9t,ZNDr*TT˩߂ZN ˩ZN,˩W˩ZN ˉc9Tˉc9t,j9rұZR-'ұj9˩S>T;r_b9=W˩Z.aZ˩XNrjSKb9qZR-'W@\TT(Bf˩Q,\TT>\_,ZN-rr)Kc95T˩ZN.rbXNFc9˩ZN-r2TTEp}rjK\c9q\zoԱZcR-j9=7XN-rr鱿Qr*dQr*d{ұX:sR-j9Zߨc95TɥF˩ZN-r2zoԱZdߨc9r2ߨc9-xo}R-':KU˩ZN7XN-rr)Ku,'>XN.rjSKu,ZNFu,Zkrr鹾QrjK:SKZdߨc9T˩ZN.7XNF:F˩oA-'u,'crjC:SK\oԱj9}oԱk9T辿Qr*dtߨc9-R-j9F˩ZNF:SCZsR-''?Qr ?KoOԏKu,'D˩S_x-'u,j9ɡBrj99_c9T˩ZN.rj:XN6:S_w-'u,ZNF:SKZcj91t,'j9<XN-rr?PrjSK\zT-'>]˩ZNFt,ZN}ᵜ\ӱZR,'>mرt,j9Tɥ8˩ZNFt,'ZN6m:߀c9T(s^ɥ6˩ZN-rr?Nrj9Tɥ8˩ZN.=ǩSM-'[-ZNrr?Nr*d?NrjSK\S-'б\z9p,>SK\zӱnt,'uzr2ӱZR-'t,>SK\zӱZ"XNFt,'>XN-Ku:>_c9Eˉc9_c9XN.}ӱZs}P-'O˩R-'t,b99t_ZN5c7SK\zӱZN.=XN-rjCub9/}\rrNdyEȖs"[Ήl9DȖs"[Ήl9hrNdyEȖs"[Ήl9Ȗs[Ήl9hrND9--s"[Ήl9a9-Dr^b9'Ȗs"[+Z,Dr^b9'圈s[?f9r&̯|LR;9H35ڹ)N}HFj絾:GFqj>WHEj繾:D9"R;9jHylazNѣvs#v*ܿ=:?59|vv>GPG59M#2G94hTs_SΈjF<'̡g*<'8F1j>91b;%yON _[E5ss"E|ͅڹaةZNТfߞf>-/jss"vSRE5ssNQm}mR|O~"vjՄ(ys__SD@D!b Q;)B|?s C\~">;yjn{s衚yaة:Nѡv{s!>;y؉6{#_4Y~}3\'Kzf;lG(<$(6Ŧ6[";>{L6p<)Y6 Ylߛw`~v{oVc(=rپ7+0|mެP}oVZ;/fӮPwfU8ӨPw}B|ӠPwf儸Pg-!HSB{lߛGތwZmެ \ q' 4ԙy>On2; @q@ @q2; @dw A܁dw y2;Aځ @q2; @qrw  @dw 9;A܁ d w G a~OC=\;Eځ,dv Y@qH;Eځ,dw Y"@qH;Eځ dv Y @iH;A܁,dv "@irw YNv Y"@qTv "@iH;A܁,dv Y@i2;Eځ,dU;E"@qH;E"@iH;Y"@i2;Eځ,d w Y"@qH;Eځ dv Y @iH;A܁,dv "@iH;Aځdv Y"@irw Y @iH;Eځ dv "@iH;A܁,dv cY"@i2;E7;Eځ dv "@iH;A܁,dv yH;Eځ,dv kY @=(@i2;Eځ,dv Y"@qH;Eځ,dw YȠ+v kN';5ځ dv ';Eځ,dv yH;Eځ,dw Y @iH;Eځ dv k@iH;A܁,dv Y"@h2;Eځ,dv Y"@qH;Eځ,@aF;A܁,dv "@i2H;5ځ,z/dw Y @='@i2;E؁dv cY"@qH;Eځ,dw YA܁9&@i2;Eځ,dw Y"@q;5ځ,dw Y @iH;E؁dw ځ,dv "@i2;Eځ,dv xH;Eځ,dw Y @aF;E؁dv "@iH;A܁,dv Y@i2;Eځ,dv Y"@phF;Eځ"@i2;Eځ,dv Y"@pH;ET"@i2;E؁dv cY(Y @iH;A܁,dv @i@Ȣӯځ|- ڴrr9-ڵrr9-6- rhrr9- r9- ڴrb9-6- rhrr9- ڴrr9-6- rhrr9-2ͷߓ;Ė3- Al9r3H-g [An9r b9-g[ Al9 bĖs[ Al9rrĖ3- Al9r3-g[mZ AUr[An9r3I (-g[An9>:Kl9rrĖ3- Aj9cr3-g[An9N7jr3-g[An9r byMĖ3-g[An9r3-g[ r b9-g[ Al9 btݿQ3-g[ r bĖs[Al9 bĖ3-6-g[ r bĖs[ Al9 bĖ3- Al9rqĖ3-g[An9oԦ b9-g[ r bĖs[ Al9i9r b9-g [ r=ߨMĖs[ Al9rrĖ3- Al9r3-g[Al9cN'-g [An9r3-g[ ڴAl9r3-g[An9r b9-gZrư bĖs[ AW} Al9rư3-g[ r b9-g[ Aj9i9rư3-g[ r b9-g [Π`s[ Al9 z?N3- Aj9cr3-g[An9r b9-gZrsڿM3- Al9rrĖ3-g[An9rư b9-g[ r bs[Π7r bĖs[ Ai9r RyMĖ3-g[An9r3H-g [ cr b9-g[ Al9 bĖs[ 1l9rrĖ3-g[An9r3h-g[mZ Al9 bĖ3- Al9rqĖ3|3-g[An9rư R9-g[ Al9 bĖs[ Al9rbÖ3-ڵA_r)gcZr~6zr>:NiƉ;8yq´|%ӂp>M曏ͪ7ao´݄irnLwV jj3m6Y;ĝ?7?k>rMi XZ;+ĝPi>2MV͊4ah\<:󠾜߯ïǻ@g\l?VLi;/Li; 3u&]&4ĝV22dNLi; 2u'=&LsLW1m1ebSwb´Ô9w&>FSw`˗O8Rw_>Kė?j/u'%ĝ2.a];/W$δԙY$4ԝt}uV5chRwLNIi1)sپ:i.)}uV,{[Ii*;gwnWguX$u{uV$3m$u}uV!; $q}e:wGNHݹm_0R&]YU$~"u}uV*"u}uVgZCuwByY$>FR}uV R}uV{Gi;muNGi(s=:+{ęVQwGg%QܶΫvԝG;/Gg2BGv9ew8NGnߜHu}sV݈;qm\;pe#4lQ}rVՈOQ\OJaZ4ʜOq9#fԝiJi(r>9cĝfs>9+bĝ6ӄQw'iLϷ"4^y>7+]iϹq"$Zԙˇ3/_6/*efvwZ+eܬVw*<*>6ENfU+Rĝ62Ief'yڬ:w'NDlU&C5Lĝvs>7JĝFs>7MAZ$~zGiwkDݹl"4Ey>7+Dĝv Qw3A||f%sb}Xqܶ͊eNf2/P}oVv;qѡ\JZNCݹnߛNjC9xo>;swYlߛw`~v{oVc(=rپ7+0|mެP}oVZ;/fӮPwfU8ӨPw}B|ӠPwf儸Pg-!HSB{lߛGތwZmެ \ q' 4ԙy>/߮ @dw mv  @dw 9;A܁ dw q2;A܁ @i2;Ƞf @q2; @qrw Aށ 䣀p~OC`2hY"@qH;Eځ,dw Y @iH;Eځ dv Y @iH;A܁,dv "@i2"@i;1܁,dv yH;E7i2;Eځ,dw 4Xg[ 1l9i9r bYH-gZ Eh9kr,RYH-g["Ej9r,RY3-gZ"Ej9r,RĖH-gZ"1l9r]?Q rYHJ.RĖH-gZ EOAEj9r,RYH-g["Ej9rQY3-gZ"Al9N7-gZ Ej9r,RYH- Ej9r bY-g ["Ej9r,RY3-gZ"Ej9r,RĖH-gZ"Al9r,RF-gZ Ej9r䖳H-gZ Ej9r bYH-g["Ej9r,RY3-gZ"Ej9r,RY3-gZ"Al9r,RĖH-guF,RYH-gZEj9r=(Ej9r,RY3-gZ"Al9r,RĖH-gZ 5ŖF-g["Ej9^r,RYs["Ej9r,RY3-gZ"Ej9rQF-gZ"Al9r bY-gZ Ej9r bYH-g["Ej9rqYF-g["Ej9r,RYt?Pl9kr= Al9r bYr bYF-gZEj9r,RYH-g["5j99&Ej9r,RĖH-gZ"Al9r֨,RĖH-gZ Ej9raYƖ3-gZ"Ej9r,RH-gZ"cr,RY3-gZ"Al9r֨,BÖH-gZ Ej9r bYH-g["5j9r,RYH-g["Eh9crϨ,R9-gZ"Al9r,RĖH-gZEj9~w bYH-g["5j9rư,RYH-g["Ej9r,RY3H-gZ"ڴE_r>yr^^3ď O@/m9qiԖSr>jýk9u-'.V)ԖhBm9r ė-'Srj9rõԡ8ZN\Z-.ĥrj9u-P[N|rj9u-.ĥrj9e{6r J)Ӗ]һ(Bևk˩Km9y)-'/ԥrP[N]jI.-.ԥr $ʯr $J˩/A[N^J)Ԗ}޵rR[N^JKrP[NjKi9qiDi9VKi9u-.$J)ԖiAyFk9%h˩Km9y)-'/ߨrõZ-.Z-.ԥDZN]jKZND7jB/_oj9%hKo'VˉK$ߨrR[N]jKZNjKZN]j˩Km97jԖV)ԖyFS_Ԗ7jԖyF^oT[NjCZN]jKi9yeFnSrR[NZ-P[NZN} rR[N^|x>tۿQԇkKZNjKZN]j˩Km9.7jԖSrmFVIV˩/Z-'.VKZN}:Ԗ7jԖ7jBm9oj9ԥDZNDZN} rR[N]jKogrP[NZ-ԥt?QԥDOԧVˉO|tD}zeDV)ԖSx[N^쟨rR[N]JC ՖS-']/j9u-.䥴ԖSrMIs?PݖjBm9jԖSre@ġrP[NZ-.Z-.ԥt?Pm9iNiZN}m9u-'qZ-P[N}m9yV˩Km9u)-']>rj9yVItڿN䥗ZN]jKZNjKTW˩זSru:Sry:iI{T?EZN}rR[N^_rõuZ-.ԡZǗ޵/k9~鳖{cwyr. r.r. r.69Ȼr. r.灼9ƻy. r.rh9Ȼy. r. rh9Ȼ9Ȼ.Ls~OuXgfsw9qsw9n3A] rq3]r.gw9]A z֞Lw99ȻA . rq3A] rqsw9] r.gw9y.gw9o< . rq3R rqsw9] r.gw99ȻA.gw9y3A]Πrqsw9]A/ .gw9y.gw9]A .gv9x3A . rq3] rqsw9]A .gw99ȻA .gw9q3A] rq3rq3] rqsw9]A .gw99ȻA7ʻc] rqsw9] r.gw99ȻA .gw9y3A$~ԖrRZN]j˩Ki9y(-ԥDi9rR[N]jKi9y)-P[N (-P[N䥴Bm9ۇ]˩O-.䥴4-ԡVInSrR[NBm9oԻS_ԖrZ->\[N^ߨrRZNߨrR[N]jItݿQԥtٿQjIV)ԖiFnިO.VItݿQԥԖn7j:Ԗ.7jԖSr]oS[N]jItٿQjIV˩/A[N]jKZN]jIVK/7-Z-.䥴VˉZN^J˩Km9u-'eFS-'Z-m9u-'/]>Q^ߨrõZ-Z-.ԥDZN]j˩Km9yVItڿQ$zٿQԗ-'/]oj9qitٿQԇK˩Cm9yV˩Km9yV)ԖyFSx[N]jIt޿QjItڿQԗ-.ԥtF}v)-$lrP[N]jKZN]jItD}n'jWKOԧ^Oj9'jBm9Z-.ԥrj9yVItڿN䥗ZN]jKZNjKTW˩זSru:Sry:iI{T?EZN}rR[N^_rõuZ-.ԡ7nq øZhq1Jbq 1\q k1ǰU8ŃcNPŃMLlrqiԀPZ>.!jCýu!.VG(ԐhBM  5&ė5!P Z5)ԡ68B\ZU.5+ĥ uePB|҃n0gCo]Ot典B\ZP C 1|je+.3||]gHtp- u!/5ĆPPzCjpK-å9ԥFꐗRCDu/ sAmK ?$:ow>&!˗Of:"*"í#RkD]jHQA"#z$K(QZ%RD^zٿQ+LԇkKD]JCD]jK 7j%F.7jUBo Z*=ߨ*ɥU+7jbQ,mFhQZ-eFnQ.REzjK.7jBo*%h¨KmyVŨK15d䥗ՔQ2mFQ3RzF^zٿQhć[I#/].ѥFԪV(԰yFQ_Ը.ިO/o8uFQ8yFQ9R;GZ.5uԥtۿQv$:ߨ;ߨUVIt?Q+jO$/]OJ$u.%j&N.jTRJRbI]j-K%ULn2KIVDI]j8K-'yNЊ'q$u@~RPe@RPR#J^f44!>閔:Ӕy8R5>攼t?N+ԥ.O|=`$:URJ]jYKJ]j\I}V^ ԾVa/J,u۷۴"KmZ>vt޿Mԥ֒.iՖh-u%/*.u%/]SKVD۟o.^.iB//u.5ujCġauVSbm:}VI}n1i"Sde:(SU.5uZa.C/,]IVK/it^m_h\4INVKRMuZ&/ԥ暺^i:d~whSզ.5uZ.uj)x~.i4ԥtۿNԇkK2N]JǩC 9y}ޥ/k9~鳖W5s[mZAn9 ZAn9@s[An9i9s[s[mZAn9@s[An9i9Q9)\- rhrr9-6- rqv-g[ r bĖs[ 1l9 bĖ3- Al9r3-g[An9r b9-g[ r bs[ Al9i9rWAl9}cĖ3- AOAAl9rrĖ3-g[An9r3H-g [ r b9-giFmZ r b9-g[ Al9i9r b9-g[ cr bĖs[ Al9 bĖ3- A7jrrĖ3-g[An9r b9-g [ r bĖ@3-g[An9r b9-g[ r bĖs[ Aj9Ǹ bĖ3- Al9r3-g[An9r b9-g[ ڴAl9rM-g [ r=ߨMĖs[ Al9rrĖ3- Al9r3-g[Al9cN'-g [An9OԦ3-g[ ڴAl9r3-g[An9r b9-gZrư bĖs[ Al9 b3- Al9r3-g[An9r RyM3- Al9r3-g[Al9cr=r b9-gqڴAl9 RÖ3H-Al9rrĖ3-g[An9rư<[ΘmڴAl9 bĖs[ Al9rr3-g[An9r3-g[ crm3-g[ r=M9-g[ Aj9i9r b9-g[ ras[ Al9 bĖ3- Al9rr3-g[An9r b9-g[ crϰ byMĖ3- Al9r3-gZ1n9rRݴr b9-gZAj9Ǹ bĖ3- Al9rrĖ3-g[Al9cr|C3Zηr~ԖAĥrR[N]jһS-ԥZN\Z-P[Nr j)Ԗ_8ZNjˉKjˉזSrj9qiԖVˉKG <9ZN\Z-.ԥZN\Z-P[Nr |j+||]Itpm9u-'/䥴ԖSrPZNj˩Km9råԥԖrRZND2 {Am9rKЖr $:ow->񶜺ԖrҴ:ԖSrRZN\Z-'QZN|rRZN]j˩KrjI4 }޵ԥ^oj9rmFSreFSrR[NZ-.Z-P[NZNDO7jtF}riZNp/7jԖn7j:Ԗ.7jԖSr]oj9u-'eFS-'Z-m9u-'/oj9u-'Z-'/ߨ:Ԗn7jԖrZ-'>j9y)-.ԥDZND7jԥn7jpm9y}V˩Cm9yV˩Km9u-'eFSrR[N^ߨroj9^oj9%hKZN\Z-'/]oj9rзZN]j˩Km9yV)ԖyFSx[N]jIt޿QjItڿQԗ-.ԥtF}v)-$lrP[N]jKZN]jItD}n'jWKOԧ^Oj9'jBm9Z-.ԥrj9yVItڿN䥗ZN]jKZNjKTW˩זSru:Sry:iI{T?EZN}rR[N^_rõuZ-.ԡ4X6- rryM9- rhrr9-6- rqv-g[ r bĖs[Πg1l9 bĖ3- Al9r3-g[An9r b9-g[ r bs[ΠgOAl9i9rWAl9 bĖs[Π' Al9 bĖ3- Al9rr3-g[An9r36-g[An9r3-g[ ڴAl9r3-gZ1n9r b9-g[ r bĖs[ Al9 bĖ3- Al9rĖ3-g[An9r byMĖ3- Al9r3yFmZAn9r b9-g[ cr bĖs[ Al9rrĖ3- Al9r3-g[mZ Al9rbÖ3- AO7jr3-g[ r ߨMĖ3-g[An9rĖ3rư3-g[An9r byMĖ3-g[An9r3-g[ ra9-g [ Al9 z޿Ps[ Aj9crrĖ3-g[An9r3-g[ ٴAj9crrĖ3-g[An9rĖ3-go`9-g[ r=MĖs[ 1l9rqĖ36-g[ Al9 RÖ@n9cNir3-g[An9r b9-gZAl9 bĖs[ Al9rqs[ Al9rrĖ3- Al9r<̦ bĖ3- Al9rr3-gZ1n9r3-g[ r b9-gZAl9 bĖ3- Al9rq?Ö3-6-g[ r bĖs[ Aj9Ǹ b KurrĖ3- Aj9cr3-g[ r _MĖ3-g[Al9cr|C3kZۃi9rrĖ3-g[mZ Al9rrĖ3視s[ Al9rbÖ3- Al9rưAߓcAl9 bĖ3- Al9r3-g[An9rayMYH-g["Ej9r,BY3-gZ"Ej9r,RY3-gZ"Al9r,RĖH-gZ Ej9raYH- Ej9"Al9r bYTH-g["Ej9r,RYtۿQn9r֨,RĖH-gZ E喳H-g["Ej9r,RYs["Ej9r,RY3-gZ"Ej9r,RĖH-gZ"Al9r bYH-gZ Ej9r RYH-g["Ej9rrYH-g["Ej9r,RY3-gZ"Ej9r,BÖH-gZ"Al9r,RĖH-gZ Ej9r bYH- Ej9r RYH-g[΢喳H-gI-gZ"Ej9r,(Ej9r bYH-gZΚbY3-gZ"Al9r,R9-gZ"Ej9r,RĖH-gZ"Al9r֨ RYH-gZ Ej9r,RYF-g["Ej9r,RY3-gZ"Eh9Ǹ,BY3-gZ"Ej9r,RF-goPĖH-gZ EO-gZ Eh9kraYH-g["Ej9r,BYs[ΚmrY3-gZ"Al9r,RtRYF-gZ Ej9r,RY-g [΢7Al9r,RĖH-gZ Ej9r㖳H-gZ"Al9r bYF-gZEj9r,RYH-g["Ej9rQY3-gZ"Ej9r,BÖhF-gZAn9r bYH-gZ Ej9rư,RY K-g["Ej9rQY3-gZ"Ej9r,RĖH-gZ"Aj9kr<Ц,:5Nyr^^3ď O@ĥrR[N]jһS-ԥZN\Z-P[Nr j)Ԗ_8ZNjˉKjˉזSrУL=WZN\Z-'.Sr ć[-'.SrR[N\Z-'.S-'j9r i+||]I_!õԥrR[N]JCi9u-.$JSrR[N^JKi9rWDi9rԗ-'/jIt>\ZN}m9u-'/i9u-䥴ZNp䥴ԖSrjI4 }޵ߨrRZN^zٿQԇkKZN]JCZN]j˩Km97jԖ.7jBm9oj9r=ߨrɥrj97jԖSrmFSreFSrR[NZ-.$ߨr $z޿Qԗ-.Z-.$z޿Q䥗ՖSrmFSrRZN^zٿQć[-'/ԥԖV)ԖyFS_Ԗ.ިO/oj9ruFSryFSrR[NZ-.ԥtۿQ$:ߨrߨrKЖ7jZN^ߨråԡ~+'_/~kwkOܧ_~{?t~_>o)w27d}cׯO|~{|?Ao| ?ޟ_-l\n_qyNNr S\|__K'/>2_3w{k~~?_/-4>v?qr}~9}c^oOo~}~ >^?xz᏿ ?קe}zvZpz/B.?w_?Ow7o_zr;?[G0Oy#qt> stream x$a;#ϢT9&}.b)I[Pޥi;r= l(*=Ow H%a'= )`VHJ [tD (k>|ܓq-s1]&#  0 ߗ_7ݭMFl/1:=" 5A/s͌d;LE|e8GS U H r{YcڶW:t@asaMBb S^ fl1@aU?(ivoG3NH3MMJV4@idH^T]bO)Zkfs{' *tN&, ޡ6€|s;V;{_gc tڝZ pJ"Z~`u0{&1<㺂Ώ>eߊv/XW's4fp[S^Q ӫD^㌧H rzg<+in%\ U} txFeD|FQ2L:t/7jS >>VY5jڝS5v\C2 QgSQ_iLAfEHKյgMeW,\o.ӵ3w7BH!ϏQ9ݑOܽWZ6agr(x+hf[05:SocOg?l/X~Y-|2_ԉ=#5rLMA G?hYtV8|};O9S|1B+'t/ԓjnI 19Fe ɠ9ݝHH )1-2Yev̦YYQ< o6ʝBjl)qYVJB]H¢EZ0fyA5K4+7*edG$ٙKOXx +O1 v~V戮L?hJ«6YQahe6W fz*&$X|ZJ퓆^wEsխ aH_/Tߣ? a:('d?]7E?2DʂmX<#U2wD43^[]hzx2eTEI1*0gaU,joLlrFmɺ!Cry8&7F9_Xr?:*_kT^bkj CCE;.+dڰ!# O$s;X:}y7kXC18Tc3+,*4R1ru1C v~(!tʃ' iERa31UP4 f[&_ w TʺjteԮ΂ wtg&PԼ  ¬c 8n2m0)О!8^Sm%ܙL-u ۊhg!zaq"裊0݇_8n:%G0+yxBb/yުzėDQ8spNMS@q$J( \xzLDMyfG>5xi 9!4+Io]E(;oܴUnuR4'uwzUvT>NW(+ۏ_71y C/o-+\0US8lW#Dp.9#6rW.o6qTħ֡AWWoX0ZP -XV+޿ǜGg\pR:X#*d5N %|sk|cWZHXK`oXzʚ ඖ՚r[/%71eD +4|ɕ,̒>dDM21k:tA`#~VϹ|S=vZ3[Uϟc_5{@ń]Eg"CK-.O1ڗt%;vmVFlDsV2eD{Νg.b$cֱMhDUt)@嘅uEynF)r"Z>af^׳k+>'Vx,~9 93B[o,!GF6 d:8L-zQe&/վ ʁV;&O'(TLO[+'s2g3+9@śXFPS}nC+[J75֖@JܳT#(H2@vxz^gr.,㔚;{(5`%Wt)Cr:MQYfvCD1*+7N5u.GJtZ,@$j] }Rfk91LQf&-  6JFN x'poc jFLDH,uˌG.Bz0R5J%K:*O>3֠I 516zֿp p*_=z!5T=yc`f!]Qå1>2ccbncgoT]i*)E+wꭣ< eFzںMɥIK(+-JG9ꥡZ59oAX>yl75a~ }~@;9w=%i<[Ѻ78WRZ%>m\U,{'-zD^0yqiT`Ji$9`k YhAb>bN[KL L "J%H VxLKlt˛n_?\\|6 cxU_wZ/zޭtኖz^=WWq0ΧpQ- UĖʙ3z1qt:8N9? jKD;Nm}SG‘ FC]9~!zv{خsJ ogQ &"g;nay1~:߯vOi~=f"+@p6r[-kAFQĢAMڏ%8 vpE*Z`*sVJLlڬo"#o.¦O2EN9X޿t8&b֘>e"e3'7g/͑%xANRnZ'Q[nS^p= R!^o~{nzf}N>wϫ,֮yqv@yAMGmڮ]ٿrҹeendstream endobj 354 0 obj << /Filter /FlateDecode /Length 1177 >> stream xWKo7WTQy h ݒvD[rΐ]R"oy:A_ =,oޭQwVvE7\3mzxr%x @no+B0F{Bߌp]v=}bc!"uBrkxg;h_ؗBLk6+tw%"t_߳^r!L|{ΰJCΓsֱ4ArU`?!!E,-]2 r'39^ҢNHIcܹ.l8 iF1)CgR' WZRyUJc\_qVbXh{N fIWRrPDMZOHhܬAM*3怬8 QBu2i5ؑ'{@>z'VZ[H|`8Z֞vZ{,+OuSރppjt <ߒ~*(]!46y酏WYf!8M|P `A.7͆wAbatч35N 3_驋> stream x=n$qo ncX<+ӀaH%eЃəNCȣ"ʀ.Y#22#y3{pw<~<__kυ1Y)Νfbd;|87{'y6j'[B;Yγ~w3E߮A_cwie~\XvpK'ˤL)a >%4Op;#CXK‰vG6]`lm>'#G; 7 vRhXu\UsY]>(GU Y玝y?BY#lt'c 5gxa |d?b 죻8 -5`)IpU&2֯ bXZ_ x.$W.` Sg;֗=q/=R( E;ZpM+pR`8\B{u%M q8gq6QM\]&P^u% gcuD.Z0:AzȒ&랍A2UQ-/:WȄ)5{ qjn/!dHzKxJ[-JN K W |v@.l/QQn+Im߰+VxD'$Լ +r;FE*z% zX1KVw lŠV5Q$ .f#F8©.B  Z431EF)j Z'TqII=XB-39͑IS@%peCIy̻O8u%P" grJbs>QDT8DO)fcme&eD|3[s3HHg+KGWb%>ȴ')0$E٦O=p]2@̇_\& D-4-ɰ(3mi v# CP&ʀ簺o[/#&lC-`a)5zD֒m;K פz^1dٲ/Q.-~L"O,G[!40Yy!72 P G$EH8)i_ 5Oi9Ю-/f[C[O|FZ:4_k#@OJ`2\J袽&;#@䏜F#g4dwAa8BT_VÏ@NRհ0)GNQ5=S$$E 8BmQ.nFw۴hIY-_^C⚄.U )\')QuB9* |H kBQ+8AR2@HOUKO;*WڒH@c6O  <uf2_fYϟoO{1[t1@N ∇^"yt{% 4UOl%Aܗ,6' Q2YJӺ@t]%J!ýnti:HZMQ2A?"+4q_),mX"tg}6#v51԰̌ hjz1 s{?~ E鼜@s?V;7`<&'5:p!?rv q:Faݻ)ёXn>| ohJ҈E<.L¢E$‰#JfL7HWjrKrw%b/L9,+ fD'(9w=Qj"pIj_9 C'6p"*sXG{M(dMٹ(d@%I$9p8bh/#wH:SbRi?iޘyÂ)li0ڬs h*m"#Ί8% nj)rÈ$91/x\n\v^|DV>m#6vuWdiNCm;G Q RrO>; oQ6&.a?J2YDl(z?F (y{*/cvMR ((0Qj&3]tjj@Wc~DZ7a6ׂbLz4c@.teZA6P]iU6|./?"~]#mljLlOkH[V+'(5Fm8+f~A d}{}hԗ̒ģF!dS荾7)lLeXj6ADfEns7:&ڨa,oduteg .5[}S{V(, (5R($F4Tx6wr(5,4k ׻/7V.D4ff9<$E[pzH6`M03h :"/~w 6?k8?`S:{uC '^Zg59aiX pi 0\TO_< %̑u?IƪY6fsnETYSemAk'!V/1XZQ#+#!ո?I&P̜b DxxRWj0lJ:;m6K}-9WREd)V3Y7 iKY}'r!MTM)K-/} ,n/Sκl/x:m1V47Q.fs_Ol~HV` ?)kgK5: 3ЄwC3VS9.2kSP)%L?ٵef#,Ye7ƿz1cBKQgE~ )zv2 53g eɇfã f߄|(:ŚŢ@BK 9ثQKsPKآ|sBt"2@$*;$ac~w 6",=J=/r)NZA^S:~}o\5UZvkjȫ*$*+ p 0;B n._K\_(<׉<][6-QtЁIO7TVצ!<$t;K2?,eNU8w7B4XͭMޑӇ, 74 V[4&SSX_gqyR?eWӗVho"4nlc3f>Qe< M6z>IaIS ,`Q']_`4tc JeiyP/+6LT4< v< Q⇓JyO:EPtQgҌh۰vd./3h.7VNhc{cDtRvܯVFpm TѾQu]=Yw^#F:Dm{pGWFz +/ЎLU|D窖h䄣Dt]QprmgwGyu$\hh5(:R>}nwdzV;D".T]ޛ$*9%ߋ)ґ怰4 7,8]t&zSuZ&װd֠oHd nX8r+LYDal K,t\G>*:Z/Aʣaw8Fi/a^CRȷ CrU|e YIUHK6ΧX[Qf0QUHII^"̠1Yw PIVPC8#աY 4=hQ2~iă(͍mm.S@~U>z0m:/FSQxԄQv` 2= yl\/$ׁM)hJܓlK\x0zM%Te`&A/(4˰9 9Nڐ,/-suT7(I6/_:@bgFD`d9I?Nf!cmMtEM~惯*\'毋G3P9*Did?Z[1:m,2eR4.Vr!# 5b(̦H+')Ҹ O 5ټZԸ)y\#)Bk?de57_j;IqI*4 }_/j ;X?׵Ev+[YܾqYOOh2eCWpy~6s-d";56UHN2nYɑ,V2˸|򳚛GR"!l+<TE.7q%h\~2Bu_BW%}oj1s yߔrmC鉣+AֶG.lpӻ3䟹0>!:B}p#} x҉.OgM2T)7Co?˽W{z=!΂M U'gsE@:EOūDA1 z)7G>$/&XL.cU$|o6AWxu($ģ|պ+a Ş -R܌LjټZaY~YK-*6^f?k((5^@i]c䇏D-⿣7&c֝H^ 4b|ʊlGWj[dEGGެGnk?IW||js9X_u*Wl)jis^NzH1?~Ҋ'~Fܯ֖)eWhʹA~mwEIZѳܜnayM .Cɑ&t]/wW(Du<+J w0`5>)OgoϜ ~[L1&?uX_m'/aH~bMɠa#u'o l.2 NMRGiBقcrf\͏q1VCk"`'k2/an|YP&uK\]h9*\#`]%=[2P"Mͺkb<H%ޅRK %0˃\33Ρyړ# -~60!OiSo$cv "gˈ_7(,b^R'ߌgGqǮ"u |vA̠\L> stream x[Ks3[!)\Q82(Zkret5 !'@ݘg3W۳?f7wglvs?Wٟa\YgVL:>4oُ /X3B7_͹Peb.a8VQTF*̘c j~if;_If1)dsLes;.Mgk2uw* cBf7uօ90Ȉ[ [=:@}Ls緔NѝpEEsCZ.U'HsZ{yJтdy~` %T8~2U8| '7b`MkMF7E2{ylڵN!qsBH-`hd~UJ E˘yjl?0P+:Lx?nᐙ\V1fj` t(w\t|{zt7t.%'Q^3s$kָYrkḩe?{݄=.oEQQƯȓ5V|@Ȁ$9/yސهBJ/`حx:QqW-SrrlҊn79 yx1B:8^ml=&l!1\xע?5h3ʎi tUvۡvEPF?>. C@xx޻०t%ƕAk1u#8g3ppWņ ]˸pv8sG.A6+UƁj!&HzC0>W(喼'1>SszpBh>HP#~a"C|Qa\ޖ• [ O qM=7ft."\xH{)~r]2-c";qe.i@^`^cP萘]@Bj#&3枕!*$p$Ph$=p.{L8YJ z -.0SBd,p`~ς/I$)8dk.d#-ԁ)m=ݍ1qu ގp ,XU_vCJy$,=ڷ>ҶUT}0QH"m nǃ.n r} Qe,;h"F]j&3RgFͩS\f)G5'J&gx7RHƻ!\a (O2S8WFwi*o~nv/LejƪD&b `'$c$cnEi!Avԧ FσDd2Z;S4ǘV&[U5ۣ`Zhۉ")^gQ?Ud2YBͮ6Mx,W5Z! Їм,U")_H(-(\aˤcJF=YyvRU1OfXj¨)^G;EtXGBo2PhkLHx5.9 U$m""uE.4r"Jv6&Zo<t%|aF4S xQ @MHż?J4ւ>4tÑ2:.buⶫT9mA6 4+܃F,IA$n*w_.ؚռ/uWo1+BRj<Ɠ~jD-a_+NEBSQr_ͱʹ,!,wQh lʪT_JڞI(5l*RE1 GYHkתBd-r*%hA* kJ2KѡKP. ͚iM_Nˁ嘚i5dK5qYPRI Z?>GNՖU 堦j9TGq2֐d=]w)(P-uv" =.vnوTe} QQ"[z& B*O2Q q;ġ%oYط 7<*{YL4>?;ovm%i['f3%8gER:oxƁb-Lfx/^T*7TݤP%Ͳ"3ڪU\4E%s^TEV2?L A{ ?B26}v7c0CD~=rG+WZ!Ÿ4[zaCpRFoyt* &1pd6 ?tUNa~ۏŻO>Pre8OsGe_5< U-BmG5T"0ėk%.\'L=٠^Hk(tL x @q֐SۖCJAh/~ڀi 1pwWW/zZ6| AS"\G`V[`2*SnKQDFn>/Frޣ~K8 +ЮƛU4c-*F{O 4O7x (-4UW3BNYn}SNDZRZPߗF ye"2WH~aL}%v(ʡ7U]ՄZH+&ISƮ(S;_bǶphdojpi1<|!N{`jo9UӞN7,. jm#(jg5;UcR ד6Ϧ`g.oc;-iyh@2]_U+*8nUSh3S&3KzH͸ѫXl<]_PBA/`@^/j^"AN&GisG9N=VL/dc_YM]_xkN"yY-k`[rNuu`iWDƋwy08JRZaIo[O2^7%yO *G =AFƤ<Ј=I^mR3eI\v\җON-m',h ӐkXH}i8u+N)i3? wX,sf~{<_4(OUZlVSK &V߾"=8a] R&e `x0t> stream xZKsө=JT8SJ*y΁#{wL5KZt9,׍n&a'{qw \|wÏ Zl8wW'q*QbRVmn;t |r36Ƥ3[#yWI@ߐ{|]^DοwCOĄI >;4KIa&|q:z_ Ƹ7g|K8Qk? V ]9Ow@E1ߢ[%Y! {*a9%L!lV, p报sWx ƍR .5* dtIpU:P^p&GeM;$_߸oW̽cP!\fD~~3k|Je/!u}Z=`P 0J55әs9sJɳC/c8\'Dymǭ(ήں@dFIܹ!QN`xc$1 򜢼:yMǷ~$_D*sDKjxhdD#_zƆՃ aeYtOTr$UhmGL #k\| Խ;cUΝG]I*?âw6 pp|ᣴ{WW}apv%f[Q'z %>>T6<)Vĉ4( 1ğJebI-'.! 8]$yq;|:x;حQBDY(S0$PY5#$2aaj@䅐C2@z2|KW Z3D2m!0ppx{{8] t7~o e煅 g 3΃o7p0 sqWj8uȆ$Qk<l|DC9tE9܉`~(.sHǠ i!*,YEk#B@7<"`i#Ǫޕj=ژUmfgEs* Ln7'Q;g؆Gv0~/*;"_STK g<aq;)3!h vVAPD@#-6 qkJkp.$!^MMHI`1GnD_ 8պ"sY#Ҽ_DQyQ"XհD|y2-'K F7[ ILB?kG1;rHpc\DXOSd@i#[:SE4-pT(_^A:,{]& !TsA)OGNUkv s/뉆PP=>$G٦P 8bٗf#Ȋ&,WW4t堣re,՟)A9dAhw[+R90Xώ^{7G_ C*Posr>6J|n`/0qT_W'6IѺ"!<(wۇ|]pkXRTjі<6ntz93ك[h|34ErB+<7ܖrm_/ lcXp;L'h\0 *Q/}b2(!Ipo]4W2= Ql'&57n#Ӌ@K(֠inɔ85LSIV@./\Bیt!Gai3潛X.[(15 BG8A{0CS, oQoH׿p+~C|% = 2԰"fg4]c PCt 23{F1-O匛^6pO@| *3k5wF.pËJ@{֧6I#\ ~"{EFx&(0Wh-_Ȫ3Q"Tq?')So[,o-9eؑo-DAYX&g~0g"}k2|#Vvr+GXEO{N%Őu^4V~tݪ35 )EMQ|e< tdqCvW깍We)&G1I$IY lK  "]zwy endstream endobj 358 0 obj << /Filter /FlateDecode /Length 162 >> stream x]O10 @+J. 2D! }Ik6|/`,@[ 4ZebY8)/dwSj"> stream xŽK-q.8߿bA>l*=q׀p-4<4Ej.R"yMxҿU ޹sʊ#G|ݿ߿O_䜚|˿>yhxC8=<-r/1SvZO{!)aMH)(&gVjkDJͳdD͒OoiɀosE$ֽU>޿Hy$R|ukZQ0#Z4gkg24-!8H1 A :v"Ͽ/?y'~U\κrG:t{?'A8_y&,*d|k>x^șGK#iPr~F@q8R:j WhsSz}ܒ^C+3\B#帊jzmFbz- _ES|mYO?T&~ȗr|eJ=^;>쯍jzsaY 1v ύ)xpS'8xlťX^>  ET"[u"MYSMJJtwÓsh9@x8^Qn2*K% A'皅OLsr,'9ׄOo'q˙u506S2[ E ŭzrK$nAPJUHJ9@M$+ 쁾hS"Q F@8iPN'ZL溁̎E[l3k(A+HY2fMͳdD: m%#u6[Ai-M/Xɐj~[kdl,CkeKY-]?x[+(8[zt͎ F.yYl)X˘")?ִweNW-t](YSןdM/B\ hbςo) 9 Hdza$iDI ִǃ*$0 m'F(/a TׂOSj% +G@ Qx9P!ߏL`^ DDO ?i@V@5a7FfJ >)N >_?FCDsЄ#?~ _ɶC ؐzcp,dY8=O 7|G E:2Lu(B`67t1a y:y$>"ξ@N/qŸ>#!lyRסуu |#NErtHgTa8qHHze5 ^}  FNy-6P,]'^N[̅F=F٭) :pi d ~)+~)22=kYNddE=~>B{Q$ԝf0ecEp8e+HMbE9߱bk|Ċ0 XFPGl%X6U7t˼MSW4m"#,1fӬ1f1g< 4~.l2F,6f,g-h4xVAOaj?gV&7KLQU'#O&MƭZ [ƭ5߸LaSv 5rQt}6n?q\n=1?!;Q֭ʔ˥$ #YF4rrҕS䒏d.TAPIHCu's+IW(\II:"81+Z8ӹ baDLhaa] Щ\l+3~uѵaFJ25KX&&V2Z]+nbIDҘ&#PѠqdkFÃd+fd+1Y&];dkǵBWTMB׎o.xdXh9QNo ]1zB!SBFi0ґ0 4 hiu_;0:)O\.,yF2Th3 $nYcd%igIv5FYZMsr+SQF&Sl:Yt^nӹ>}s$r?tޯv1EҶH]#_Ì,?l;L*y%ny)NO2%na q$\%q[ķ-4-$ $q XHdxI08k P-4Ж-d1ђ%#ĦBҶX7H0G0FzŎ]IV x{R0h%o #.-ӑwFma$ɑ- DIJڶbpɴ-4 %m #E ma$-qgma- G02a%kK.uȈ%m ##,i[);- -DZmEY-t򑹅 GFrF2sdnW"jdnaFddo$n+#q #+#qKnY;+l'Ʃa9+ЯR(y̳$f5y̳0Я%5y̳L4f}|d[uc"ۂ + וF,GLju@HqεMcDŶ)#cv@M3[8Emq+H֌?ǶFQC[T~Bh;Q-w+v#wVzHV:\xrI#IV~>ok# =F8=(jZ7C7%x+hH79ymDo4GҲ@k M#|a$|b{LDH{* c ͬkd? Ycd%4k̳$fiֺi⎀H!_Xz9y8u!5kBSH;BA.Ht ]z:"~noFD qڈPz%0aLcFTepL" BQBƄaU)FVbL.!E=#U>F`> I@C. D cp,acT\},U|5Zn|o>XB`x8[2|PJL(}{KMc9Nb=/EELsu^zZ#S7] XzOLUH9+?<'õ8/MDЉEL;oBe. &ioy$AR>{/N;ad?:=8*i!zr2O} 원ZE_v.Cҍ~P44H01JۛĬC. 8Dqy=ҙK7q,9mW^=,2PUЙw\,/G:E/=2jzܲB;;ě_ϴ?\9q+57Pè"i8p˾V ~L0oxqϕmE\4FDxy-/,$1?I|.gȂ%Vk0K-W!Ēn8`[r1'!|[ҜB-ĈB>2%<){5K朔!Z=ibk$,\%UFDz w E+F$=y*&%*f{F&=yfgL";N0E"鉛%V9:pO# Zml#eFN=u{з1 +B@NB SEZ8| Qygb5DܲgDaMRex"nٳ JtY$[-R3SQ'~[@HxHJ <pߊ׾h'z{U< Ҥ[m׎(j% sSK;?s;t)pW]zYI ] *42gI[<1CXLM4i='5q جXXIRgĥKpڲ+`maN> Uo=ٻA1|VZ|@ʢ%T0峣\[\$]V`RJK4L!G?( {Z%P|"QYlQ+_qq`VQO,W0&A6gud %$d;#5-[t Qxꨧ1{{zmmZ<ů׺)e9߃58wSv-nG>/p}zOeB >;@N},W\B7rQ,QC,+ZzNcw <̲7zb )(YVFOlrt5YFVڙ÷ôXVӳ+ ni>Nx? (zVp\yxcE!V0QR/ͣF@&U fzxhEm$ BG%1=47z\nkgԈC"U90@+y ܧ4,v3i\Ya1Vdi +}2E5yxeX{o9[6GAXۥcpZiF5Vk8Sy5\ 1=khY#t$08@B5PH|@氆5Pq?Z"%ZFj`YrN9hLˊ HW#V{ B' cl 6q|AG|VzXȭMb=t*Lvz Y!!OW: ?Y<G#Db=P/6:gEhgk9%0kpr~VV!2~k@1Sǎ/,iSF_ZFގ}N j9H \*Y6V!{bg/=1bmFbם^ C8+C["N#KBAa~SEr y`feuM`bƞ;ˬPѨKs;ˬ0 ox+(Ua4 2y$I.XebQ,j1*,׹町{}p#^G*,J|< 2lg;1rK)c:ضB{:H xqàΉoͧLbZBV~v~DݥC* /釀ނSY'V z9d{:mt!{k'i]thᄏc:l!B1*gjKY ;. ="􁫙f9 zYi gY(=Ҭ@҄zYi6cCo88iD,޲hBVy8d9Z}U Y * 1Tt+];0?M t%)pr]!؛QH9-2Qihp5*ƥKF*Vk'4v&Ypi`Ȋ&|k=A U Y ڭU Yg$RamA(G0+ɊrqR?NVPBA2 TԱemN.OY9;yC`AAkV`fEH7M 7 yfeo:FFJ(իc̴g"A>p4HRRgPͲx˾qZ `y`dXlxylr[TKc, ۷+g4(^"rA_ѭD㕇EsġRxL"}:(Q^2;% \yX= 5g\FEVm/˒+m X90᭝<,b7`x=rL!'+D #¾'A ^yXdZ։^込&vhlWQ`zșrMXE:@ A][2^Ɂѝ}\'p2)@>FA'x,M9Ek+檂&v,wk e xha?{7|X Us8QߚXtFM#o%n"j QX֓8  g< \fD,+",,-orx )|-pJd<ōx]oL2X,>wN a[B42 xbn4=v9%PC{S(`ݴ\$5[(:@5i1o˚}J12X(IYuO-gB1U<__ O բIo|:g)F#==ۈc&9o'Ք;(GMzg% 8>XQێ>Pk uRo#`m >K<|tR#-?pۦXjKJ%@p/D= t$xJxL+I!R=W-poXA0/rf*[>u<)Q8em;C0'rqMU*P2?J\8MU&P*qQNYU>pDd^\ UAqQЌ`WK /x:B7&pM*x =St)SnVr&Gn ֔b׍O 5C }Scx??> OxHb15H7_?~^=,qTIyCbIfs?Ӕ_|UT6r{{Bb/Nt{vwgE٩1fm=2J-S9eEcD:oK5GpBh39aP=cIb bC.#'nBdjJßV2')P̉# +[2 Fd;xpxZ#L#`ӧȦL8;e* HTZ3Ykd/ F2c[<*> w)t2yol"va g"uX\|iO#l2ГO>CB'2^5rAlG]^[]=1z> Ԃ 50h|ݶOx#Q*|M9P莽FIw?\,cLbƒǖ&GJ NbD*UV #PDžV%@o רoPƭTJ%`!(pVŗ,:4Z%?xvk^8tg:HwZ-lWSՂM9w#<")H<(B]A c_7#<"۷Ne@d9~xW/|lߏ m(皎k'w#J~?Z{G9~Uc}(cRf'&{ LQ6pD}n"@nFuN ,^jk?wQ9pϾs`P=e*qi? =20kJȆb?esi;A Gg2.=_=ҏ¼2ɇ"{kKs-AF< }jn%nQ9O7FLJᰯg("&ƽZ~_w莮>3]iDRrTْ\E9e=C Pu6L#{t$,Lt>6E'zv[o7'ZEZ$ϐEs\"tjD Dd69mV8q9.%je>BPI'!-ƝRNk qAz~jd߲vs5S˿#ܖ7; a}UUPoCtlO-v=hZД;m)zKêߓmK(Ɖ;JEb"N"l[1P.9Mz~3!XWxMF"1qPIaɝCmrq=bj`]Xj9[Jj@%.Gs,gWݪԸ4EZ<1(3X^Nm^XND y#d.Os,H84NеYǒNPz>|&WW7;OĢ1J1,Z㼸-Oo,o2G5J<6jɒY<ű swI֤vZ떣71;MBOSuSLa@>,Rq)D0Q.0M1gW:Qzzi8=Aғ@T\USKv̩s'6/dgiYt˔Es9L!s4 $:zi~'uh< 崀\O+ ${9{h\nȇr.z)~;H%rGk1;P-d,ie FidҔ)Zs=aOu*:zi3=D {l]O1-sHUI`8.XUd-)&_j$6甓q]C]O1-'|٥3Ha-Pg), /:JU^;ӡ [ƳTxcIPc~AG-7y6B<D{Gr {O}MAI^ǁFO-wȗ!hL뻌I<M".ⅼ /lIp@r9!RO,OXumxyxxb=aܱ(,g)ceR,I s+ĻwKaa xBwϷ]N!=c@Ѡ e;QL0FD :>ӂĤ:l6 Ijf!^QBO`P,۷-Eٛјs'],E(nxFM,OWk8X[>9z=j\]UȰi|_@>8T.ҀH- G~&~`]x>l<(L<B"b 5xPAݻ?,v!LQO96j*[1T% $ {3T1zq|4 {AvMBٔhwaX,{yPed]bSa1f4HeEj?.] yHe%jޝFX*riD:aq3,lj˜rC>dh̃*tuT:D*z)4ja:1ǰԘfst,\C 9HeO@l$HTfRYo30F RC!rU3][&`*Αۑ `ϲ%*+S`0gdOVUVvIG)b d린>#>b)I \|oy-UO_6Ylt>y ~ydΙ.c:2j@2}[un1VVS:,^Jwy`Ƒm9I- fPYow`jad5yHXI宗_ǞexY{PXᔕ(& sMU9Ji eNY mC+))&PK;gΠE*(ЊZ'(ɔY ӁC+Yװ;YPZb%`+5s 00bLSՃx/ ZOp\^z`hyn<;uLcpqR@X雰aK<X_XE:CM>X\g(>C,Y5yxe>UM UcFÙUz&Pǁm%@BqxSVKFn!Hk@p~bLtS,xʄl<)IS,?\mh1|X.~x ;H+1X6L}Č*-xa̚i9xwG'4xb<-׎=Fu\wD 7"Tz xbݭHUnNo@,ۧ:}U[|UG*}W7:$q 8*n3:.'C. [0S6IW)O wv[\[ < 6xo/L-: 58x'5 Toa[6;R(S A@ <շܧǟ9@W8G-맄1s_hpp2.ai7^#{qc۪BD"iS|y{c;.zl2fWr"4Kgrh5;6"dpzi()؅f?^QMÜ+9X]R^O1-ovɽ{V]O--c8)kh]O/-c6-DzZi2'lQ=)Zw=4!!Z<1ƍ-խe-Oo,|~|'f5C:NNӨ{;FRKXR)5+9zt܍6ZCF: BƲfW˄#\bs{vycys%;]\ѧ˚)[ݐF_]~5v!+9*Ze~]6(zbfx9I!ݾuw-Y0E=AFwFO,zK>xhQ2SJ<g!e4Otu3S"F%2QSE.g$Ew:E</|!YK]ʮ }tB䉈%ߎxu%qCz(1Dľ2FQhȑ~}~Kh-4hoJ1ѼЎKC5=jLbxZ| i>{{\oKT ~4=&t^_G;q}-CuD +<2qZ?G= ʫA\Xj~Ge~[ kt<=IF w(9Q,` wK,ut Ф`Wa ]IšRIx.eD՚R[TH➎[+JyT0 WŮ&/ҕo$x>iY]N č4MWp}W { K| Kx :{[_bP-6v ~cưSwI&:9 W<>/1ώG㽎Mo`q_?9֟Uh#{,FϗwP_ǯ>O"pGT?F)՜SS?Ӕ_|UDQX^p S4+ri52:id<"i52:( 0#Ӭ"3YoX@Af[58|Q񮽆Kz2%lb}9l^=iE$~YI5KF,~4" fbFҡ;"~_ 7K*̺\_ŒL.QQ}~.-#ielXJ.Z{]}`M'+5Ͻ̙T##a5K-0ׁJP#QO꼧޻xT>GNr@ ]v `A?]ĝ)E.xi$8r4՚FN.= lu=Xr#I^ O%fDL L1RvLxTT#<%0Qw†Dh^Q"#I#~\%$RaԍH #$ Vd卒18⹘gMk݄ԘMuLykd&Y4 !2=k]`w2i|r0BoFnz0C52׬,&}1^jKЯ8f~ 3_`  =_o]_1&0ApcF AM;9{ccO^;|UJJ p!N#@Qt(oA)>IH  9Fbd #b` e0B E2vw|b4FyDosT5-dlC_ t ,/s䘪<7d:<5iMblD-iP3N٧ӞFNʙ7/d>A4Ŭ>u<?S)[T#OJFӓg0 w \.bsllpgf9LaE.c+bUIO46BХObь[Abelu99 }u;Jl ~? A ?HW_`4?>~/ ߙK_C#0nF0iuu>ND N긕K͝EomO\ZBv#bJXm @ 8'C/z"' bBΈaM\y6A[3rQtO-2'npVr崙Е)MxWxER9W pXN88g2]ǒ|"W$C`wKR;Hy뛿 |<멧$%^0Ɩ^zU^Tc._eW}IҐX"0MOjao{et>6[z/b `8äeZ .1駰rmuv<D4=z#^C2m0=zFA~A,ݣt ;u+ɯQ6Qݣz[i{A< =rڷski~\Zwa>bt  fQ. \[|[&>{<2k.2q NYA! ϖy[NEZm0rvfvv,ڸqоU@Yxm\1 (EUζh)ZyJ<OD.hm[LHS(ăZvSxO`qytU<0#:|gƌ[ #n[f ul O: (KX =kѫn[Q,q)pzgHU#W˦#wr?I T"Ln%&hzrG:pȓ'_I4g G !Ǩ=K='3aNG,鶲x46KI#ztі $ly=C-Y.RF-YӝKx8aaHBQ[M3,Cԕ;r T+r.Gr$5 htPQwi$pf G~O N~du~O-v'OjȜzwDntQN Z=6 ;m%EѶY$,l<. {lYkqzKP;<<xmY3-^_a4p[lA&E r8 vࡎVfnGiv˛6?E<ձ!WfƑpȦy.~ycyP *Iշ@)sm[-|]!袤 (8 (kZ)#Ql`#todqk[asƫx-n+Aa6uݍ;%,Ma4N;,D/xXe<3xaM,d^zK5xaپc\ѷ >u;։_:O9ዃ[4I|Qo`@0E-_ЦK[A)-zGBjR@'[)]Q.:*`mbr<8\'ڸ.R7蜰vO,ߊ#>;#5xbYKrae۸nR,YWk vV^z)r=Zi Ż|ZfoQ&Yz(@2{r!,RE;??ām(ay4 5ye9N9U>D.0$tgx{,I(a-Ӡ<U&'$`݊/䁏(jDWqZ` Jއb1e@6~ա?٬8v0}Hs'[)&Z{Rt6#PpycS@0~ٌ8 UW[ <\Ҵkk3k;4:Xg87 qs1P߼4!NF1,9DuyA 7uԮiP2}[x= sTn"R@桔QD$Թ !R]CmxSyA2VnEGL WH桔Nɥa7y8ejBB@糌<c 2"E.7_2G˿]n!;59Peej^J1XzԻ3Hq^% 5+c&3{Zv&ڹDJqژV8EF(bFJeLYYGҝHWu8اMñ)#JT;RV/W{rO<|AcdH6;w3FHQQ$/Q1 C5y0}Yҹ?8DQPs ڈ(8*^0,˷.=EI{+`͐?䔋,j<$1\g%hjR0$[lo3~xHbNTw"fpL"6ESIÒr˱bsYe4(RpA6oۻ)Ă7,Lg?Yl'V'*ƃuo%GJ`a8p 7J,wiw&dO7їNl*$;A#;`i' Π#2Pe6u( q`rY;#_Y\ƃ-G+]Noj2lhQ% w/]v}R/Ht+ s<_ JO-OybsWh(Su˓cu7+Vh(e8oy>]ʹ39wu5!%ۗ oʓJu=!h'EJ-dmr<|R\O+-_H:<^c8Zs=a q=t/V9aSI˖}UI U QIPZRIQ`):reNZy:cb h~L$$[SK8s'P8[K]* mY8шO3+2EYwIc*NdW gXW:LEjJrB.B1cy5s;Bu Iqm +6D`í=vDrqf ,*g*K^wզJ\2elQ杒Yx|=gpȣ|)EXx׾C `"%ؾ3^2)ГqCdv I/`K)ke<2FOr.BʣYf<~%<ΉWC'V6j3rp:J'K/0 OxԱ w? //gxkUOp7)䨸K=c}?|/?yzr~IU "Îw}߿S-w_-ws>Oa??Ï~ǯ-GO>_?OoiMd>@K35~~?0x?^oE^30_kG./6WxԿ?SoOno?~~q:!L9 @f&pq ><]?Ã{W߽|;~C|/~o>o"wݻ/a[~|_o7FӴ UoY?ۛ_Ͼf˟U|E:(_A륯筏^D~=Ѐ}?ݻx1Å;xo[x0}K 湞6}6g_Zjz΄S2zӓo~!kAz_(N/b'\=w1*>'"endstream endobj 360 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 529 >> stream xcd`ab`dddw 441U~H3a!cO/nn?'~.Ș__PYQ`hii`d``ZXX('gT*hdX뗗%i(gd(((%*@ܦs JKR|SRs|^a`aX(䆅?w.p q?l]Kfq^-]]r>fN=iKgvvO\P51%KNxǶҿsflq$ј߁پV!ݒ1V]sV%'vͱ}IxbgW[g)<< EDendstream endobj 361 0 obj << /Filter /FlateDecode /Length 3666 >> stream x[o77sI(rCS> KFTINbo\9iZH9o̯V g.p&7gq$oq?%Lh ZL._|buͤy8;?zf̊q:S֖j7jl3Vkd#-cن9P;SsØMDZqN9U2HXW>tq|ɶt G,-] A]=.+k-PiKP螌7d ZTUN(N*QC<^7s!vf\mAܨp$1 \<'4V+h8ugCe,l F#>%`VZE"%2O(a|`q N)LJɌZ)F,F6=8S6_gx)яrL;Ǚ$IhFדRעsu͝(S"@阝P65ɜ 0{ è#a⑌w僬D/ڎQƢa8}Ըh렎*2mjQ6z`h%;HXB̄clltVF/!fʖ) ppԡ=ɇ@;ge$oCfhJwSe{dP!t9T i*ɧN_MtIQHcXk TM]0d0?W8WBr嶺 D\دvR$z0$.c~uL4%e h`VwVc Fƺot໭:JzXvKHia * y\3\9 ޴_UHKoPqCS%Jn'-Y8& ΋s٥an!Ik)ʣk_l#+Rh!431$(8`8+aje%ĜUwM:v\pُ#EfxВ&ꑠ>4`'}X[ZHסmA>HBќJ&N'*ǵ 6mNeJoe Ŵ&zHySP-!. k})`+-曼OJƊkS 2Je=ڟv!jIs}\(hpZiP#d=,Ftl!0mIvF<5C ;u~ eBfoZҎPPFsx|H.',Ծ܃qd`|PRN躭#U2voĖaX^RA(N06G@|H<P%9VM6is zُJqzWYi,?@i:m66B}gq[+;|tրI,=x+#Io jka^#fpî}((+\`|ՖÃ8q X@\,n0)NJpolr6DZR/$-)H,Q1ܩ[t)0(dz.'F{p5 I.Zo/p5>Vb|gSbMJm$Z֟b Uwˇp?)6yԯ- eK@.Z r7VL[Ž@6f1 [K(7OT/?Z=5˵L5Г'Gi{\oW9CЙ#+%fv(Q/8߂78_@J+OF8yz ![u6!ްB[1LՋ- .oh.| W]8UKx7ikv3ݮ6,/~.B+IU! oqUxD{«n9}؃oϞlZYe8VȦ=[r788yT#I?aendstream endobj 362 0 obj << /Filter /FlateDecode /Length 163 >> stream x]O10 @+ ]ZUm?eB:gv׎m_Xց&7$i, Ÿ> stream x]O10 @+J. 2ԉB:gmyXց&7$h, Ÿ<񭼐U,2+7ǡ>UiB GMQ1 欎튺:gh*C in X3 5S@endstream endobj 364 0 obj << /Type /XRef /Length 262 /Filter /FlateDecode /DecodeParms << /Columns 5 /Predictor 12 >> /W [ 1 3 1 ] /Info 3 0 R /Root 2 0 R /Size 365 /ID [] >> stream xcb&F~0 $8Ja?V m!(N_'3 ;9 S@yyhl}?)} M' Rk "l)}H2p"A\X} l*d^ "րe7H} X\Dd" @&3ռ 7D vI/i. v92dp- "6Ii.`[tA$c) v#[i`0gH9$+5 endstream endobj startxref 861649 %%EOF plotmo/inst/doc/index.html0000644000176200001440000000107513300570625015307 0ustar liggesusers plotmo

Documents for the plotmo package

plotmo

Plotting regression surfaces with plotmo

plotres

Plotting model residuals with plotres

Guidelines for S3 Regression Models

Guidelines for S3 Regression Models    How to build S3 regression models that are compatible with plotmo and similar functions. plotmo/inst/doc/plotres-notes.pdf0000644000176200001440000065103114055554252016634 0ustar liggesusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 4349 /Filter /FlateDecode /N 81 /First 673 >> stream x[[s6~_uj­=$q,9,_TF%f4Pso?_ 9IlI4bif%3LK,3d1ςV,bRz&Ïd%4SJ9& S H\`1 ΫQ=MFuŞS(&F( w!ԣFFGy\_Kt6Wzt@Wg{ך}3ݜVhśruBi͞\OfZ x\OdUhH-gn5$5y@aAom S,K{M+ak3i2%; v jQ/[(ЫdB-` A:ddQ XRK֑g^ =S|yIC,P閄L/Φu5EVgK{4+hUL#_I4|F)DրmEo1K6zN-ԅ!o}eM|R&L Ymֆ{v%Fibl 6l[T[]jʥF\uLK(}OZY\^&DMf9ɂ(3#ẹy02۳=6p|$]tC_W ?9WTMU+E{;{/1hϧ32xl2E{9BˣAYF@EKk P:0>/KW&Iv -7wkq԰)ɓ>]D)UKb~'>?5?o;hq:YO)?MfS^]xlWs~/9 _)ٴ|R)5ЌggY]L/b2Z\חgϾV#łpvdOe*+~MIגztU%G@{G_Z|</V{B-m =n`zo?룎bi\\:ٞ:ꄕR[g">KpЂ~k uVqZC.h9F't, B,Ӗp`J t͘i"Rd"~58zŐ,ВD* rOH&H;]&_Vh^;_em?F=Z='sx U5.έl2W<=#;?San*>Hї+4N|JɸTWD/ uf]0esK"օFBW9חB|BWw>v7pr~߲)4{ץ^aT'bꤚ/Àf2k5-}|׵|Mn4y]T_U)ۑ')T!B//rHrmJeI~UZ UbW'pCւKX!F8I;'’V-99,XhR45L  <4Z,8m I+p?&z|:z3]Y>S}n(S>L.CD~ \ft\EVy5{*Kp;ZS3xv װCc컈Th;L+]_qo»qWd60{CŨ{zQ Y(:.uI'%xyPFW|VX69ݴWxUZZEcA :4X޼wlb{)ň6~s[LpsIzs !:$jkTޮbXqhXS1b}]ycK8 E AC!mZVї$:em[H= cާ2{7=hÕck;6_vC +Y{?k$Yt*JW֢ۚ*ޢ3"XIM.˴w1B`RSqmՔ{ZG&9դ'+ąm5&&FkGy.Hc̦Ek-6H雎Eja:V{&-]hz`?SH!W5h/YOeZ\l(E&MZD̑=9Me&UNǃV)gpsPL߅ @Y*( ?-]=ƦӰtZIdi]6M9aV>++H"- KotA^E|t`*8W<@ߛt}a(e']>6L(@P,$EK_8Υ.D)"ГttRN:*WLG=,eVw?|v}@e޲h 5 G tnhuvXF%c]ٖÍy/?9:൹7]>'&y5^;k;?z۸9t7?99dYkc}kHu/:DU>SmPBwBXCvw;:Jse>oƄ%Wpbq!0aR90z., Ա5yu%b曺M[P0 j:ݤޯAčxl>-3I{>:X1n/00G[gE2ut jtJk3bv<;kE# VQKHK=&Ҕt' m+J#r=!zYXx;s AQDC' XeE (뜰SK_`P'",Wot\vc|v)㋇:Ceols6ü=*QD)R% a$m6nkHV$6^y1CDk~~]nOeC Ωun-{׏Zƽe۫@W>~U>޷>M`DI+#%P}2ioTC!OL3fsuR,(Xm>ȂTtyJ;ƑI/)U( vanQh')@vj|a } Lb"վp Ev#3&+r;lv?c0U ZIȤ_ |{34 _ Ķ@@}OcTI6Qעϟ+r:z4{GN+iEgoU؏] ]C z%Qwyw_8bω;G©`Խ񑗏a:0_}u~YLY yhm9O[/o<ݎ75endstream endobj 83 0 obj << /Subtype /XML /Type /Metadata /Length 1618 >> stream GPL Ghostscript 9.19 2021-06-01T17:02:32-07:00 2021-06-01T17:02:32-07:00 LaTeX with hyperref package Plotting model residuals with plotresStephen Milborrowplotres endstream endobj 84 0 obj << /Type /ObjStm /Length 2619 /Filter /FlateDecode /N 81 /First 715 >> stream xZrF}GO{{ʸJ%3q2M!'ɐ%.HR5w=Q)(r^8JI9UB6*L&-XY}Eq)*{E!3a< )18b',[UP֖_Ee}_%a6X!lLClʙr\8L-W;SÝ#0@r)cG~FdeIʓ`=v=&0T0F$} 7Kb +e<pCc&!D9>IENV1D8-WbU,;;8Mw.SA%Kr&+r !Ow$SwD@8Nq bn$Ĺ^M~ , _T_dv\q@˃gqѡ~Ϙ6hV_z(r)kF{Y'Î.7LkUS۲7Oɝb P0D;-8;7@NHxt.jIBJ͓F܄$PcZ1i}'H`.(RW[nݺГqS+J~M}<<|jJ؃ C=\̆\ɳԼ8jM] U.ժ&ãZfZ<{7}d9IӸ6(ENfu.vZY׬hUmUK`UG/b0 .d-UQ"VLml[+6mֵ[㎬oêmGw ,[-5(+ֱΩcŸ)0.)h0ML FK״.a8qZ+kN70q ZŨ՞Y:u1 u}~!_}3NGU8磫Gy:dhLfB2 ׃v+@qtܜJ s~1u΄lcňvC-[_B,HPR%UztrCJ :qUW'i5Ϊj\MY5r Llp2e^L2GE0_jRyWl4XG1~X5W vjܲ! y+EBLȡH=Mc zz+}znx#t,S g Md%ڮ 4@̗(-4Pt)R( bI{'0"wlI}m.A(-lbt\!N$H:#zlYoQ[m/ie@ݚt0Qk]ޙ3þܯӶZZy}u4XѬאָ_]ϰMƋSNf>: B3ך&!bY*)JP}ݪUJ% O( Iޘɒsrp{}x:O/\>d'2. arg).k6ŷ&a+:b^z>z\7U=5}L)؄f/HSWS>nB49KCv5g"HˇG} "Nޟ%$ES6NMΦ)kjKL.@..lW:%&*Ze:EL؎=|2^ܔ,@| ô [ΦNSI^<|r L.1u5&AQr TZA%tJ4 ?>{ >*KD(-9E;:#V^,^։ v_:+ɗ0W.ۯs:G#]BaRPZ #endstream endobj 166 0 obj << /Filter /FlateDecode /Length 2570 >> stream xZKs##X!Ô9F$>$8eXY9|\.k)R&UC~{Lcf(ɑ6za*_}}3B8 ķfKaRU:j姗7gsQK!3ՖJW{Չ"%l؊}B͕T7JPiTՒ!ՊZUV@u` ٌ# Uʆ=*)L)L-L;i{6<1 >t" vbiDF/-2@ iOϻbEȧs%EhrP6EK{H)x0H @4Ў tK64mK?ޡ}-Dq>!o Ӏwa sjLwG{옂Y zp${,ؘ?gK T^RR6'm#EB:lf#iB8J !ş.'o&s睙4:#3{S `jCedVZ$ df qjq:u"(CC\a |/$Spy eI nn;}?ɰŰY6#͋4^s s5{~/&- 9fA|9}B:sCO|sh!1>Ө)HͭFK]unen43#lcNDSq.e@Ň$阮#D%u0T4T < L9k8A=wt1:lnb<>EݦqKO;z}s؎8#qxl[>!~!J[Dͧ<=ؠ"W%9m"' c*1#z(~Ho/TqȝO኶3j@!S9CYg쬶q$hlbR(yR>iE kixq/$1b?jams~"&r/jEv*G\bN*x,w=wzP<;vJ˸fAb8.wM"GAL|jmF[PFZn[l(x*mTER\-$t/,Q*ui %cv%M?bf1w>$9d`(A\ YE\?]cC 78w;Y^ҹ爵V N!=@!6#K_{S>vAo X|[nڇHݧfl~xIŭ`au\Pi+.м%?UGmYT褂4CGn [|WLosbjhe\n7Uu]NWGj:qv?fկhɔ^V!YͮRgyVa돋*M-~UҪB>pk[i}>*[NݦqYe/T7ݖcHR) !]v/qNqrm5ָH9;\pfyGXL Ikm%]Az30endstream endobj 167 0 obj << /Filter /FlateDecode /Length 1514 >> stream xXo6~7GC-CH`~؀vP`귺$Z-ّ;Df)uGNF$]Wqpvv?#m%X0Q`y33SI 8L %Rj6'<(Ȱa1XO~d2S`"3 "LqE z.XaJ As3AǷKc cN&FDf`DbL=1IVAGab(NB'uԿM7+kmGNٕjd'9X l^)`l:~\ 7..v/|;12XZXY70{ x3k=~s,9^pm5\e *T^搸yxcJ&$L> 5ɚUXdM{#Nc$E^Gfqn?ot/!s4UN`=LL-fB6 iKdj%BteM_8@~S h Ίf6~PGRUңjֱ53DMQ,L'C{f ?MQax) 41Mthv^GecJltj#Y't(o %\8a`XӥlNRz慠=U \87Ys>c2H@;ؽ7Z6tbVE{۟$fPP7eP8*͹kjng{ّ"QRUPAGb۔"ꕋ5P4fF14|0p=|_kgJWTHrcte&p_'w-%)Jt "}u~yPR7t,m HICIy2x^}\}]$ ~]ӕM4G>t1LaqbNQ-R )SAޛ-Э-H>xC \p p,3 z/gendstream endobj 168 0 obj << /Filter /FlateDecode /Length 4655 >> stream x\Yo$~ W-Zɛz< b^e{RXKA23xdI`:Iq~W V#=9zux4.~$Uf Pb% ѫXy3*3bNnVc!X9~}CX߰g=sG#]=EX>ⳃߓMC0F":_o-QȰq*;04ze/rJX"1s\i%~aQyGLna{S@oN8MＳ; ;ϑ.q}+^C98D͎xvPk\exˆ] \>r^,S:Ħv6 ' -{~d9 WZ]tG"ӈk_xԜ=-Б3-@T v*K]: y1X0x:kmEIZPtɴV}2h])j I7+mUnur4?i=Ӫ+GVװBT29}KCo7`CtW08'/zHBV[`Sܬ\ Wrqk`Zf%d|c:F4jmPT(,7"6:1a:J劣$IޥӁ=2Ԯ@a:q\ڏ%{JlŒfڑ\ .:B&[pi+S^\Ƿ}UC|);γK4>X"&*t]]ן H=8K ~džܢ0(+4sNSģIfP ·f zhZoq*a|z Nt"e8hE@i%Uriiaƈ"H#1jϿb,F C 9Y+(: 4L295ΨjA6^cqQLF RGvWڥ$&Kn;Qsa:I=hНED#Ou\99.GU!vZxgR1ř4pM Tg=lx>9QLs73dƆѯߪE~a8A)˞׷;_m 1r}e>?ݟnTVoR?XK*QPKa@ Z& o_~}nOKf$ZY=\ RzT&pRBܝ W4j}˞I QLRN |L/K+4;f[FK)W=%d@m8vp{G6|R [s*%XKO[ .㊀CaBsj\ 1":nA:7 (FGɂ3#,ȁ1mXj4!|K^ѺJ H?zWS-HbKӫ7 %\6,zz^hhō*KJZ郯ҪhMܧT[z|F]h |I@LObPRu|I 2M*`T'IPr⌨iKW2bi۸00M(Xb|ij%1l ZAvRi<Ӏ¿|* ?$dzN;SvXS6Zt Di݇Xui:)0ܰ7+ j؉J}ECìjZq-68&A̾ g FɫGmwrnlR##7N|\oO0 Ifpf[b+e盽?}|OMR(w!wFpvt<ڒYigۦmLig.bJP2iVT%ʂG3)GG*UD`#XiNmeYA&.jd/*iun8ۯen뵪ֽ<JqL]=AEJf9I^Jt3zrjҹ;g%PAy#ȳCbRǏ,=IP&>k+u =Π87`"= h8zS+DDo2N}R=MqUYAi*ĩ<Z8}MאFl Mǟl\#6c-/A<m)C6(͍wہR ەz=Nc3͉X>Q9sRscREx/B66j]ieʹbg|+II0T eFx;YsC&@>LOfH{A϶M)L`wy_|FۢCUB{nT"*iHkʝO5c2`T?:ED"zAP R`jr!kE ~ ?WTV׶&x>km]ɦ A4:A^Lҝ[cd<jЏ! vu}v5\ɏb-~7Q1.)?vQv'E)fb SIR???~endstream endobj 169 0 obj << /Filter /FlateDecode /Length 5277 >> stream x\sgoV7{Pdr:'uxCw%nܥK뜇60rEer5FןK^ݜ}JٻY7{w_g韫o/3Z)]=7m9#ZͫB.fHC->}UT4R/0 Hȴ(fJ(h~hCg_еa2uB& st=b:jn{h:s/ۮ>kJm5_<î os/Z/Tw&siEȷSbkynؗ{ a˩DR,SNKp&w\ԆB:_9Ű .@ 'k@4.rO=/dЭbv!tqL@"W__&G6߲1W)6:4\8,] HjaaDb+V/Q8wW47ޟ׶45N Pl^A8L:,&Cǀ7͋R"_\N”ls;;]g?LCfΙ2 3[iC?gZu plagds!#끡 ꖰwR剷)axp0K)+<6@zrx7{H6wLc[Id PP͹4 ulzc;lЭIy M k.n3B99)U!v@+}M: )x;'*B]  8#͈Q B\}-{.a^t*PY]_ # `f68(+xbmV& l3B0@rW Iz"p@3gQk D,dE[X o铸Ѱ/D#AՠJyP ϬuP2B5p?|[͜jdNH7jSy)`w.> xQtmk0$ijQEUp[<@.7I 1' -Ыl_)r]ИRh6/]ٌT8 6F>HX&tph լ K\ovQ9۹>[7jHek\1ʃPz%HѸZW@M|}WLCִ'` ाܖ)"Xb:-F%蚯s_<-`3C2 Dۜ KV/+LzLm^N{HQmF34N ٱgHk/ɪ0V{HzgGhbԂs*Q#T@ua=^uXƷ"z`"\2X{$, ZpSY-^cԯ"UˇK#@!!} cPjhF60|G2M yIIwxה)„!q} ec n$Hf#;IBD|{w.:- xߒK|#YX /S Wy|)`68Mpm6EƄtbt?Jz-rˉ_bOK2F3-V/bdnG|BuDK50EOZN}9ufgŨsqx\4|%VE)o:m~%oC7'p+h`hP7=Vw%SS /MUW-eSbbDBkp1ed\.7C溜^1":7aϯcˏ[ۉ>G1Kݫڙl"KѕSS eG5҆vqq>`bk;Ƌ= Xt]d.#+7AU77ȳH5T ޳ Z ƯG?;(7}t27$ c#~a%_"v;>HE_gה8Ch3T.wE}<&E1׫V>) 4qld{L)[׹BrAϣAjχDZD"t܍ \3]md*п(EІ s t>Y2 /no)E᜔,b )xuMvjQԑD܎9&ɟtpW֊J2.+!1$/@aE;㌰QllOGSOtۉ~FGX"s)T1Nτe?&"*x->_Kftt(yµbٺ J!`D똫yLKh`:eIqs ~#P7FTuU09Le R*nq!ʉ2 V}<&)!缍M ooN J,XhTcԵ( jjr ~mޑIF#JY4.m-қsaF Nx#8=b:CmuCI ##ZFqn^E6ovo?0yM5ߥOI͏''p.7ytYCfoV |! bPnd-cl"jSjY(@Lc1JEV|T?B1S(&偳<^M&aXS+ SVȣ !d=B2-^A?@`'D@6ya|ruS8/N2{(º8?ba6LohCs ,~#*D4fi$%=$s1DX\^/^7?aRf"eAoviP̷ӱ @0~,E}{s{_UN*U$ 8|F e6jOu9J}Xz'P۰nU]OTp@%X$*RPLT@f_R6O$$Y#iZ) kJ>e`粞qakQpqu b4F~_rzj}Ƨ4^Jy(Sn(zEq{"-oo[4lFSd;~hG3tVxSk CT O UhoR.p:*Ug4?4v^mBjET 8 4U_%8E\|Y(UmsN٤?w%cI=.\ Lj~͇2G0gz6,' )`o'ⓤdDMHĒL9R_6 *q/&NQZSr*ۉ&)Z0jK¯[Xj%M}G;hP,Y~"iAk'2l c8Dc ȅKc KH ik CwY_ton,Uc cҺ]s"W#ID:e$PS*0Ge`@]-Jk$W\xT)KI_WQ?c\3 % pA?V#Li'6gCtҧshNqH \J'8őu=h"0u!Uѧ4Tv1N(N&, $-z];(v9xb5Ռf7 l ES'P4jy AlN/)VʕT&9eQ:!>qd(7)\-%J]o1&bv=kH|6U / PO(Ƿ볝3Xgc0|%B?F0D81=0Fڻd=v%iJљ~T]U'%G+5z7sC(xLhbHۓe#,OFł~&iOJ6Rq>>7fZ%NxYydTx*&PڙO']ߔt.]^0Ъu>$Ѳvk{2endstream endobj 170 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 4206 >> stream xW TS׺>1prPAEϻhZUъ"TPA$IIœ28[ikZPkZkӵyoIv[Yg?Qx߼s𸩣5HcX֩2捃|O-UH"GH]gxٮ[2&\"r]" h@qXdT:sITܹ2=$&],ٿm,R.I F,n w-MK\׋KDA_){Ǯ&$B~{7(5fLs{}7UŸHL#6Ӊ@bBl%71AEb-6 |/GxE!ф#D#gb"1CL&+&#Q5E YM":5pr1sƮ[r㖌5~= lB>LM=i$1Wĕ#3ruf.?hhrJH *f&hg=&dgR dQ\FQZ2_Zh"Fޏ&?uX! `PrHOm_yFvhN7M@z3v"/{>tʧg_biF;nCW"@f6R)r2CBhWĠB@gՃoAZjrVR.Bg&,8k@!-UA{33{mK/>7z}ڵow#Þ{s1]4t!#ky\`A*42mH7;̓X7(.mg2 g|Q߈0A[| 7pݫ (PS!U bYM$WI &8tc{p˱M"}۠M*_iMF39/nLWK5L!p,J 5vEKJy"US.&H *J ANzǖ,f=te$ÂqyL&šIjsRc >shG<RSTHO@0 $$2t)ÈsSdI1 #m 4^|_AH|㣍u~f.tFsKݛ,&|Q04X7D QydkA(?Lqr>74j3vdאM} SND4lm(GAimh׍~ETc rigUo~3Ze~YyGA5]7y}&(Ǭ·]蕐5) Ey' (j*AЃàCrD @1wSz$`-'/`a6NW\qO G$9~g#kUf'Pgwڤ @bڲ_ycm' ǠYzGeŎIJ;l/.#bHJ) ^̰RZ[(USa \ X/1T3R-L !9Ɍ_/*^L yՐ]5.n&+,H@3-H%vj@9OJRa=NA$)B_ewnh W,3x>eugtͲF>Cx&h:v>ӂ.CyP\hT%vM|(ETEcIkmJGbw0#KĀz„CY8'jqIz 'ih52 Io}OTP@@pV=VvvY \7pZǍ[ ҋ+ x k1hhq0A_{MTz^ufвJ>ȳ>(&'6.' VQmdU\S ..]>Rq0>&7>#3'L N_ED%.BT ߟ߱cܑq;LŴnI$2DR'klkd 4 #Ҧ1YQτL g/ܺ;1W8PU|νEjdHuJ'Ug7k$@Lm _л,FT Uy>U畜`z/gS~{%tNvB^0 -[ ;Թ/_?yɗ)Lr#w܌m#|)raPBy$H}bxmRU *JOlSVvܤ5a:,u2 Kh8oQt+$DWoT~5?v%o};|YZ+0򮛠kf5ƦwG$lٶշ |,s9ti S5ͰQӠ 9<_a|njzWI|69ʾn(IZ!L?1jy=>%A}z\'7Q05Ş냔m}tvb.NDTDT̰6 wx(fsDbJ4ѵ|9OskS`+h⮂c"¨6P§h6xg3Rx4]e8+hp0 1#kxAGe UU/Y' \*vw?,CauvGH['ޏ"W~e)U'egդ.FS Le* ($}FS7cО[>Ö|:+Z#)#7% ).8'# HbZ; - 4>It~q~1(*RUIY r2s2A4]}IUy`fw/&n ] sCS/o@_ ztn׮]L?dh O1*KZDI  nN$8*,ɼ|fp~U,_Zl ++ ȧ 9yX`QHgNQMCesmfQVSy{w,X.Ţ99 m EX7:~hNgRL`E_b^eݦ3vilAq~ (ke}tóG6>0aKw6WW*Zj@%{M,%HDx72o>n&12@fVhC 3Kb U4 (T]yqai ՞:a%(X]l^̚JkՠkFcmû@ur@^KozoM)3=*| ܾ_:}?wߕhgVK?k|M[v,e%~_م;wMoٴy nwA\LV0Mr=kI{~0/"_"j_^v9tѦjfrʢ b7Eqv/ &.+H(G0ƱcMc tendstream endobj 171 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7353 >> stream xYt׶!b17K `J(6c\p[UұlwIl: !PBIH @z\%AB Xfsg}DTnH$ڭbci0H$ &-Y/;\ 9ؗDҐ$ۀ`_oPc̞=sɳ{IB}~ۄL6}茙f>E VSè5j8AFRQj4@6RcM8j3Oml #HmPdj5zSS4j%5ZE͠쨙=5b(_ՓGS@ޠQ7)@EPoQ5DQE=E({R*;%t vO+}I}fɒiX0n'=lz<k9ebAoޭ>V}4}p_Ϭߤt`XwVgluuਁ5 JoA{ nyfN5oZYZ\JLUG{e\T0 oo/ *_7/oqx)E*z*I5MwXi׬"g7h5ms-8Y`D7ł "v~g|ؙR`نu6^UѰ V]Sm+iFXN}P~`z<BJu! ,:l:Rmltbb1?[^!$T!T1)yD[tn wNҋ: !5NwrPR Y*8ԲF[+ bw4 OFѬhVى2eZ bfX`A9polX-Jy!0Ő%z4I+Lx#͚.n ?A,?;,*]_1o kߐgς2 JմsdZ6mHVj e ޾% x B?H\4EvBu7>~܅ۖ\ #+'[mB6DV vlkbTn&`K1Hqv}B9,쌒z{ycY#_o&ޢs"z Bo# qg?džIB``o 4L2=o7%fQаg*$A(ĬM :V5iŏ%&űOZ|e 2T-s!)XtԩNB=G/@Ղ&UU;cjCXLUAIT_w4W7ß(l+QtgvLঢ!AA!ZdZaFhAuPn s]Ue$(^!|Z|]{R%L,WGAu-¸rPf(AL"Ex0i ]UIiSӷ:vJg/*3L}$ʞ2s PP(^/6N9{6)?ihԆo~%%yxtW /Tw*ѯ뀴xBѧ`7Svf|Bv)D@,臋hpFhA$ &˙/pCO}~V qx0Xob#ۜ%! %~)z/q?<{{T5U7Q2BAF$z_Xľb2zwg>i< X~GUP[1R]G,m`Ј7˒sH-/Ejm17p06$O*kJ{jra$!ýA.AzQ*ƣټ2*!&>!I0X1X irB`&2vwao:r 0RJ+VpS4L/^2Ŗik4@.iC\}Z}941U1վAq^/ԍPe˄:m$TeQ$!)AEa DRep(DBTAU]3H$zӉ(RīS wDrq:Ȳ c[*ӉcA +13@.}Z,uZVUEkъ|_IDmҲD[]r.vf*RM\eUYYU7s);̼̄o~xrj&nBw3Tzz]Hr'(Ve,긽D T? 3ْҽͥ%CoRk ԔNYaO#&}>'x 甆a&?=3>hdRRTiV4He!xcrڡt;+<=|!EvDV߲Ck;t8gN;<[L)JS!SWα|yVjXAD1(t`Rd 3Fj-ă'OB2KJsrJt۪X[7BrrLP(ɡ3C!J1i$-m%s4skr>Fez\AgֵgTzSop vU,(0?% B?w->ѵ:Ckpdql 4MM{\^"UL%lNT\in1[{p^NRzYJ6"3XmŨ:0V551Gb*39 iE~hLW7K!HOt/xhj,I=Nj;z2Y00b/A&xJMҒ#sp 13dYR@'9ƣ9_-^/㫄b9M(I 7ɠiӝ0_'^ypg(מD3*,p%(2w52N"Ó$aT&Gbiׇ$gZXxCċ)Hh_$f5HDHޮ͢TP[R,L%[q/ۑNOby1:a0/^wm'27qcP5R m ?+-a*mVZ669htΏ)&ezme\%L)lR2# R~k/-{PI&"/A2?.CCZb+?6mqA&=')ߵ6q(Pla9Ų*Ed)޲()ksӶoMGP)n6l`)'i@eeS;WC[Y- FF@>R/ #vܢyp Y4~Vi]z 2YD~47nlCTlZtD{d ۼ|ȓ%CJOu rvšQ_c z'8\]E|-R*91;Sq[iy_봾uYd/+%^4^yOiI=N'标O'lv ;TWZ kxAג}.e*Si;a'PWoH,PL(d.@%2A m&qӜVcL+бbHbk+"k*8a{"RVޝGHpKWDZSjEѵb!Lg79Yxk6J{%r6~tOvo=Ѕ~96#4IE5&+N=w7.lWߑ[{Cd؇τ8#w \!zMUGgpzCµ ?(jԹm*CBvh"#BmyH$ AXl 1Ou3 Ӿ7Jv~#2"M=ZW҃ 򼋱O%Pj9 );rs93ETA42ea0QJKb&7#PZL_8-Js!**.-`S{YAMZVI^ۈT,ܔϾLz"UhSx6`W\2PjEVѝk}_(@qf fb(gc_fnmV8ZX,Jf9]p%8܃M7TiNXQDg&wze5$Nj#ve #qU>o%H[Q['VBFk80R{* S9?VvϷPkݏ*/l2qxDv Gh] c$ udZ)<{l֧Sѓ?!TddjJvEjs.œf8.\n" P~Qz?T%m&*heC/Zo-q:C)+Mo>ԇkB%8 PWZפ-O;VN[J#&Kse>MM.DT{aK@\@d5Q6;x_fW$]R(\en5=R[•zJ,sgVhwc넫j/&T8ƽAQa$~؉sE7Ȕ`d1*"4 1/[هdujcWC9soIY47߷Η+P^u=X y{$~xmsÃy5pxҵ l]ndQy5чjMsg,:w_7ArV R:ġC6f6sْES643 v{ Y!T_D`|8cZ9x,IBA8Gjkk>ja23=MRd/Rru+ ]GkÈ#vd?N?]$I0|/ .V7[wIɋPǷɧ!x<ߧ=2'FQdN*. yOA6a+s؟pWK{>#e1[78sd* BEvn-Lfq2Fk!7u44˂79:?4WѴ`Zb/gZ> stream xX Tg֭D-jq_#hbP\P\M@]iv~ ͎ &Fcq1jo4D ?2 fdj{{_IAD"amW:͛osD|}8N $uS0I73T" K  vf5oV]b#%%kie+449s"""f|{LP/-!VvV\<_~aV üem`]Țеa"\ntssoǭ~;^>|y,|c"Kf.3q`&1Gf*f1ӘtƉYdlY.f1k|fY,d`MbF`c1ØHf 3f 3d^e23&LPY8hƠAtI%:ӻTv[™r-6әsIO clqylX?~ّSF֏<;jΨQ{% 'iSc"Y5%%|Rp*%)h~ T.R!~P WRDZmF7:٧d,Q~Й,+Fȑ6SrHfk L/A)Jp/Jbs} z[P Yh`e\S+PG_o,27Ӆ,H4XidK[zWg}+D'ܺ_9rT[w:67Bl#Xاe;Wےr2|&a&U1ͥb-ڜdY8&cyhs1lh;ჲ&yER|M%垰@8 J(:t5HxQ.]WBzɵU+$d2O\q*C-Ь$YqjyI`=,(uԫ٧Pv>II8YMȁ|*A[%" 8Y/iDI ʪ:?NAa=SKV{};?v8dӗs:~)rRt0^ pp(.) "9W}TukGRo;C/RY{\[P ;('X\@KiֻG`BVEnXb}0{Jy;qL7C؊8Q ze!ʵ,wIE(2ȊIVABP?8?2 8~pyGR'8@&LmlmEC\8}Mv}.T ϥ XjhMc~!cg?ϓVߟ3RJnb3gk&z &9Gg(Li㹮ߘ _a.߻i;=>dog^27e"'A\4a-Et\&<&j*c*x4ʤ1QM'N'4Yz$P>$=c t]!؜!V xR@Xl6'P3lz،HUZ:m9<0XfU> ~/qV߈Ȍ ̣.c0㿖UYd=B(-QxHRl\#k˒J}Nwc܍%ɂ}D:/~{G|?(~dl%!F C%G$Y6>\'EÂhT.e^ANW`i`U*P@@t)ITU*i8Դ׌`ۋ,%[(OUJJZ (C݀Z ?MV fꢐUi/P:B g j Dm]1Hvk{O\+_*nf'vqv;ydԺ%dyw'Up6/@68,V.$hZֵY ۥa?#"~L!z֋$Ʈ%ŒFyR))~ TP ii49LWifk γh79Ey?Ein52#Ct~!޻;\>ᵎr4TA3腃8V)Bs#g?18&*EV\FU :o6sU%7䲄bOqȟċQˆ0e"/B˞2}|v I}eS,2pT+ dVBtDqd6ИN1SE||ZA?D;pAajuPj*B \BV/_=!j TpԨ 2+-*4Rmh?`)-Tէj-MMnBz|{$)Qg5َۚMT_G^-ފx|\'N4Ћ82L%x iN-Gpع(U%ɮ[׋Iɫϛz>kõΥtɴ)v=*kwTz6Ex5Goˏ],u0Sv3ںe/5Rnczl27 qQ1b &{2LX6QY+4*+xk) ~̿_X{P  t!7*&;ay2&}VB?~IFK1Wʷhpwhnk7 dYGK& g%Die[%R7iWҟyn2F'=DhW bWngtj&.G$kvQS蓰|UExAl}8qd)#~Ur ?s;ָ(ٳ'j J oNIQ TY7m$kܭo )9pfdi@Md4ꉏJ;eZZ&/{i 7#B)b2eh!5E`wZ*uca Dk:A; y *f1NOP\ ! R*5ANm!kD_ 2law6q} 7i|`&_̨tk-+W.cѶ%328UFÿдmz$zx/@2_5z.b̕A@`-PE:+ˍc \(b?wxNF\27dbNtG)idLb l(.HVz'ʕI!K (p_;EhWBJ ƒ2kFl B.p!&R8kppFV<|uk<*$7دu=rXI%[h;RvnUFF͆<6Na,[}||}Z[[_-ohk*T\* 11/a|EbTՐ)pt5m{7:2t[T2 K=Ynk^D|cC _rT_Wܳ)DFfz”twq5[t^$ŃW޷ +cC.xLH<3(14Xov>R .T%8} hs16Tߤ09tO9C"A|MU#@Ƨce; rۮt8rѲ 9耯HE-P۝ b#kn/Ey(b<2U~fn7T64N|3:tclBNHD|~Qb--(+M8q ̢ Lt .ܐSG6zW9O0\O̩={~JdÛ;[k+;Qtwv2v~~{P)TUr$QEeѵrR+g|5j?2LWȪ*Q Q߻ m3?9} npOt \|w tA;Aw'8ޤN:}GTүxgm'sTl9 o(,4[oZ;vyB=XQe1*].gt5Vڷ) ], DuyE"[í]!n`rp_ynb f("ؔ>cnJs _K֍endstream endobj 173 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 6141 >> stream xYX֞̎fƫ$QcFkŮ("A]@:{қ"ƮX"$.FFS &1Qo&[]ǿ3gVXY0Ded۱ +$°w'kba ōK$04aQW2kFN9pWj~?ʐ! uinÕanÎ0zst誳NJfz2qU_WY\_ҘQ㮍QP1 ?bA\" "" O˳WXJXc|Iqa=#ؗ>}0%2Gdo|́^>ݧ:ʞiC2̀ C/MdZdpƓDjU 669~'d"Döϣ ۵g5wBRYr~pƌK@ޘ[i-<ϦSNm({^iXNQk)֢_]Mga6Xmڲq8_\ !LSc26%z+Fb7jͫd8q$%ƪ 1Hs]KĘ4rLs { zhjh!)=o޺{ ^>HAzOpsL]zf^㫅2n%5ݮDWvgOϛ)c|f]˾)zcHmڰҰ:ˏ>xֳDBn ޶ӊYrkq-uCa-u""D"e#UP.ik5\}>V j4)Ftr`VfAs|A*z7@?xOPzwGCKTVೣdp"y[x|?)Np]}Vk\g]F:qK8X'9j\kˡe?!-d,hc#S ka>?5ݼx>j"3CNҮ:^pX=q&arXqyeO6Ti2\?^x܆b- cƮ /h-?oYF Nw>F!9wgKEUIw Ꝺ[֍3ryY`Y{psp% F*\̯u;qѣg>:em֋S!m=igc\Cd-(dJ*im&V1*߫|+pϟԧ8\&6*.xsc{Mgj8Nv6!>M S[4H+hYnssXS 7DkmqY;M/.,J10b_BѲܻY'pk A/dE%Ta x_v (|wG,2)wuk-*T}\Z.UE@x&%=)t[0Xq8o^\έ_fDŽvCwc&GGcN]SU7~0Y\Ģ/qkq_ϻG dt+gƥ}X٩;TF5Bs`e8o}>T|9btW"+W%4hU/z<^J{ x 2K4|+{bH ݙkXrq6P[nʨsԥ2K컥neVQsp_uJ]o:z)wܝn'{2̭N8n;yOC+KW{Nv-p?gr;C(({4';qhw(^b*qHD"#k,LM< ҰȀy?!m _^AOe%M gѡK '֏v5vd-IKf tY u6zAߢMC5ogCNr[F5>g z>kP$߳#ׯ_t7om^gж> 'UwRz!F F=TfPۯ9wX-suPKri\OUQ P϶c?pAbç6* 8_egXO;0=ЉCUENQIßZ.Ir٩;w }e>*8hiְBnliXe s /KQǩr%FCD%þ(.]M}IyAU9-hM:$ .g|셖]Tz,v^(O| F$1>Vj8``:B.q\CqBFDVtPaߕggP!T@{KҲQ8*k3+rzmB^mԺۃ'* )"$b26qHOVO%ihF} 3,"v DPٿf:]nuQi\EaYqiLnF7م4.j5CC.cZ@+THEt2lI[bD$SG6?-t;? ߛI刊&q^=i¿F MÏ&8Ϣ.X8HBmdw.r?]Aj^? 0jcp( V0DV<%C0EuNXϷnvFƑNb7xz޴Jy9eIk.""b DOՉ)Rgr:DEb:OU$%m-GfK\9p8:755q"RI9xxԖ tOiW wx#Q'$ 3džFRCY ]'KJ$ &13Ao>.>1 TLV^<# sh36@Ι5cW}l 0.[(>~p>:mɦ]^CZpl}^ETLJ{5[ #K=ɘPRKPqXd)羕Ҡ/_|RSmIcf!i=.w\ىT/<2X}}y"%6K6/QU)JKIn\?*S=SW'+8/F ٟO5'?$fffq*}>Я<dƖF 1ht>2TwDY E`FD*ްB"ʀPࢊJ2ڒ"ȣ"00"lA}IUiEqC%34tqtWp> Mfƹb}ߌgdgބo! $u#tq<5y*r(p:A  lKjLWri4edu͇.PޱN,^vಜs494 !%aJ3\V8oRdOTzgQ:w1oAIlfK! .ST6y~:m H*Ȟ=hg% ;X2zX麃Ñ;,uVj8e3ZZJ5K~ ;^mЪ՟?-dYMvTRZ db+NąeiiP#$/Ē5o zdyV4nֻ0>Z}/t>~?߼~?뎵yތ;y{7#H2?l٪^8 ݃ov@+!Lv•_b㚙.p0w's!bӷmezX=퓙eRcҷ+ ہ*$-M |2k}|Ã-Bifkp 9@$_}ݹf c7o|F[H5QmJo(HJp//OP,ҽëFh2%|y&e_~edi86Gq u˲XnFD)uQ<U\}p"3y sv篦F)Hq@鯡&c8ٿNS T@4G:muAg.yBk(CJ,̓EuX[Nɓ/q&@wJ/{ˊ^OLQ%@Tz#ؿ3(;ԫMoXY-ZEm3-Iendstream endobj 174 0 obj << /Filter /FlateDecode /Length 13451 >> stream x}[ɑ{?_ 6k~1ljax.>rf(4ɑV_䥲N!9s- `teTnբoWW7q?M0mn_l}.ofy_o_߄%z_no?h K&%IZ(_dmOP1bGLx[Ս66/>3.*CϨog2K(vsJ/]cn} 9sFH΋sE#*Z!\ jdS_e~EMYCb$>lߜ>(w1C*47jdDR{MI&$ 2DR0X-o" ('ٚh6' f Q &MRd JTvDIv q]6nӋ ZRyx*$Li-D6aTiV*, MGzR"SfCf-aD:̭B)EPSUCUۛR6Al5¡CטٴSD"]8 G`$"UO_@>!"?@]|AnSF7>d])76lIf /G;hI>S.=CUr.nMDhICpQRލi@4qv7wuiC㟕̏s>y)wq> (CGA*gҨ ) <2QޚA78:3-'e΍= y%SZߣԧ({]M# ^8W7Y *Pn{{uL]^yZ^\@&td.H `)i BЌ!X`0-Q\!h;{P#6l1Zx7=)]D0V'eowyb kCX_<sCV0suCW1P@ЇW =[U/OC㟕g0&)?!Jll$a_rQ)Tj(evZ7xކ Żџe?ˍL{gb# ǚҥGg/\uкu}eު& ,{V *Dugnh1VjD(?l}V l E7&mh(][z#ΞuY "Ljy{qJ[\vy4^CX"̏8=AT{62ZP9һ͈Hei Fo7k1M{*ѨĒI͈%auF(8gB{˱eѺj 봍rz@5vWwuLmJ=LwoHfv3;0eF-sU4jMG&Qredlo7I=$: p;K?ե[o=Z#]5ݤ1RV7o_uߴip}8h$o-cU8 [8J%؃,T$BLg{4N~zO44hڳPYp݉VY-źJjbBM,+e ( vj 4 au^3UVFp L>I=n- **#?yadK+y ˆC7FN쿠Z a+!}p$n߾ŷh3C~uX;"Ӌ߼|- 䑲?g~ ߿|BvlL$Lʆow/V1r8o^Ÿot> r&,)4"ZTVW^(fl3E15Jj41=R*-]R*-;6~vujwGO.tBa$9\Z-Ti)V\Ba$g|;;0K3s-2 K#QXڞzWJj4ûoE[wJ4EkW9Jj̕KETFc\4'lh94yPZ/UhZi7E*(i4qLa\],2SDT(| R()j[hlF##Rlx:i;UUi#1pJ)\&B O%XUJj4W)z( O#QJ)(I*RS)i!*:rUZU QޛUiN)\P)5+x\;LfsFs\\ 5J媴.Jm7SN?)Uh%9@LNkhoh1(r "){H<;(ƧBRf],:wR:=3sWؕP qNC<\4j@= 3xR*Sf PUiz)Y j]*rUbR⯮0URjm&TiC&GgeaB Ӕm[_SY4Z+u s\RhGvjF5}Py )s"F)\0WB(P*c {F\F܁- |gߕR-5qR W0._hUiIR*WJjP(*NaŇ Z(b<(#`MRdt T)\NyPkj(e(2ȬQ WbydRԼ&/B&c s`1!;0 HsLX1!;8DŽL8DŽs`1!{0 3s`1!0 s`1!0 3s`1!31a!0 8DŽ3s`1!;0 3sLX1!{0 3s`>1!;0 32 s`.1!31a!{0 C[ d=cCv` م9f0d瘰cCv3$ !{0 3s`1!{0 8DŽ3s`1!{0 3s`1!31!8DŽ3sLX.1!;0 3s`1!{0 32 s`1!3q8DŽ8DŽ3 s`1!;8DŽ3 s`1!0 3 s`1!0 32s`1!{0  s`1!0 3sLX1!0 3s`.1!{0 3 s`ȄsLX tO{y@HX(w1o\'v&RF>Y\BJtԧ>cAS֊5*eÅR6\5*ejt(k.u*}`0ex'=z%ا=됁0E&P&YoգHN2TVWQ6R4Z:A8pw+FG'3:YGC4FGAft˿^w+_tGe3:VwZ:ݒt(j/FBѣPt7rGh: EBѣP(= EBѣP(= EBѣPtsGQ(9BѣP(= EBѣP(= EBѣPQ Eeq僫',(xK'/ԎGJXO+OL`Jcge`:6qiY. '{X>Фq!{31!ܒ)y^uQyp)S6\ ǎ\2rѲJظeeɄ9l\1/B$vJڨWQDHA>EC+{s]9.~fTZ2PzOoi!M~ lّ}eB;s[xm~K0 ن~wۗ߿xG'!2E+j3mbojlMࣉB(p] ) ]|Pθ9(PۀRdW6%VAO 0o/9d'> RuD61ئ OX0버u%LZNɸ;HQ% Oh .(iLIBhpVv8-96hqunS$V.C',=Y;$R!(EٴU^BvIta_qC6oѓ)bpkʵ5P,8| qaH.VQlZdɈ=FR4OmE ͔Gme!kY̰{V$y$@6L%F:5n6w$+tEѲ[q#H }B'6t;%4( '3LRf㥢J!ߥ3OkFog=bZF yA +ٵ v->M20B,42,+-z]8dLA\ ]D]CvHл iaoqJل%J Y54Bb!!L0]B}'Yv(=oZRSZ$""m+=ފ"l䳞G+Uإ0hSZ2/_ڊïRVz_DZ#%$CTe PBJ9^;$D6ߓ, mvu$y1)IZ"oKnp4)0XNMbhȀxb'쫉_4[-1P(hf5y%D> ONxA>O5t8L2q| |ҚBG[pC%o%RihYr60dh0ȀhX|-?ڦ|M8z`pS ̣hSX-8?ig#yG=0G۰C q؏IC6r !Hټ6X23G^y^pc$ %,U{xeq4)G77voqɣ^Ȟ[ͪ~lQ$2Z;H5:"(A,3 Y|8ײ /xddsm2iVTi*:TȱKS#Ņz |%$B@JCO NP\+0beI"ΡGSJ<έּ*K/pY :E8 k8#YvĎMSAIm(Hν҄NKzCGj$KkW˅$AR.LrdՒk2\qB9:hqǹ.#&#l +kq(l^,~+h*`E"]PR',_#t5,L#5y=G"%bZe'-j" pE8IJS8]f* 2҈%F0/l0lyG?dQOHr:86AyL+|HG݇DA%sfA׊QȇF(G~ ⬌ G,rgք5 ) t݊)_"s5ԐE1JU{z= (0i쨊eRYxU}b "J)],eu.vyJ+J\%rot_:.Nr id1ECs9oGI k9ߺrD BO] ņA1>\.*rQVe'&4$`o|fbQ.i iG"["{=ZRnJ 6Bs63O<K,<(xV( lu^0W`! Fld1NtX'LSf=1# )xQrW&r^p"V"rk#<#8'#82NFg%NM;raHX-T{͸? `SND YUXщiEEy/0k0gq<V9w H$9ϑӲFSFb""x0UWe9 $P(L Qhde9CW.E/WCnsy/ҿ8BG7!zI\Jܥ @s-,W/g2x83"oV0 d,IK{zIn%ŽrJ - xӯ!C~;L(H7,4J˩:+#),q- "Mt]Drɹ.r"RZ}2 MI % %$(xQjU%Ba5CmةAjg+{6k%z4v)x3z}( BУL5xMg6ZP!uĐą^&TXAWCçrO|86 8F6imȡ^/*wZ0Өpr ;/DT ڀ<^UR pՊ q0+8}gb|T4jYè7"rIP|` i/3xQ@ ryV 0ܔ!Hf- RȏL6sG.PgT!p8I3>$,iM=Vg-@68h  :J=˹Idy[@2VMeI滧8W'"'*܅i$YZJT%rO&|V¯fSġl"KJi+8w4"q ŬTJ^RrD|)vR&yEӇz,Jx[) <ƒ憎P09~WOėK|eh =U{X2;0\)wbp~^HIER4B,5ЅMĒLhxZ5DIMKK"$xƒšp*W6!֔:N;'PHן%\+"$Y"$ga%cG('Ɖdlso1bS v(֠A$mpQ$xHl ;+ZG侂zd0dp$'y}niohyl8}??{ Lwq ꗞ$&*N_>xZ%@=9W^П]ܧݚ(pl/qG꒹ QMEn.9n~-rqqFs"wVqܵ2n]4]]]k}qUENª[Sqܵ ]/9EJqq qqܵ%+-rצ-r׆p-rn];9 Ws"ws8nkCkgq1qܵ-rIE]9CkG|"'v]qqE E: DH-r{k|"'^[׏[䮞y-rWEZ]^M _sQy^0&GLl_EQνp{. sfJѲY'0p?kͭaImo_w`LN?3-Чw;)n߉^^*e>vhV*^۳W?=h{w8c(ӋwFagp4?|OM?,J ٟ+$7ӠS~{yޓF_DszaiB{WP+5^k&C1 Q&WzSc]YvPIJ)9?,XiKăYa;0pSP_H>6CgqߚF(񙼺޾0NGA{s.ԤU(eW8=gd%OCE/m:oji#ݤr0M71fPɂzF3@j9R(Yߣ^I,;M,RhS|o3@prj<_Y;Mx@/Q{?F=jrH֫s颳d3dח8OjZ]E )Ѕ5]i?iMrBK9n=+r=p>mԸDȴG&AHu).75m@hj!8[<,>sO˫Z6noߜGϳaEܿ:C^kf5Ҝկu|"򧆸ͩDHzTVh26!ZC;_/M.Pֳ1Xޟ_X?%/,iM«ذb +q k}elqƿńkt(iRb%0"mXqi.p(ipBewD24߽ &IJL)xI}-l\k+hkku~0"vm҃X#l4`0)Gټ+ l_JItio)<+?֑|PHi3,LNR<f6 gTn/ȻATsQDķmң)bj[||u Pmx;i-p29o|S|;)]iΨn2 /F2]rm7Q&\š;*ێ}i;]\d)͉[ KXQn5 >Y<\٦bˢ,H;1ŭȷ{\.,wb+.-䁕Cz !JOuQh'uZp tlf:72 Ĺ[!F[8o3[UKAQ3} . `)_ǍesSjFl};@%#r{7gMlfvkOo oCghIR 9iz9 e9\|>n|_Fl [p&c݊]_2@ҺK{vn QūD|%-*I<:Q/]0Y3 ijSn).L]jȶ9?>3mQ-X@Q BߝZdrendstream endobj 175 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2825 >> stream x]Vy\GaTf9g4 (x /`s Q * .%x1@4*n&n+Qxfkv[3cMuuի}_24(qi)ޚXݔo'B5W"d*D'Ƙn1 ^)@0TH!3E&w\~ɓ1m|]o>qdlKlP%Sɩr] 3CQCfCJjZM2cbUIjOyS\M1ulE-R˨P*ZN©7ZD|(_JAQTHS!=Q2EYPJJb)KʊP֔ eKM$š ɖ}/gAOB?a\j@)bCS ESfFaF7@9w I! VҮ>ն;b+'^<>`؏pRI4  ɂ ?b,X+`xxC[%"YXpWzunpHF<#$T>XM&3tӒӚĀ`CC geҕКdFz5S~9Y;on6-FZI[..qoۉv H! {^4F@{xv3` ,L(L*(+(΂9E9(Y)0^Yq&pGzދM6Yԃ'vTbsֱE[*hcř/RWq y"?RZ &`9p?г7V型wmߝ28A&+#e8o[IGbiWPTb*`TMsLvN2H %"HcVxn ˴"E%L-@{h",׍fFhp&a<++^HrI26z[)cG  c0?[r`G|1u [2" j- CN{kHx3δ{6xUE)o'L|R=iW6t#׈~ n/є ~!k]{aX[ /3+N F[ ݲ֦3P$c|<;qжՋ m{hRWN'C=6E؅Qhb\xNY8q΢eMCKEO|^Xށ󍪥%>\Zv!=h\U1%oz`XLC0qL0_fëX(zV& ]Xމ+g+Wک=xS7Hί^q[M8iEp]M008H!b̭ά?xt*}Yoy#V$؟_T/͊칖_yΦ B3?dq{*aAQCwN^>t%Orʈ٘⒁'CbHIH Q̻*K\S `FIOSxKpqaANt [O (8KH 7[l&'`IU=] trg\ؐʶm}2]XMݕJұ g9zێW^mn}ool"qNLIK*YkV\uwrep7/ex`P{u/M[QL5 c\*طloA}J_TojgjNQZ!endstream endobj 176 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 4204 >> stream x]W XײvELPDdE$lDdU-b4D=({qDA% bp $(@2*Fͭw3pno3]TW47iZ715+1su|R4#$k^jr@ *&m7?ApKIh#"~S2ͬCM1+3Vgf"+1ui6m4 Kho)5.Ey/Zx >rV%&%'/M Y6<5"mt;Nγ\fϙ;̩ ʂ QST*BiTeES2jI-l(ʓZNyQ7@P3)_ʑZB9Q~35\j6HPrj$UBS18ʈQ)@S452&Q Nyt#F6PPblX8#c?l|l13#,x hҤ؀GޥIgawx3+5kB iMQncw-b-JV*ݢWo)9ȴE՝B%lVuS6J8^QYvQqFZ2N&>I2GNJwiB]SBg fnz-zYÞLѪ8YsPR8^)+rR.M;t>铈~!x4I|빕 06M!8 %DFY"ȉ,sb 覥IĞWW,N }N?MmzXGn9J(QW "EǷBF6'̰&%VʗLC`[9^/vEhqfHW4"lLx;@?ˋ su-}Y0e֌ /Ko<͞/J-;C\৬.ϭ:{ccY5A,kXYYK";Gk:7!yfn19).NHj`+6%kC'te閈V}􏎞.{঄dv-z}?^<Ӂ"M->`͹!5p6|P[\ 2tfSÖãu22W( q~jo+,=*8Ƀ'|s`#0X!}΀ Ā12C:k7$]Iߥ=~ʪ/զ|"pwyN Wi?˔fU]d7;RJ+5IH2jm$FȀxd>ޓ[-d}r9pǏ5+[>\f!#%6`01?(fgD}c u\]蠠CU4l ]A.*?HQ-n''R-n1VJ8QCt{<2Qձ W/r޼vֳ,agRrfu{ 0x|꣍pd;?V7lez8ϊ| 6(Me҉7+'sf$nXoMXAβCDk:QDբA<tvcI9`S6wը#f]*RaGD&n/>ud Z9&X !cU|kg#5Xtu3W4= >UݢiBIxG5;||UuSzV̶`"T Ud=_ݓԇ~R\+8HR=P=RT=j e3 CW*iiLyخ6υLP( ~_tdt.f{A3ptHi W-Ȫ;3 =r*E\Wnq;X#\<kM=!Ƴߥ 5*N_lwxN:DBjC0}eJVݦ{}nAw{,aV|}~sW\Vp<>d^(zC?z&O^bJ`$d>I-x9^b3Uo"Mn}"$i!<a%'8U 9ݖdˠ^b_'5N_}C0?Mc.Qaj<ŋ&{[e]\"`Wuˁ%Xa'G}e$PJ^ғb2m̎.2smZItz>7<&qnzϯPc;.7kϟ. U8,{Tȥl*7yNѠ>4qo/&^wa㭸A3ojB`F]9g_t-,]?Y_fݎLa) >j7cY3lS^ uq }!-iI$bYLHq9#z|W$0׊M7I` ys~Qݹۧmw1]΢nSolgLd2poW#aT>7ɗlP4GU'/&s;Q~ܰdIqr `IxLx~^.D s+8!X%Q _}tcAq st B:^;}q.Ԃ  sm@NR^fEܶ MaOO^؍=BgX"^y)(%@CR0يi)j-Fg!tƲ[aƃ]nk\¶!a1+Bc뫪H|iGn KjӶض_[m8 YQUKgkY,aLzTe-b_}_|a0dPendstream endobj 177 0 obj << /Filter /FlateDecode /Length 160 >> stream x]O10  ]Z2D! }I[.%Mů F0Lu@v=|JUZF'Rmcm+͟tF{8yp8I.~r 6/i Sendstream endobj 178 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 6637 >> stream xYtw!,&!Q a),5 tn"Y4FU-[ƶ;6H!e]r_x_I;.^=3hk7'NQ/K21QɁS¦Ξ??Ι5k~Ҙ!!qa1S^NN:sfZZڌbiԂ LI!M\.NH\{KiZqx4 LX,^"YLKG)c$7V']a=8CH>`=)}O\nHDEȜ|`Y*>[~ jHMץ\. Zs\R߿}'r<7>棂 -P~d30pXQZFhp ; .qX FmB6Z~F 27 6Q%tcCL3ϥZ:m /la*Ax8}lPMG?!q$G_-l.M 2H,EGA2j40U py4Y9oT&Q#='F{~ƉQLx=c<Z-@Z|^!L0:sf *su7ܢS J{ _R1yãH\VŅmƴryR  [Yo(Ø}w/k1*&߳3R(5C)!OUϭ=7EU7*jEb/$=g#M 'h'14Wfn q.l\`* lf'+w2H0d(] F7F{<+͢VpfcQ_"򭅞ܳ&<7c?l~؉}<MXM{*);G";Bel(ȿDJn+tҊMibȄ,0$G=Aʹ;2Ҫ|ZCNBd@. a䷛hG]SP,ҴaŅĸ,v ^7&k6~ 2A{T06*YiV"< KwYZ$>[頉!Ix3&xЭĉ^  V{j6?Gj@Sw C>)Bk*:B HG(K،6ٶ9-t|g =ěU[ ݖZ{;mv ;Ћ_ˀpcW!G'](+NOwvRq7Ǩ5ER={2FMr<5?-Y~zF)['HٜV>?5v/S `^|t] dՅ@k&x }+"3Ӄ7:ޝ蕲9 e(\&LHn"7iэ9dбܓ򸈅H1訴ٜPD*KӤ^tIeMBu Qp0[jQҿ ܭޠߠQ`qns xrKk#'y W [B"cĸS+pvS-W:pS{BOS7)MlAl{`CU~*)SŨZı ғ}gsʛUj$7 #rt1%H.ӾV̵2]eᰇ,mn1WQD+g 2 7F &-S=}5=@8zVXZe\Vn*k[w?E7m 7`1&xVlܖZs>5X'<,Weڻ]GQuh".Q he59վUeV(ZYIZㅽwjSF@Þ !8bp\A&X6v %8!UqǿnNGaU2X)Z(ig6;*o*|?`uuWL痃 pm^nm:M&gJ Y1*oNۻai #)7z ]ۣ1l@{drn&i{\Ig⿼}:@b!Dܨ۫6 kH7:޽SvQ9(K)PU[D5]|*թA[+svdy𖦢YlDUSf;keԻde08 'g O $@*[N @6O)SԜcEck1 yt?F]! g-M {ޗ9>x=*(Ҽ˵6ŽNAi64| \_io=F>i, _AJqO֜ ϔ ojLG.e{ςEؼgN܎\-p4o(q<HS>띵~'=|W 5xc/[10+ssOPhZyZ xnȕÜVK.q0*'(wi=N#NrڇuSnbUN]f*3ҷ~6 (.W`me /1P }p !N@c4^ q%T_#sФTq;&l}|X9aCԙ4hFTj#c%8qU\IJ C"嵌Z$̅]Tsj'Ǽ&5t>:&a4I]&4E%2q̪P),krs5AK6"7OGR E%hZߺN?49ʌ\&ڷwGZ9ymLzZk0*AsyC&fVUGU1JB.8LKVypOp"yȷ-oIH9B}sSb(,s}g=T~+,Xس6&4W/ޫ>aEBJt.D+nTVȷlC#oY]$PGai172nCֹB17w[nInrPMHt(%Afo.H]U46M)DoaŠ2i8^^VXS_C}aQBp5j#ѣ -endstream endobj 179 0 obj << /Filter /FlateDecode /Length 21428 >> stream x}ێ\ّ{y>"1`xo/cXRCKlV5IHxQow}2OfeR, 4*%Og_bu_va]*nr#]$b_FەQ"qklwoo\ztwtv%]),c&o}TR?F[lZ?>$7l'O>fěNL)zftڊ'K(Uv~ї褥w|X}>o>/%M0&)f%XŢ. ?Ŵd qԩ\ưU_-f¬C\Av||vws<`3:eί^xwKQ.&^VuF0}x}cB'sZt.%)hZZx!7<0E`c"6`TUR$`k̋uA5ѽY?]VnX7TS+0,)F[kQ)#̋^VvPzp%6Pumtd 2P VA+k6 t bU6 rRp0S!jm'O킜mC/P3jji 5]8K`BӤ(!*jxjzK+DYu. C⺃Ee5,&(`TߠB-5FF4C+Q  vQT=%-Mf3Qo1Ie IIHWu&-Q_&rNt״C\%D/BŬn]JS*B^zi =Ou0.(ƉBryTxQaZ$ ۆ" FNe0eM]B4TQ^PXt06y\ClY;9G WQ9 i+v*LmԘzMWvEhMcy =JѼ^w f<$5iэ1*4Z6NkPW>ːreI.6̹c@i Wq2(zZ(CUפE7:Ru)fCwr{eЇ{8#eaCOWF&-Z)w^T#i!n56 |5"cQ.d^LT rRТxf jFPMQ|#˗0.%7S,vhN6%1M:B_q)d'6BYdYJumxpdpstWHm/nMDLrᩖ<ܑ K+Ma:BׄYhTNѬ+$k\+0(Dz!W MDqwp:).N}̸h#'|WmJgH]?1&Sq-fOTdžl/)oeeXiCc H&8 ^9vgp~J2LoMWTOT6q_}x]c]BNDԪ| 'ZTz K;qX[(dF21 Ty(jCBtvEԃ'K`<:AJfzRa#s0B*E;rPhBf?x-l"5MbF):Y땲 KYRI @ѫ)2G]| ѐB^t\0|3+pֳ^ AM63ĦpFBY&|H渦Or"r֭΄FjɫOz'9qbBsQ@扚BXP3 A*ƣ$BɑѲAxed5zWW: u WscBI@";E2cCd'P %86,2+G+0('ddr_j5hz5B)Dk`Sf3 &4#sxL_Ër'p%!O9xzW~"K_JuzDbqi]Cx'ӰۈQZDUN@X앵X pTԣDE8-za O..N f?G](C\\BaG0{='Lz'HźvX>6m,eXuM((,v 4;8LLzϹҠ[zLFJ1i#MWiVxX-_Qgp.5~ݝơ8қ)xDf^8%KyR<"^7M`΋!g%,U$R{L XXbWna('V5at)U09%@)-,ufM1x?#Z> -EfO$n* 6<2Q;G.0$BS@s3eW()(~ c($wXWsj8HrN+j,#iU[ޥdE+PDި6'jm5$Y{HWbܖ6KdTHIJ zLI ؍٧P5n&Gs*p} hfG<԰IфJ(,P <ПAxU02XirUP1'<Г9mTJ5E,~O5V.C9I֌ssdx SD[of9NH{Jf L no ITueZ)ЉP"KMaߠ:Y9QB1E0N'̖t Mc=R*ȵ YI% Y7܅T)zvH^1Neʦg*Lzpb?\I ,۳?ɃBVS +BNckAENp̶6"˦G/h)U+Ull6\2Fv-VanGNn0* rQP>PdNNJK;=ۂRK3tgu(y78<zuE5tkhX+ d͢yM-M[tGǜqvp-Ucн?|'/};,;Va(V6}nVAG{{vJ'nuӚcoU7MJo*d9|Wcf CrBCet ;>~}tqo N4Tcxn63j6vwZv>hϛs O$ aAC τO@y}h~}hP3ugŬ>&۠#U~L]v{LIaSktV[p}6"%P*Hm߼˪!NwQx94n_I7w1i$NAn*޼{cu׻[{| @cS$W?~iDW;Y>>Él=B5Zme7J6h5Яn2n) MO+$Ppf䠸8ũas0rZrFð,3zYRJ 9 m_Fxb^"竺3IL6p%tS0aMc,^4(3=0r|ʎq޺DF&6FgbUUg2c !WJ-'990ldL K;#S)!isM `e.#7̉LFT3 5xGa3–IffZf_t{QMu+ p$38$zCe#،U֚'q"If+[L!^!=VU*Cr@3MQä#L+43G' Ckg#ľf0[, QS#2X'†iKU8Ģ=wQ@DIJPbD.#O1!McyJZyҫ j\F1&},C}ؽ ¸f3*3zN_@9Y4($HkHLZypԓW7IuiIx%fqq0Tvf0塱II1R3[a&fή~0 s"OfPx8KΡ-) Z* [8+# #<ي"d9ތ7xc5)ںœ r:UB x(u2)zW̳0Vv=&_#ɮ>(99%TD@L+OPhSlӬ7<~02q551jLxͰe-uCB0ѽ5A%yPjj\irؓZUfˍ 6 5<@UԹ(6Qjs #'zgxgHC܉5kLx KƫALRmOů('#1EM5i5(H͈Nݤ04rқ[( ٕ-!q0b,C<Y⸤YO:u)5X5"oJ'ϡz_a,Ƒ: F(3EJh#$694?1( ,#4MaDgzZpsbPLN? 1.c$wDi60*!)!V9O@kC_tΏI 93-rP5JDi[Ǎ"$tb7))! ?\좜( ER0YjR`) WV l1<(Ai8e%ũ^CA:+'EBkp󤢶x"zAUE )T q9>P=]gy e^91o8gj;)讦qr"f #=[髸y8 L j!'m='s\ 8̓9STdݏKBvqjL )NÊUFb!7(ydxa2W )=LsA5 vLwl5xF}@OgILX}Ni^sfČB&x% 8$b>ї f<yY g O͆賳R5xC!_Hk㤎#5F췇˃_88 c錜@)^*(Dhg[Ҷ"cVlEp|Pb58 i&P5+)uiкsWDEVY+B0f'e(|M(9]Ò)ȝesp Or:4YiF,Xds\OqM`;+ԁFmPmkRB! Ք$[ం a6CJasZ2S(D!lj}욀0Э0Zk̕'/;pNr/mŴ-N0.^,EWaI Xcޛ>Rަ  G)sv-%y^DQl2g/&m>(,M&uJH.0I&ѱ(GlN%dpV-wE(8&*32Aˋ kKQth7c`fnNYN)E^-A9>\ppw!n\}+9c;R)F!#V}}2pX3*kNf1oAmAx\(|u SPU:#ӊqV7<9vt8XgiZY#DaZ/{5 `<(Ab>Ô)p[̼cvJNeN$qh&`zBXF*a Fpm OE,:-LћBR @7OHL{0_v-Th25]qt+!vQttvQAq:~p@ML~2W/?С Vx]VɮLf[)a)"u|@QNfDd)1TIk1(^ڤ׹꛹Et&%H_~Xfqzt, `cNh"X,S7PP-v*퀹اr6vPұ"\\9{t4 oh~;UWN^yx0دsatbj< FV=P^ep+&l $@In#Gq]l(@- Jg׀E_wwfQGW@GkUGg^ Nl+c'p*kMq0û-ZP!x0#>lO)^E\gtI&j2E Q]ڝ|E yPr+6$e*z7 SL2b `jv_!=mW֯m0OQ(k`P9eB]7lO{. g}] ڀ# A4mPW=i&ԄB_ǫ3+ kT+xF=_W^(ӣ]̡0ϝJ31^k P7bdP1R <k$ W 9G_,ysúModϽON]iW h:W1||@%y;ea ǰOs{ZD&rC>ފP4 Sc1;S@P}JQqWd!篡(9cP SdEx)DPO.D^S{3/j۹N5 `Ux•bfꌥXQ$N]_YEyK dz_]IO5ԚW]A ,qpBeX>pP8g!uJiİf<{B{&dh DZHbȸ%8K> LD'\(1 4TQQOPv ep f_=|o5{( `vW1M=_̦}|+bԥ2-vzDŽl酮ZJX1f0SBɊTWk@T-%ӻ* m\g~L(k 06)\;u"?AO\fmS$f@+v }&cWAѮ7!fV0p!OI'ܡRgP;]+2A#тBg@Z舛.R[C1qNAg9!'V*e?X,i=kjݯb RfYP*1#ڂu"zZ*KP x1$di'J3fv$05%qP,̈́5ce;pK9K4X5#r-. ! 24G W\h8BcBd@JG.*#sEZdj  +(ݛ. q-.<ԂB<EDA"` ^)코xtLƛMʬc OZќռInW5deQ"rZP-1.#UauM`c}dfoQḙ2WX# .5">Q@t<Ŵ(s , ~N,c`^ €KȐ:+ض`&a* Eћ.2ʖ<*ي)FHjD ?;[3Ż +`GHFGWjr'ƮKF]jFHse5HTe-E)91?tr On6)WO uqyu˦ְa"2Iv/q0WB~R@$vdeר M]W MwU@A^&F9+3BQ]0Dtx) &b,`+.T:KX#f XV][%^w3#WU2/ ݈I&<(jA!$;mF؋O&T @#sxņ Q31w%pZ10Y9q! #%Ɓ/9,!~]%Le^(^%TJL^A^BhPRx(`Vs$mԊB:)=Nm9'%YqQoytwƝLPłR(=32XB!0hcu f6(`'&fP\': %.X. d;jPF ,g6$Т2 8:A6WfL&03Xa5]]GV {d:oP6y!/yQ3VQJ^c_^+`FXW@AX-)"q(UlO0FIQ@ dba&Fr)iIQxXF p6+d`ILD,EQ>2@JQ[qt@ htV4( t4mn;CYI&~}Sw02MeFB7^xIO&SHhw|jdԐbDǧO6OI4OO 7τk#lצ  .#cп}Z򾬏Ͼ-q]a0?ق֧C yDC󓓧Qm}x_}, \)6pfWaO.+FDxn :|&0Αd7w=W33Jn^.L}$O9ytUytUy}<:y<:}܃9؇>{O}`>S (Hy#/G]rј XD XTKO'KMG1`AVۇӡCD^';TKl ilAAj V*!3#fqtx=F@"r(`g`P`\Y<O p BB0 8h=ӑxfvJ7UIx=EX++ 2ۅ ؛, J c? k%AQ NV _N s){r<%UC1Q W Ɏ4BNHT{49(V)d'EVywTvNY䲌ylpdb"ūvLX1+Gh?3-bAM("/erqrz)`.+u"Y( `7GyRfҹSP?7U`tHulDɪ0 f;6i륀{B4h*aI)S Xс+`E6Q<Ηh 8f\^& %'"f8d5ܞ" 0J&(`N*Vk'xI آxKFZ J4"KB0K,] *.".yAU58wrrq(EsՕf oW[< 54bJ*z3-C` ا-AxmI ³ɐ)iO 5ў잆NiIHZX k6ۜP8m Fnk]p`iBCd! e'cB J1@0uXH[dЍg Y<Z%!8ɮUy녘/ p@87Bj%~BEsbB&VN)K+5#DpLtX Jtbn ؇'d3b0OP&\1Z $ 4#0#dQ$tWNߔdK/tzPPL"Bg0SBɊTW"&ZJwURQ $pyXC4Y&tJ˜chu'N$3' XiFٳzG4Њ95g vݣ/؈ҰsPd | 8,ò0OJ֊ds p'n͹fA#jUQ))MQ3TT&T4XØ(-na.#C!z:VS"%NKrNMP3 (h9xz wɽ/q4 J 3T@xL4J `xרqx } '1¹(/572VJ@nJAD!Sg@6zјNӰsCTR6!?g3*ȉ21KK,<D*`,j(V2tVƉfׁgxݢ4]{&o有x (TnsybX#QŲxS;0ДQm)`$.C#g"E6i]OyixhK yUzFRf?7W,2t4P1#\4DRM^%PHBd}P,2:X{&HP )^N0@, ulc) *ar%05!zEybZlxN}$esf$UNEޅ!DVA(4$J 2E ZrĢ;^yū98z=ҿ8s!VP@AF9Vbנ1(Bd$0 Pp<[\@9CL]I(\*V LDf@aHH) >qKK_WF Sf622rWF$Wlɽ+W@W4"!( X{%p܆!IgnPNsebdIIV:ACgqg':@ z" `d P by](2 ؉Ɂ׉GF&+ {K"VKk"YQ : &!sNP4 VdX͇80EWבUbx$Y k)`[)MFfK^T ~ҩXz*W.W!* PAcn@ D[LsRPB"f+`+oX41Ѷ\JZR^obiAh*ƠJ-jE1XSze0KQ#RԖl7a*lRX=(vIS/ziܿ|4Q%>xeݓق}q !o}?'aspADŽ}v?oAؿ{vݽ"8u~ŴW|}Oqݧ߾?>_`0O_j PyO#^b8Q\#9뗯>?d/ B_=x7oh/'zʵ_ ua}AX6?|͏:}O\S7n1wGO|asE4G=; 75u+Q;^miכ ,q sB*׬WUnyMt# -+ 9EpFVA{ӈjʔUnp;}y"O}z. C{wa~DT˾f/}2|nG[' .D?ND2A:C`qGC'Ş@́?-ZyӔQ}!4H*Yq?n;jdM3Ecn{R'?X#|u~3Ѓ>j}\;۵oHXuĞH ^}Kǯ*xz#@!_/UPö# ت~wm5_ͱ0|_? `}?qztǭpIf߿Q6ǛwZ1W׿<]_׏`qً]>K !o?޽/#<w߼; ݇?` ~13ҚlsXC?~q~B?{|y׷8~!a 80"<[uz'r:O/w0ٶ0?3h#v,}U/'3){|bx*4F9én?Y>갉ԏ7^}7Twep&p+thaC$YNF47u{59a?oO:=["g.y@N{i>Ѐu{2`A|` }/¡5oO\ͮ]oOu_<ۓ@]8[￭8T.O'ݫv2l׈#8]_8E-]~l+`7Vߗ5.#m*ӾG*qaɗ&I-f}zo+q{^sq>U7|B6?ݪ*w<8; fF?.xTkfڍC/e:; {@Cʶb7l>.xϘF:f_pv{~+][Q۔U3H\w/v:?'K;$J3t}~GV7zSqU6kZu|7O8qEg݉߉2P&a<ޟ}56H} Qmߞts)>d{{zV0"vXW;!ioq F^Z}' ~#Hf~SW9X%eWE!oVؼgl^RK᧮RIE˂lMƹ@\?q'{8WZ2pר} n·a$t _=P.P|jR"zG'.{\Ķ ^uy|tzn-\=zB=_NG Cx?ݻ?⏿8K_H}~:/^XYfu5T3ZOu.:o}>*ψk| e_l*= z)!82W>"AcCA!<Ićㅜ57|qcX/=y$.GUq'ƐLezGt?7{Ek(a4J`;xnAnyaxJ14vyW>p2ryZ2P,' \t~G|8U>O7ܿ|6nޓAkvr,ngr W'=;YYƅ&UyoǶdPyO0P`GԸPpW*kۍeTpS`=5p( ۹bO=<A"cU_ kQŻyj_W-^=ED/(/6#aѹy<ڴ"6p-,Sue3OG[5=Bd~FFco'i\Ҋ||7k9{/* (RL6oI7޽u5΃Ml6M| W=gSFSmu6]mz?1cPi bnMOn"vǽӯ{9Slz֥"endstream endobj 180 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 441 >> stream xcd`ab`dddu 1T~H3a!.k7s7Bߣ``fd-lp/,L(QHT04Q020TpM-LNSM,HM,rr3SK*4l2JJ s4u3K2RSRSJsS@.%E )Ey LF B cyls?Eu%%tsd/>}tǟi:rYl[vG[:(`阾Ad]xW}O=k3O9vwnEmj`լ#V\9dO7Nj6N~-V]$Cmwwfnnl|e ~8?u߉p]b1ù|< gendstream endobj 181 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 440 >> stream xRCMR7$,  ZUQmqCopyright (c) 1997, 2009 American Mathematical Society (), with Reserved Font Name CMR7.CMR7Computer Modern12Q͋oKL0bg͋§j~'eg #e'͋JiuP~>}L讧Ǻɋ !74/XWϡ=:4MFkgo0wCna  7 ڛ !endstream endobj 182 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2769 >> stream xVyTSW!TJ|#hVELTMR,_NDdH DQ0Uk֥9Z>yX̙:睓rrsww7 7m[xev}э-p0䃧*}PxO&<4=/XHNLRϋ$((pŋWIĊeX侤,yo$)i-Z0FPH$mtb8L#p3X&IS) MxBJt,MHWfeNjCN,XH[6"Nb5L|@C"B5Zb=XN 6̈́1Cp'ʈtn|+ HLYw ^>&๎yzTVv/L 7t2RTxv8?ds\H>tvv(BPn3C]ҰVCDl%3gjh!셧`ǯ H`9!ʒvLqCtƣMǎ[Q8Gۣa+!TQ(Np'Z`e\ Tsc>zIj+Pgz!a>yNp%LBOx9ꔂvٚw8V5 U$ҕIs@qniIwo,R~7$3 Pf{Cm˗ouOY <>(4yVV=#]!7(!Z{`cZy.g/fNqT~be JDn+Oz(SqwF7hB'g׉q_4@I4gҎh{c C#,@![+,8k%"U#d?wA7t>wXvpuF:14%5A(.Eoψ=4jX0>ݨEsxA<}~=4g 생ע씜A蠼ѧ#Do[y}|ӈ"|ѢjȯfrY95M΄Wg2|#2$pc(#+oF-b =z1o2ڧא7C!ӄP#KXQj?xQ>~zmIHc11ݪRUi4ld9]>O^F?4T>xu+^Y G[I$m8b.oi"dlJx)%9"LꝝҷJzÙuC~Ѝ>Wf409p&^>8H,hU'Ærxp 2A uz44ɠĥ ~cG#gC"8XWlnꔃxe8&;74z6NBhÆ_t8su+2ܺfg& 8apK5 K,yeyI2ҽqs&z, ȁ u|<{0*B7|-> lЫ|N_P<ک{͹Uggt8 8̲i eһ㒲ڴ(a46GE R%ڒ׮!Asw{юF4=]*mLw8"*H <kendstream endobj 183 0 obj << /Filter /FlateDecode /Length 7137 >> stream x]Ys$q~#&D*|eu(\>,X8V{gV5`>8:22q3On3ˣۣys~kn{-ƹ7^ѥnS46Kw̓g۾@ r^!pnɕCx5H䪧><7^s}- }kXBl-N>lx}f2ɥ58Cny@%Ϯi ݵY[}OcWlhQcs1yʮ?Qp~*)<;uxg\ۜe0N4.qJ8P*&k9diAXzi"]W.l_lvzg09qq1;Ofx5+vYlO, l3 ˺ہ}Rؠ Z>{T;>1bwʨڜ+EZSI[}/B^ןOykk.`W|~c>IYq7 =_4i5ϣU]ҬBywM_# .5_1_vhs l1p@|u | uqDBU5/7zª0V|a7V5jh~us !-^;0 D S]OU/Χߢi Ҫ*<|~m'a)|9VkoyxE ٛk?D<%X1=WgND"5*HHzE`vjv]P@v!CpU ykcTw79L};̿Qga5/͏u8Rm+`@fHǰ?@` H ^1nCĢ1bPĴr?9;Xޥ& -^JSUHHSxX]&8WBCٸ 즸á [= }yo(^œ6'.ѭn${mZHMm+xg7a'&+MH*gf>%Fd!1"sp1!ф| wc HD_SZQvچ8 ų7Zpi_SLڐ|qRA~?\{N&̔5o~WU=MFՇ[| vR3NC>s@Q/L]z^|8V !7NibT>d%{%XQop>`>kv{\^aiHد \lp]?wԺv~a_ ?y87f8Nt`#%P!m['R'*[P/mQǃeQk'ךކ4%&:hҽ^C9,RO׊KC.nu 8}pC@ɺp^܍u[ NYښI*T밺vSc׾IaMw-D`HwZdfjr;6ւQbPBkdL2:O@ Yr0yLzOϻµ`)/)릶F~`gaZ[;HQo!ty`I`fwWb'Shs\Iwˆ+aZ)gv~Dܸg,VHyRwk<'% @k)Cyѳn;$NVKDW35̽iUu}t"åqS0exNݔ2~罆'ܐ!N;3_MTs>P9FnVWqz߿t泭^gݛhX ݽ}`z\VTaN׮j/]]IlAX-n/x'|\\xze S~9޺'?n. ˀ.0) ?g=˫MwDa @ RmŞr懛7o/.˚rnٞ{|{q}u~q&C"E;Sn_OsZ勻7?kO}~~܈{{ܜ>!awz/Jf# n՝Lr7gW2;Pg}گޜ9;^Sc>AE[J~K >Z=wRS\4fq Wo[qޏ A!g'gSӽ X7來3X,Kz~/}u}skTۑ߾C}6wǕۨE] KF . 3?}…7F/_]gLti]( MesshbC6CO L bB^C<K[Z7\}M 3ܐ&8Ajd"]TF4Zg֥!Բ! ~H="n % FDKC`tq<א>D8BB(sj34- ȷMZ< ?sglqqhu=;#!Y̊:{imHo5ÌiQɶRĴڙ}ou_ j*)b1sir0^z!fH&퉇a'}p۞d' ̞ەV`f/q~ C+'m+FV< qbC "Epn74#? [g]ZW~(&Tq}MUփ>[y@0*)A )80\oyqgrÛ@F禿>{7gWwظ!xm)ϑ]EW lUjHM]) vV=z?3 x3#3hztㄐ d<$BJ bJV`y Mq]Z]Hmkۿt ]q/"| B3.=u1:XmH6ց8AcDBbczcqlc@(fX X"B7o7˃KWڕwR$Ay!VETyaP^@8FU"Fʋ9'V^rDyU^*/"Dy */".[Ž !ʋ{U^܋`ulz>Xw)F ]Dȯ`@I )ZU&B?ZgikiIF|*-b&MutfXah?0rt,~@b@iK8 dD"2^:qv433Rof$T6̴ޑZ8B83&b3"d)rO&Y3$Y:dU<$&IV3$YO!BNgp<8]OW!o q QgznKv(NaۡX|Ån&t;p!;|u;̴%lvi+rnP—P4vvڡxnJ0:;sahiڱԂa,fiJ Q Җ5F !h`, k qmJJ8AM:J1^Fu1NPD>fLT'lu{] dFcF7:!w:V^nutd ݰِ` 1jvc dP0&ۍwaR;ިo7=BҔYQz-j@1vc\"-E ܞEyV/:"5%~%uGJUԍfOi:q!Puu,GפGkq.鱿Sz8e r𜦰4qPBy'k7 v׀$Y w H~]g5p#w @𑽵KS1ݨ$md5 FC#qQqXFQ/}4F#Cr?SF#(l]xc> bl'P)vl]vL"FcǠ3b3jcېV*Ǝ})Ǻ͙ ٣S ٯ!j,a_`%C nv4Юd~l /"r2dY yMAy=|>cۯWʩZ>4_.˕Z+:Z^F7魤h[uĴ⢹iiEsJ辶U+PZpa ^'8s*3eO)t7kٔ'6٨S]TW~+?ՕOu姺S]|TW~+?ՕOu姺S]S]mɿ1brJ`Q񛳣WY?~|Uo ly*l8 rƛB{ A.z)x *ݷGE,n^:x <l:*+}bUs*ЮhH+G4yDcw?&DƮm_1&HvG4pP63+>1`ލ?_,"tR=i_B<3ͬ R9bV-`lh a08ZUoh.jX5/p$aI#0m|j,H!^AX5@OPj4#"8D$sj .95@(WN!rj )pjURBjxrD IT$TkPq<%éL6H|L'4e©RZ.ZC)ZCb85@*©5$fC5dIT TuNTkHTĵJjK!R- `+5R Ҿ՘IP13Zi©`8bܞ95HfN =8#hWJ1ʨ8F#c!z#ZcCmV}ꪬph]WC*5mչk  eoURhZW]UMuU94UrhʡjE]uU媫ZkV]V2UUBUU MUU)4UUDUA-H@K  \e),.~FLi<3?Nxh&\Hif) ;Ό8 E~+?0TJtY XZLU1ˀyӹ!wbt2+)rOJ\mg&WbJL\3+1wfr%LT%\sgFz^tg#8~^#:=/ԷtOmPn̟u#dk7F1B C0F1Bό2}f#cLJލ#b#daGف#1>Fȇ1Bbό {MȳL@bϙFO,RJ{ZcĔ *j'bJN40)Ő(s '6^vDL<r_hjtG'd}K&=od}W&]e*sdʑ*Grdʑ*G&"L[)2J(E& *aajdJVLud [u!LYB?VLd;?&c;?&c;?c⏕w1qǝw1qǝksc;7&c⎕o1Ɲo1Nvzmcbn'v;9&ٱfԘo|;5&۩11NvjL̷Scl̘og~;3&ۙ1ΌvbLcbco~;/&y1=o_Z/󼅸~ەV5H]۴R¶Pӆڦ"EsH),[T6X muO=uNmn+pz}L/HHya 5.`R '42ܭ҄4̽{Y UjE 8Psp'~ g{ۨ_;^hjͫpw˶w ߖC2yh )_j:&ywU7gF0QJ{? "˸97rßˠg9! LEǿثpwvdP|k,&uqa8 _>AeW2% H?yB{YÏ+"/:j{*ʛ[޾jc%f968~Ȯl_~tt|9x?Z)*nR;kas a{`JgE3'yK//ZR O,?%eendstream endobj 184 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1357 >> stream x{LSwphi\0j|L-CS-@o[^-hP*4>RE1%n31f)s[6?V69I|?߃c.x/k&M٤e+ -Q?r2)*|=*x8^ɘ+UZ.iDi[D;22vm}{(B(D%DnERDÈ4mjjjK*Υ+}[jH,9'QWKN)ђ 虾g~eJ#Q%jaT&cXv{;eao`b#HM ȝY M6*9Rk77Xj$]~Eq)+_$}̈.Sds\\mDs[F d|ͿgQjp-PJ*U[@=3ZM.SP}H B vi!C Q_2MSPs0/ q]OK}0gW?1F(5=4q՛Mj.zQy_|j)}aBmNwr8MF\'Aaqu|{ IҲ|cGqhy,zIVeգ3SS_6ͦ:v\gwBoBd^r!X]^_)@vtSפ=D밗kkF2J~tϷ/ ]endstream endobj 185 0 obj << /Filter /FlateDecode /Length 4098 >> stream x\Yo$~G m9_ā c~!KC>U$fό80`zbE6g-3'z5~ޭߜܶk5?OIV*9?[~nɂs[͛,Xw5[|V}H/Yx/dpV֛l䗳#6V(l ^Vl6k~C_8SZGMt=cZf&m+?6k͏o'? kL:de &%s,714&P@]&aKr% [ㄋf`s mxF¦k߭m쫟5 t` |V`Y_<~:o7yKDòPuadu"V! 3Ouf>| ?5F[1~+2%aa𸼼,iXv1ca-#o.׭lv5NߟIOM|8G:aJ b =q7`+0Idț4MG7Ļ1_g>:kӂtNƯ(tZ項4k#Z10r4BxhZ3uL<.=+:@ONG٨0$/3Gl0J.RT#WuXV:0 :s,6pP`Cjp'CE!kLUG b ĚF G_#)8N=}W5#PPD&@)3(؎b{C)sdi,S|Yg.ӦRټ%ܽ` ً<$\\NIX CQpI;gn}e){AecbCs(%%$q㴠KBdkh{/!)nM&A {RFiD"xߛJ}8! UL蘷Nu,{Ac2uAB((pJ2)c:uՉXMeB%`iD#X Ϳ2߇UnjPOh"Hlw% 6" ׆ӿ亯aX>@h[¡0diA lE,J']3H[E 4cLlhӌ `5'ipt)oB!i_N AjQXs uF9M7ȉ^.aPoqƹL YT&<wd<ץRAA$5"/c ;^?%q=,z ZO`EN\AR ֞"$ ʪ ]CaTDE&''0sULPCfTj6Bu{H XQarԗ9&J|k@"XƧr~(e)_UU^NI=m7Z1&T ?>ꃇU[`eŒ1PWI_dGtO U;TG1*Rc.IN?-;KDO8 ƿPҬÄ Gck^?PiAܲL{,hM G,4> sS(. zC׌+ 9 Jt@+̋fw8r͸*BOiMd06x?R}G[Mfax`nK'B10^pҲ¢.>/bb8_QzZ֝iBgzv0NmqA* V׶܂gydT{ Ҁq ӸcLH5ѩrJRe)E&QNFӾnǺj 䘽 |9(qJFS[O'MDY5\<64-bW8`=R8I/NPqi UtbRS)RP ieZ:W"=lZ\t5Eȴёw W;vv) ɪsptی@C[7/h3pB+mF m9o%vQr 5nt˿CjqMUA4C>6i1 KFb[8+< @*5(!,$%`QQ+QʧxC9XP~|;uRXX76Ib$ ?H|:>8$ncE̋`jGzX'Orwڅ40܄Z'z {xgJz96f].ǶH_r/o$s\os}Mea'N\CpD7V!࿍jw㽎JDNgSյVjƾRb,zzB 2pi84HJKh6x/6Kjthrlc];I*]_1Cpb^V5ՍL<x,/B9p߱|!P5L8ô^?'4R/+.s3IřMIg΂ O$\Gm5ֈTQz;b7782bԅxͺghúY1VֿqW3b,@ݑ !M1z]DR1Nv7.,\mչ U1j kOkU|m&e`/}!whJe-=cQZH o1/=t>2H={"|eP ذ#z=}=cGy%7n]:nZWQ9Y$n)RrAO^T…MS al}Ԇ7c>XVǪ@M;)b&CGexBg'*c*<u}S0LԂO8)],T vt"n-^m_ }n'=OeHcJLI<NwA+Pci 6b>t%U7xMgОbe${{]]Btn ?#15%:J }r[ |\z(-x5>Ҹ&ͥz*٣g^gxN92/)ZIendstream endobj 186 0 obj << /Filter /FlateDecode /Length 72757 >> stream x̽_%Ǖև1~pA?qH +[D< H@7 E=;Z{筪{Nw usVeܙ3->^/)o~|yO"uEOR?i|O=[/^ŗ1zps>^e=Ӝ)/s>w_WwO-Woׯ~sb\r~$W N[bK~ğcLmviԬ5᫿RO_zk# ;|Yԣ!X_}2$#4קX^ vnikgmo}[ls,!緿s;7^߯m?r^Ź^lO=tkO?Jo9oy[_?77w}S)b,ݬҴR<?;\Nos]|zKVƌ9r)k Tx_WCn?u|/|8GoӏxxtEC?\edU{ƾylakG"TώdV+&[~{x%Ŭ9V/KXӗ1rC~"t\ŮOxrm^?XS?r<|> *W%O*53.o.+˥YOpY.g=hB/U9,vɻ87 ~SOjoJn[Ի]xTB,ic-Dg?^g/K*н/@m?;9ɿ(d9[k׷_^O8nc:췇;w<ׂmau.*WG=.WsڧU&\p v˱| vk؃e6 bǸ[Nٸ[(ve,/\?x#H)7]G>[}᥾v?m=>· A?a+:-?ΟlZ(WѽͰb˹Z il-Û|~CMo훟]W#R?ڟF'|&Ta]&w~w~o_>yO>}|xݻ>O߽Wh0mt>?+g&~͛7eS~m}{W+K{_|ם~_=cճ@n?}z`ahR?߿_[a]~mŦKչ\P{J;mǎw{`\Z`n{ />G_th{z:4w5w=xIXww="Fx{yݗ?@ض֜Sg@g{Gݖ{^_.=\mGt?+KPf>}Rjt07 lVnb56N0,G(/mQkiŸH[JQ_ZyPY>q!z{yd/ן\1jw.)@^tQE(ΐƲcD|H?^+{=P6*5!Վ=o'YU+|X~wxϫKm"v'Rpq~0S^~ uJ\?6Rq@ ̗y\˩ zoK>QG;\U}TNȷ0 hfIQwy]ay%}to? <7:Ao9$+z$Gl;\܋y,֗!E:c?h{;kDzn"]KE~T;^8dT0>~[oۣQ8VEd=W=Ut'9X^t[?OJynq@9l6X?ú2qݢj\&߫C~?|KVe($P&W8tϓJϽϏW/*SsAöE74%{4q2ٻ=>[{<ÝCc')>=Ѽy"1δ/2w\;ϭybvܯMZox˩f/ ]w[{''A.tf?=8ޥk\1MI)J̧ۭWMb 3RjH7,,c(Nމh5ѷWcA ͘x~sw-4?npG+c>,uwJh?E~g/)"SG({hVdy< )/E¼=wI>q$+Yw߭Ss_=w矹^{ tO{]Ǯ\||Du}UQ,~jcw| :Np&>rhcc@wuc9/w揾sֽw4i^?x:x5f$25rKEz1YDXR~E;qP29zNJq/ACuޙ?tiNiT~;9&7_=9OGqg$y1hC9k[#ޟ| a@s<캕x쥞Y/O#uz-{NχML3T_09GFx]URv#9NܹOGaأ3jX9~/|^V>ξ݈r4)*X6i .L@~ԘX~9tϷv0|5w|Dlrxw.wr:}MXxvwYr%ǠNe1*ES#vch cGW.҇/SVbhRl`?UdUKZ>N7[;]0P| 2--9<Eq=9r[_Q=}Myʲ%.yѹWF+̟_b5N!!G釖2Hv[M͙Mfi\,5ScSEXu)U͹K0oe}oG.2U])f>Jqݝ>&@}*mω*h<9NNw~g &l_wke޻׉ch~\<{}Z:B͏$Je%gG\A }k ;ykv,{3RJUb~Xc%u_m}aSUOOcޭ96\lr1;o|y;Օۏ=|\E&#k\WMڪA^cս/gjwYCߗM~\pRBw!=JHuIфRr4wBcu3'w;_복,4h_0:?3K`>%]G=O$DZo߯gK )NsE=oMzgǫrdrr K<^p 񪜱m*'ǫVs|-**'ǫ.}PpǼ~O+RSmZ ևƀOkIT N>__c*k|["i˫Xorj{ UNNW!_pUuW9]5VhX*#ǫ:>g)/#/VSǞDDAogiލfT[;XVIJii/ȱvXߋRN|"o\o_򒼞%˵f)ǟ/pkOyգ;x͇>x+)qBUTVc˳=j~Ėj).=\ށfun ]]w`Wu U',g*E K/l+:XDX?*Jh_1ҡWt9<Kv"ª.ZuXL_d5gjjh;7J qMXnn^]a3Xq ';vijxNκ/Ꮶ4W'<:ZVDjtY 8# F]%9'H0F\ R&}D^yZ Hr8N2rL $-ѾR󈛱k5_2|hSx$d$'ڮh)zAzd whLq +%Zj"D_ܗD:j%'X6 Tf5+ZIq"7~B8QMYdkbYjEv;Z]+`FaT>ShF[ ]R1Hu^7\8a,VQc:;H2Z_f="u@Zɰt#FA`>;@k11nz AP}8@ކ׿U[q z=Er/P/E^PbS7i^ab,cѣ~*@Y w[EYZ ܋@6;A˨-ݖXHOD:VQGZD[[I[cu2jykV2w.Y !UdX7[ޕmRx ,*cvPi@Q^[Pݩ̣[I J 0 ^$[(Fd[0s=y (Z R\2xHx`)WS#WW7{&hj}/TKJ~PC!CKUy9 QEĉ/2+ 0ZW'q|v@(8Ȳa Y [@_l[YA-xJ7dimkzUϙ`/c٪TIN(!3K܎t%:AsΝ jP⢑)1ta,ȲgeY0ZeMؓ*Jwaf}RyMBI5:F(lwW CGiu>Μ"ÌǜpBC8Pڛ]38ڌ̚ő(m:W@q;&'?$J4hK)9Z 7w.Ft^Sý381ZM8v730/3֊!9Bi&3NhT-4^8+ٌB͍ 5HnU ׂo^z㌴JްHf~'|MʨWoAO*H4o+`U4oڐxo]˓"8\Įgw@Wz 5߳.CPJѦPlTj#hR{ݾ FhdE8B`w]viX.R;O^b(ܫ5عy]ۇG612_]c/ xFzKRI|bU4Y=!_(6N(9}MC#nZq0at ?!.Di"rѳUr7@tҚcn\+&"rIoi`MJOcf3#&{7,,#)9w@sBtJ0Brt}sjv¨Wr-CJQ/x%D)[ IP% &;GoA  Ti\UPrN("@xǛ$MizWyUop0NfHw5vuAi3j T X W@ݢ6EwYP!A58Wm$ !]1k{c[ A& a2*YcdC—tJxlRP4Jb#򴐡(p_1,bqZ`ԅ)POԠ7kEgthUu_9u;@Ӻe?WGKcDbo'@T>[{s:iIĜFI,DQ§Q~iU=ʚAG)L)*b3*b> yXVlWhYu_,FtC C$QXTCR T>]ʣ3`<<(Ȫ/Bᱷ w) [5Q~V8RERtB1`d ^_mvM8:J6nVCGD@ih)f(pE&yU'T=X O A :H=L-#.$z hA:+*'Vݚك'Iɠ`N$dZ;T=> .ghUGN <$UafS$ۯN ]d5ƒ*ZXS0B}QMx Ĭ^,0Eჴ5e ??: Ln01/$9G0I5;CD.هPQˀS>~6ĊiU!h Gm"@(V9K+_ }W|$z&?N.&'\Mz Wn&{FD a1LZ9OR웇tGլ"b@{Ak̆S÷lW$བ,{s ]I4"{*Qdb%I uV0M jAUZmoZt8=rHbw"ݣ3^CL{py0\E!/A]XbT5 ֶ,ᛏumX]WG= 992WH<&gufe)ʷf,u/BݫgU{y ELW) |>{-6BvT G눦|@d&)$F#>-"+6i>Q!benTS~{Q|hE]ʗ ZkZ Wl0 RS—hy) ͫjO—EUX39s bM圂`3+*O+𘒎NLko)ĜXdvjVɔ=G4[5{ByZ *Oz܆ =Q)>pi[ $;aؕ}>ܬPܬԅ#)4+Շg!HsurPAOk*D'c&IghQ9 `{ Ҹ[]JwϏoDIJB L[%Z V=ZYk كS$JvϳfhaV'N@({^NSɦR.0]a%UOԐ2Dt$"m*ٓgX̚R"!1q1EQCQhktF^іLT={KSajfl)ʞi@ɞXU}`SYČɞl zId.j3ɞdF yɒݧaA${Pr^Cg (E) ,RRC&ɫ.2섢5A(z^}"2-l@e(iA-JK MG# rFG*nEio˔'[eZjު5 $ An*Wm<)!㷆yʴ=b'/굚>"գ x$Vk3=yU&؄lc KB%O`їD.zUM>ךSA7[]{T`tS%H/Vf*: Te=L {?T=ykʴQ\2 I3 nR=⡸My Ռ 31JK dn $ 6:$́l<5uN$nz1=AjbnkĊkW͑tS; (S3usUdg,$[-@W B6¡MȗP#MVM 56MF'4"I<:'$OasLR1"_ɐye-TޯO-H\K$Pn`ytFހr''8OܾF'ZM2NYF [~ rN?:T]臩SąNmH d@oNbAIz`r H@pL=e#z9_e"s>IOZy ԗ `)Hh$YC@`5zsFHb 횩IHhSAТ}oy#$SQDR @N&R!p*Ȑ Ӱoқ' *Iat&> ̭Pn4fT,uy!LJ;:%ld[ʉ h=1'Mf# j:: -Ğ) ְ:d 5SRA5ff~{x" XeHFxwD_&o&xCZlAb0R%g1t^nà ի3J' 6B$v0w QE D-"]E Ȓ;XF 1a?]%7v܄r#QHi9 ֔3MNh?E:vf%2T G-ɛm@qwj;b 0dew"9+ 9πj|qe:l:QqDmFuXyb y+Z+QAR#TV+W  $9Jv[$BH\[ ]A"$ Ou Լъ4/D"1$ `Hk< )ϠKQc2*HW#HBݦDGޜ & .5ZF4O $1^Y{6 @LHrtl41IbHU'T|Sń?;%cݛXb?AKKC)v{ Gx;~j88I5\ @@qLXў =dtdgK@bܤ 9@Z3!8/e,TQ4HLFvVOTgo3Hr1;.|dIR췍0d"*HΛt]]S-'zkgy%wA~wCr#;A ]#,LSr'/#@ pefN'']VEh$ɱc!++"#d9"R$zR'IV5@@tYlAbq,?i[%|R1B&g5"@ -L6NhظDNT^@Fp-H͛tY33"o2dW Le&荭QL-&s荸o1S*A뎡adJKD !1v#=Ka)v% U=Q"R&SV^P _bQԄIUFiN-1@xt&I`gPe7#P}m!lTD TSTGV}Oe:#5E]t*c@*՗iWM3OANR02:bᄪ]3Ii/H2w֘ 3Q (.M-J}'AKˑ'72Nd&W'.=M,jCOilR04>I v:3J2 G3I5cfI*pۤɪX5$LgEza-PςM(tivQ]]p9ۤ*ػ̋X]7qzᚁ[34M`(+i6f\ɐ 984?qxY i[g'Pi,rq30$G0¬S+ Ps~g@ߡZFp:+@ج%y3w7 @+fxsȭ eds MV6K2cK-^jg$VF琕ѩ\&0دw)~"UV6IaU| -Sw#S/,x2IŋOUY< %>K.I)rD,.)KKdZm;U)"TKEy؄*KF&ɐyITT>2X;v$I .9J6G )Kp)+Р.cFbsDS[ UzS*U:Tp<(a _ZZVߛڔ ċvM1' +1*`0 h",S'鲲\eE0fs6-G"ac~1B^b]+8H8n@ ߶,S·]@ LK͉ Ut&QʣO1AbSBS5eVdk&(R-*IvMe{Z%"=M#+2Ya:/j:$y9 R=v=Bڂ$OH(.= ċdK/>g#YyYaGP8ȣyY|!FuʦA,[9f&Yf$^)ɪ'2ej"&S^C Pw[뒐?dOB٣")+5&;t&MKH @Brf&Py'2RyYFr ɣTDz$eE0m|nMF'QyOȤ-Ry'RzXBnj@ ڇkMJbɐUL7"MAT<_7|-6G}A4J2ʉh[ZwNƏG,HLa?IڄzެM 郤c"OdJ ({ a5AWdSN1%z[HlqlZnWT@{)5 lY'R4=!+FxI4)3sJJl~$?+Re%hUToY*xN ^mVc,+GE k!{^GwA%>L0C?lAhFX\H4^V@r%)1Vk JԸɽʴ&ۮ24D KfeZrB.mJg҃$CCdEgV HIU٥'^,erNA#_%>GGIb$3i}$@.}H5 +C R=B̪) i}$iPػY]dG'2qMevT`[2(aGI2DV ^DC!"R<CH"(.3Iఽ<O+20ARfX72H4M&H}y!AdU@ܤjlEʝ+n V9";$J!$nB@ $<)T( %P>Si@.L XIF1I|IF iJH<& FI(`7I)mi1?If) j)$ԺzEvX9(d* *LĮ^u@cSD WufU83X2H_(cd*)kJJQ' ͲIBF &Pl {Fb&ďhG6)8H?`Hr'qIؔr'Sй`J"'I..iH^#gP72{6)y5"sd<9yJ,Ń51럫]_wꐙ2=X&îI|@:wjyy.++`Qvt+,NFQF^ ؟+@ $Yڙ/j#78a)WJKؙ4댎6:y%`L5Dv0WeUi"Y-5w 5%x vLaUZxUV)O=K74Q`a`dckQ]ҊH^XIMBnhPQ ?I5i,$J IW l@DM%mM2i".2*Lо!%xUBHo"#ɐU܎L&}Q nԹ…ؓN>$e7%(]J`HN3c@nc6WFx՞ @NuWeN xs;i*[( 2gHC}2h$zU' S*8Š>sPu%$) $ەL86SWdt-z[sB{,LYY#Wq&QzWw$<"I yLYo@H)1͇Dyu$IRe,Nỳ1ׂD({q"`!S%1S\ ,'2eegY)3| +%G|0kT/x:Pli)1 <΁# &+sI89XlF <@ee V-̬w#GJL&1uyC#)=YUJ:y$q;$tY]?PLSp՟$xS(x4. ,+% q7U?*+JH}P)R@M_N0ĝRiR2Dx{ +'["~BU @s+SAp& }lRe嵹rW` /9d ^}Ww. %݂4m[H:r2ݢ4r$Ԕ̺ 5n04jܶhEٸ!+ IQ b'ReH?,/ )].,䬟R\xlGЫ/pn/cDV.vK}z-0H!tcNDG@ճ%zz?4ϻeM,ͳ%%KHͳ% ʾOa!@̲z?DOޏ.ӮܢJޏ)Ӯ4?`[]ڟf$Jh9 "Sh)$=z=O%]Z<|r.Z<ȾPJܫJKTӉ= !îsJkT FUq623XX4 NuFAz!SVJ:L8귬(+<TVJNY  6jq(G7JWfC_I;E,UZ~J#~<&v-ɷJY{XơԹxRzAV-n/TKռyV6(fr&SVgm_|$E٠xcia͙U}F]HF:$哥-PCR>mPX7iLOZAS~UO6L8GKL8H%t$+Fe)yN*  z̩(Ƀ7Y_%hgun-P7XڲhUh?LO d宩v #J\9%b]d3QӈP欚A#WS"(@&ܗ s)+KU:Sq2t$kޤQ bMyt>y Yk'=A5%bYYP"(g(\N^s(b.+{H M,yIVRrAop2oMB囧uѷC$7EV2lj${bZ%\)oy.Ǩ"D2Vdʂ~ opqnTYsÏl3Ƅ!r7e{aLѱ#ЩLI| уMeeɝE^Dc+^&n8 ?FЙ4YYVz@F=%b\N;2Bv4Y-f#I(prUWExLv%HA!Bv%I m@y2 "+KLEsEgdYi(g79LP(Cʗ2AϤb YA 2eekpr%ee@)_CrGS 6dn2eeAFehF v4Ka:(&zUbʪW7L~O$#j =$ճ{А5ed%OA~pq'OeR+{M'0e 3Q'=Ҧ:Bƅ?1h(mvK-pd@6z3Lu&W4cdac-(3za#Q'¤IoĂɈg@ܵu%"M\R@Ž2@$I`FLs`"(.gk-iNfq4'I؄Lq!o5dcl 9$t]9%\ `N9<9O8ᘒYpqetJ`pq(Wdd$q1n@F&u8ߘrW? @:O$2q Ik̍L#sYGgTVV 8H̯wb8ǘwG +# SHo1LxIf83*[/I-779^5S +#8Qed. diQed. d pFq%oH bQ@4=IE%8{9KH]#HFPK5 iOH88Y|&C'w DOh2dd:p@1D]N#k2I$ +22WsI`Y㉃~ɝ'z{-`l[BSrߜ`غM\L~e"88+]lej'6Z "x'pY݉YVnXp"Hx`R8[W ޏq>۬ܐPr鎷1uoX xvEwۘ b#5+xJྐྵ1sBl NNp$#č&'2~9%k"(q=Iݾnܞo>3B:-19_5Vl& 2rٻ=\3o{ Sb;sM9MN$R߶`b ϑ.q:="}}E#Cԣ*5=ݭѥot0Ľ)1o5 +2r:=[ǝI%Dl 9n.{$t~t;$/N 8XF #s UF~G+W`[ X\dS3UJfs87 h yMd.[Eh":/_]߸CĩI=$?!ICU qM:F~ Tҏ0J8з h|%MFRdE9$J~%$qhgbw8J F[ddkp~oy,L&5pz/4JcGl\3ޛedA q}ﭲ2{!4YIVv`9" 1XT6υJ8| 2dekq~o-y%]ɴkJ` q\or*&#wOXpoUT_"E8"w`X|.ĿKn>|LBFj^LԮ[Cysj $[πɐ ڤL'2$eۮin~ZlU5@oGЂԴ f_8~$|&Py>ϤHຽeSX;τA[|Maq!Cy $^&SgJ]aD7v&CoQ{'Bv=KN J܃v)^A{ٗv5[2t}iW/ ];ؒ㥟&m$|nvD  Ix;zO,v#K/6[0әT 촓pjAˎ.v2t{1%s^u|"ƕtYY=&G;Ao:ϤJb?OluMr;4r}IK<<DXV›ӕ Yk)e :H&UVm;'H,8|$S\ Ru0d_R%y03x!y~03/HZÛddAf:)bt&\~bG5I8x7+uo8x'I8g7+O,I8y IO" AEw&CL/$1w#y&\bIA: g¬ SV3c EB +A[Pԙ=Nb>3w|4=2 JG(+ = wnKZcxK:uHRee~s5Ҵ% T@oAРc;n$K)ҹɻ^I9q$/w#1Gw̑ZdJVw۝GIlȐ-yEV;1] 5;RLJHBU cK~#I-$Ea#oHF=)U--yhs`6F(hq\, yʄU>_8iֽrm@OW&/Nέr?]<j}"NMu8'73QovͭHsΤHϼ=w+jT)z)<n?ݛ+wf0K )#%g+iEDBԖV[sMVGa{e,^ITYEHeK s*ܣIy?)qRa^ &N|H&sE-H䫝m%Q.byelA4w$9w-gBk'do9ZS { J#LTYyјme.#o&ڔq7 My$LYyЕWh?#87jf֠+Ð#ؗ$*9bMؤzWa ۋ!yD)Viȋ Ė^r&< =`N!v5wSX@τAly9e `'[ R$>J+hy㙥 Y+<)+ƓyH 4gdUrajr>d<:^VO'I헸;/M&27p1\A펦ܛ*Pi[`p[sA=v^X?č+Uù}M69ч"z̤C0i{*my,NV z Oйn Pg5\ZŃfLR sG/㐬byĵU:<<I0`Sy8 xNM+ IL'[YG#foe:,#7Ҫݙ.Juu$HULҪ IGA\Zѻʐّ]E𚙹*vYckS*2w_ h3'z~M4/M\EUUC׽a: 5Y`0"&kqɑy`oج"Ʉ=40Ge3H9[݈]"!96m]" D &`''V )XyN#RiLGW$[ľbV$ۏRy/Ո~s*Sm@nЋp$nqEtd "m`K>#5)~\jX|7]4BJO,@-څɈ pθ"ᢪȕ븽qtD,.9ycI9O,:1+bI]=3@8/CEE"crP;;_j,ϭR{b:G"6*eMHšr _?bIQܺEz_#1ܹ*b##wG EEW%OD)@G\s3Cj'P}֐>KQ{T`T-0bD7hh[.LF12)Rxy O+t,16ܹXq9Zöy愒cȐikAqOj@QJy0OJ/boHHl<1v %쀒JpF v4 J']jFtbw~ԊooH,]ݑP_cV Z#FŖ(O zV Ikn'F Q܇kAoT]RT#Nc{ҥ1BK7a,]LT&&ߚA?(&)0$m.5b`FA ^.8@Lq+HkL9dA(Ds/ w>Jo,;{LɝN$S,fR#ExPĄ 8[^s@7EuUx*OS*~kwH [NHA{C|*YqUuXV@rd@z 9bt2 ^eu- hISB?2xNd/D9MUoqDVN#:V<&v@86r:9=ZڙOǿN D5dÃ_:D(7!.CΏc^8S.$@{^_$yo$L+4_H%W.t`g4>[0/H@pú#Cg1 f1},n&8@tFG` eudg.n~#QjM}8wG|1CNNJuj>^2>''3'71c :};CF,s'/2ᬏri'm2=W%znW"{,ګ̪=wD)b!d?Vx^o9"Vd[kyF{p|0svDcy{Ų?2rBO۽;+g GҖw<|fm4G$='8̩J^{n{_l+2Kq{crQ~$)31{U1j d  b~Č.G1bVa6|omOжiW3i W 8쪩+SM#Ȱ5'I@{ )G<\Lv;/bp*`sjӜ-O',i'Fs{q\L8BDɗNEex,*#54S,4S,{>L$ϓiL$' 3r9PO_leO~V 'IrV^Iʡ&kx,=(}t3Б#I[w@ri|Eޡ io \io3~>UIgW!nԶܴ_H!8 9o=(n~jjJh[}lC[|✷x9OUK3Mqϭ,U Jķt«އ 2 ~Kd.-]lO/"%\QkZci n({;Y8d ^{5I;EʵH{]:?;ʪę舆A71i'gL(T09G%񧣣:c| b3/UC]{<2i}U]:GFN $hWO [QdgeW& YEqEe)o&O][l*|OsOsԋ"9(wxMqrhG(7 ?t(^kWQU m3V/cIGxi+Kz \Z/Czkkkم֯׮3V \jxJcY&#hBr'3I'IZGțzR 2tv7ͭе;-+ 눍=_-\={czR 2TN6#ek<ܕ :c'"-2c-iCoޔK65T5 pqû CòQT"'ɲ}=;xOKң7w?ô `xTH@liH?iX-:^%Y1I;8tqqK+^L#wlѭ~=*&$twi}~%\=<LiWV=bK2u3YTK?6B\eۑdd$ie39/.fr4:z%N'kdpKd"nY[y&%4|?xi 5$٣EdO&.͏$o} ecMX"=_["]]>,qdwRV EgŽ('#y i<'*3ޒGr9ƃ{G]K^䜛q/Uyx?ac|,|J3@hC}K=nbfOχLRh?u~#%pLўI\δ՗)N8zi"=רA5'҇YﰘEVUj?\`4-^NfWgvMiYՄߜlNX%| |VH~r@V2mf!mKDz,v]"I 8}/:͛Hdg;SM2ɯh\C|4C|683JaΏhTE o1UUT8ҟ쏶郫n&v-,-yJ;2q8PA M̡.d$с2ӋDyn~{{rGA$9;_ʭb/XמGi-)r;Rc s II-SB=]dZĒfK(T,:+N2oODOR*Q,sUZ84i4e/D.r!+Kmq)Sd %tmxR>Q^dd7x1 0VdkΪ.r^bܙ2pYw5S6{FP_{r5WJ] /D5JpwGC J7áPh &7+3:N5<ۇdPh$,}Ij+SP;+vEBkd<ָqw ^ EdIv*ӫ+M ˟PdzZ$tiL\iJpr$R|6|fboIwEwIUl"cýE<g-" %"kG Mݏ˼Xw2&2°\CSR$.bv?QXvgWʴTCRʝv׈+_ԥW.K֘(Kk,aj Kݽ^R%]_T-xxːt{J^z:S8YS|uOoKH՝p?,K u-Iaeݰ{B@xO@~n.z2ڣhjΤњgvawEzALJ\gm WD-IŎBa|owMn8{ƭDʡ!DCMr\w]z/?V.1ĥCk]|[P>w0WI2nPy — I@NbkI "=gJ,#zn&Yi_μ0JlCkV'?'RpRZ#HF,+Hs]LqG`ooJsj'??Ey\E@= +?/e>??=(Xbc<[czp۽7JRzY\@ h0'~e^VtևZrd=mԚ\@_}K"<[[%%=Oy?eMrϪp[OJJzlbnFHy+D̞ݪv$H{|Ǘ aPE I<Șֿ&48 MsG-hKDz7mEA$"=c<,*YzaP.jZx `dɔfޥ!~\Z4iϑե =#t|95 o|ؼw|8Tr;k2I?z..Qd1g IH*bv$&:N# i~2Ek{>J#&W- n2ƛHuHCzZ8+R&5hWU|yB/9NF/@2i0MJ4Srҳ‘!!ѡ\S+Tѳ>R hUd\G[j#Yi X41ZW!N^ߒ?LYJr?^-eAL͊væBCL Un|ib>0pI:Ƌ 1?btp6d^ccK_z91OQ?s.K)mVsQ)834`sGR I"'rGKW2-^m'+eoCD 6v E(HSEw }Mtȶ =i( ILHC+I}?R&T&Y8^T.X iVUBdU"ޗΞS7%e*XTBs1{!iejLRK4 ILJ@ 0IiZ \Uq[כUx KU:[@1 @lwcAՑH#i(Ƹ6ߪT6ҫ=S$Ib !笶&)Icz!U_[KaIczb>hҘؤ1\hqH0OfU%|KdzR~̋^y&Z.\u_VW"9LVrSj,sWl|yGU4RE 55$-/x! YF5$rɭiH󚋍Y UrICڊ);iW,9N`/GlW)' gΚVtQgN FO(3︝C7"/ <%=S+b}Z̮/9V(NKN=Ў\-yKN-)F[ʛI>$=ג'6-F:*O y[Vl'TΘdK4z)[Z8-H5Fllj#fߖjp {ȕBz-Ė/nR 7 <+p/{Sit#g -hfzV&(n(I{IdacY~<14kjyO2 GOMrpI7z!ֳܩ;1FHG1GeL[%DƋ$qRlCǑ`%푫hg@rJӓrK!"hݑUmvO?|VOd~i"%IG5T"yF.d$ /~ٟaP$_iv~\M%xnv:Q?Ѯ)OUӃZsw~e6U\jiz0w|4&_rBGxKN*d&[K"Z9[ o"{jOR49&\(9(9IB1sHtM& LIB۲dXqk_d_+.8u })K?z!rF#%\#'Ư՝S)ε/:2[|]"3'1)"=ӪKDz, cTxM)H(Nr7Jn$*!i5"= R^<*6k!Cr$#5skΌ!cF>ڹk IIϜ&Ⳝi˟|qOUxHzrQK$^ *6h@00%}#8Bw Ii 80eޞ$Ғr.~rGԪpEOh^'YiKQ"59g@: SSEAim@Fr, uyB+ZAڢbJ/ JiZTܿ c)XX3p`17W15"Mipd)օ-w jKs!CI")/ϖ4ܖT8,rRfRh[ڔ(|'IKlLFY镩sHGyah4ɦ()ׅGHyblYIب 3&a)L@T&OVH_d+HZ~壴4VeJ$#975o&Q7ᨨu=:xu:A]>CU &G?EA*j*t{pWSM[2?DN4q6!tB\N^HҔ^iZK7>!U"' /iKj+&[51.n'kxJ' 9T&ÿմnp#YiC:rsOs j8'Ҕ*ewiBZЭ͖[`{BF-/I{%;^d袴gM{}OGϒ߄3|Ve݁Qd/ғn=q KNsKRғdVz$$L[\Yґ>T&X>Β%#=nMHGz#iC6ᬽzp- ?@ꗫn9M-S)#=R[ӊ8DUL_@.>Yr~]&m֤#͍$#=cv&jIrcpx0H6q-&ixCfR~K*3m( 3L8$}yBqΑd3PEP#[~rp告r*#VӁ\FYr]5I1$y:BcȒLހyʗ8ME#  :B:]݃+򑐕EL)ga6E)ҋ"sEym D}qCj2q.9#xVv;^wM 0&9B%Ga^Œ rrqBқ/Bo^r ޴Fժ2|\W0#7 W/$ ܵh$/ WҊ>ȶ&`|ߛKH)z:jҮ4zIk ayD M#it4I8$]d%OI`1s,9J dAK,:Ł&[ܥ#V."eґ%e:-!>sCLy`͎.}h8㭾ݖ[Ӂ!})g1U"iF1$3!҉~߁\6}RO5bIka%%)<A"45c뤉\ V[GPBIj?CٺĤSkNmImHKz2 iI#>ZEx ^iICq\r00ԑjafL*VF $^!D+xEymȉܲTېtX(tZj/3$mHL:-P\]WěF$r0-AH|:ڔ'iLIOsxp=)5itĉ_%/UqMI#`Ec'>B:6 a3_ڦrEBG@]u8YV Nd0W)JWշ S-ʥu5Msd7)س|@c>'YWۊ <˟U#2#CY4I#,#d rt!\EU)DוFAF"1 W ߊ$ܴ!Iދ䤊V&Z݈xܕI޳{B;hq3w\ Wb2q!1+b'/8_<) d4pʽrIO6"ӾKR(ݡ@檒*sEL@2qMD㮪x0_yrq+ 0ҔFjGHZWD>ʥQ*ێx|Lӑ)Pz;`r)DdzH % WҕR[iUhF@K_O YIi+I*Y>vd>#1I8t Kw߿$/~\ʛF+M=@Ptw}b8h; ?8KOIM[]KZz5o'Q9p>d [hs"q uVӆrIX2lDYW.:#aIYzQ8 J$,ȇU U2gZ.P!]@^oɅa;RX>m/ X ȅ±8[ 9iΖl[ҳnyP8 nɹVԥ'1g - g.mK3<,hoQʽٝL3" 7J\6)FׅHZzIZzܓR6jiT9LʣEuy,Fyvr.LgU, 6<۸ٟ-Cvױ[ FBfWV qmI5nM#W "}){QpLyWQuo:k[/=T`d_ $u) ^yURM1W![x摚tO]B~V!Mۊ;X{kp咢A[WO-VFOҸɕө:rBdJƣS8c`SG1R}Iy&Vr@a)ad\d< p+E=5-yF85-FwH˕>Hx+ 2ݡAn$٢")Mb*F>jK2~,e$<q V`R 4n "%d$ۤAL<9 ҋ^IW˾XOWFԦK+  yHM2 DdD-I`)6)SL"?YHDꙚgَ,6"d+ygc8hn _`= A* X R>V' 谓HqHj^#u ?/ˊ *vNJ)r `8\4vdy qCN{2SӶ"D"Ei#̑pYN,WAs0`m+rFц ֪0f' vO {޳ц=óʿHzU6<*JzUEWkvT(nVw:.oۚfj6IA;.b gb"u&\13Ta0ofs&EUI1l  l Ɋa!Ap& 3*b:P**`׷\z{:Х!ywd1D{O.y3*oC,L\!]COP lO1CϓD~vD. ,o@HzhYxX*FO 94ti`x@C'}k+*͈-\V\}fYiSSV>[R'e@.JOUtrp4D@lq Ck8_dA/@h{/Dz*9~F"F~29W5s$kg>5Ern>k\&5@~*"*" ?xz?1/ j1|rU1}ܔl2 e~V=r֮gruEyC\a??e 0_/mk*L֕PzcS+V߱߈)N|X$=|Xl'_ KYDl p@у?墩 \]g/f';9I3ჿ\K̟~ŋ߫\x$&ڳ%"g} M8hףYUlVjHKڣ&Mo8&-kvӂ*]O.DX?iXON%+!.Xjt- tsS"N;#\O>n)p7/SJϺ 䯝e3wqF)~1 n0q#CB< yU1߲ |Pk`Qo ?R#ܯ QhK/F ߲/}Moz*P7M=Dl ۗZzIqps5 ߐ bCHn~zTT&S>S!~. Ir*ߚ7Yʗm=dwB>k oEq՟r3ߌP ĐkB*p8|7v/w@xo v#VEU}).T.Kpʿ!k^wю=11Wk_p4/k2~.54 W`~k{U5ރIߒKGxkAc. LT@ږ̯JHu4J_Yf0a}Wo SMPiC&} AΧo,c<(mN1.00^1h3.0AyNylOLّ?Cߌ'Z#`^ j @NG x'& 8UW \b:EW `99G\IR5m8矴i1'egKUsI-__ˠuwV5p Z'=sX^_ ^j/Y;P=r_d##zgE3|^ n٨\_Ws>!<%?GBl縤ĥN0m /4.H@4.Y-%aDt0וaAD0eaf;r(l0ܷhkͰ1aRيIiJëaBk|C \~'v( ?V+ 8ѣd}Vh6zN@tNy# O5LÍՖ3϶ץ3[= ~9de%D[@7yٽ+a;W NtS~qXx0\>8ӭPWKݪ=8٭_5g0mZ^i_@Pƀ^wLi> 8KY2O άocBho@gL~g ɓ4 ld<ǿqE'Ad<xP&sG{omFQ1{]FMOAK1 :XojZf#{cp@[ YLX8ߌE|1ζ0'w-gBF1HCzꘟ1@lyDxw N<4&8 c[;gؼDF! _۷;-،#' _ ~7?éݼ6DOw[ hlezue!stW1*MFv0ڼ6ַ}X6t xs X _Ud iY@ƫc@[oRw,ʲ6"Gƛcxs%qw _`yx]@6j+ X“fGȹT8~,ylJ.#Sh\tG d+W!d82ٝ;睆jɼLd@WxtW6@ꕑK +?e"@..@@c8HY8K YIsP SD:+\ȮDTI/$EvF,C-#iE~G N,y%ih8l+# RU*'i],ʤǷ4Kfٍ4.N3i=h1D{'Α][= 2 ݝ4aIhYD-d$Jj&M`J/'C4O6$>s ^=Z8?i||DXFb>Ԃ9W' ў5&/#lY/a3_/@@ d&/Hd&/߶8>H%%f\5du2b~>A: qK|`Lg&Q d*-w(\_D>LKX$~^BheʋTce.GDx@"u 󩯙-G{Bڋ/˒ ÒwڼBww_!n&ڳW$WѮGh^!.3}/C]j@?fb@2iE&g[ja-y Ve/(@zlÍfU.EVzI&|k>NX- ^cBB_ "`ER&=,[5m0IU%V<^NڔU-$jP"/@ʈB8Ӑx96'q$ofIVNṘB}h!#Lu镫|">K.EW-W@f(,Ug er`bBZ/`[ls!\0srAS@g^K\(0+7^fSp孴;WQU9#${ ]+#]p(v!ۧLҶ"[+6#d]]"Gs+O9}:•ROqڿ8łMtiL/h5Z iBsmC 'Ԏ8_mæ'*MQArlJӻfI: |h들FaEBӋNiB<d3Qg 2Y'y%.'がd<V.8zJ_N/z;iwǷ6XnJ+U4.45W]O{ɸIyd9#הSlL-J-fRb+i&]d [7oڝz9Fit]o} r@6[B2B!k.Jq dnWͳ_חOA_4s=b(di1 "pIseVGj\L&à:=QF.P}2d(=SsmQɠYO#YCdIr?u{0`+-57eNW~\ (^.om-i<b<)ӋDK4['{oh~3L6MI@JoNo:~ܖ()o\- ūEO2Rox}U*#Sp嚏r}|S'd_tp==wW; &W/蜦1ebO/n.w e7 7mpIL5/g=5u1~bSEST9 SW)ԝ.?M1T&vd~AHʜPKM;6&݁Pvz< %qoTH9F#7[09`0$=r\/cz 9V<;ɴD'%bjJ s_^$4#ӞUFh)%Yg ܞkRf#d0W)7?{K4M ?diYYWv"&hd4m 5BVF/`.«&ʞ3ה#`\i ]Cb$=Izt=%i>- Ig[ aN}ZY2TJ^miJ")HrtrOQoϤ<(Mի-sgo9raQ!& ̅K58-F&Ei$]d=n"=Gf+eV2!b;P%'MN4ziGYwH"-rϠ2M ^43jyop-0?G -S;1K}HW+|FbZ$}"g@] HyY2N3ԉr2݊$.VHA +iSԇZb9 % [xa!@F13iSsb`]y `{Do\J3ê5ǶC[O#25p"^KAY1`10Kd<5 >H}ÚW.I>ZM UkҶ&ccY^ᜱ=; ^$0ږ$Fpj$g6KT#KyO/9Ur/pRI>@U4--HA$LH̴"L5)JEa_ʫq٥Q-hd )ˊ!6͒AVy5rÉ4xf;DW<lnk+$n^!BBu* +"ϴvixod+DFf{&z:{5>ӽ]i_qmKKUdX:s!"o$޿ އcRv^uӐyb켑>RiF$|n&iYM+oģ9>Ñ?$T)4YEBީ%ˑu }숽 iPE&;L~HUā/*bI{ Xg胏һSKW\W=ɺW*8ĝ.Or+2ĺŀ_ y)gqԾvlJ;OwҮg{Xa!G+$Cʵ৔BZFlbǑ0=b?F~Ӱx7gE%s>8b!&^% 50ZI5[Kq@L#}RPXd dLboM dݢAB%7i$CZt}ߑ^$ijlҠ\B5'I+ɯ`\imU7i6O[)zO2?U;ՐᢁhdS[d;d+wV UN~.{I|߽KyrZ[g 엽>(}}W[.ˁSd(W-WEv_GKX/ o9pd?a[i[rHrIx *^xp`j`V3ۙTG nF mDl,d9ɘ` 5%ټJm&G۵ٓ>mS,C e_ Dw$0e}OCG)ǡq < db AuY{.K 31%Qt'-[n-]YwgffT.zs6ly8GHy4'Wn.|Gl>;}2YIUd<;x d߻XO#HŕIy!39X{"ቪ.Red2Cc biItdV5m#~g@(zYAl0U& gb"|lIRs "G)J%yU$S&KdL~,t\SWE +vF+\%Kw^*Vm[L$ļ 1Ï*Veb4x dX*6`)X:p~T.!loiLEE[${[IT]#Zϼ~Itg/M! ^բYs$`[D ̳Hu)04߳ lmUcI!b|AB5!~L n)ɭ36氨7=z3Z`=!CN(~ !ށ6$*j( I8l_5@^(+/#E.+e=M#U\%K|?u5\&OrpZb4ok򳤾<%/*K@ӭՒv5p=iF=qõ}=F^(րVRV.@!SImyf\OjHnyr/9%9T[.ih6 xoQ ^N! ~_78c&b$ Om?nd=rYҮ~N-_K,ɻJAuj%p\w$֔lEʂ< @ˈ_O&Ԗ13NG&:LɺA'JCl).܊BuΖCؗ+}hAXIwIA_ڻreWz)lt:/}mmK}!"YYTX.0gDXKPΏ9#31Va?qy]i7m79wιET>f*Y|ˌz܃P{;+v}ef*Ln\#=n+P]?+P]Q˼|9Q3FQ]DTɑH嚺Ggf\l).vyOq=8{ oNfƤ'P>s͢E3pg9Y]s+^YEkC^tF)s /`{bg'i4eϏ&Q鲔C;Yo=>kxOL~4cX%k^ӏ.u]crڠtATEh3-[0zQ/_5}V8 ҟwEzOQ1z*Ӝ }=~UF2˧bÑ3 E)KrDTY'n(qk &ַrm;+u%%ҞȁvYW3um-ׇ2_MRxOYNڼ~h2wNی$QR&Jٲ"̷ p=n9 ڲ9oqρ}YQ,Q:Y@O,[C-;dTL,Kaj^X}3="Lgs֨D(qcx(^JZ0Xύ(9Mo1;d93&Pztz=N}_ĸ};c):d<9&HՇx)a93f-oQ񼽧3ˊ07t7)U^=d;F_F(zC1`oh~e[,1i`/Z4b;3&qg(ݎ r>4vnQn>p{3=oy*(ToƩK0쯞hN(߇y;80ķ?Org峱qrgI Z;ARuN<Ȝ/x*3m `b^qh&ҹ%j4p\}zo|Pz`*oARR `zՉJۦ}yuډN21d8J.>xXTm>q`^! |nP0{syy$d=E݂Wy޾E⼖TyA:Pꯧ-xZTV/{8Fg ڮ=c:|RnK\m>;8x>#+J3w%t(>AŔ{-̮uݢ[QsVr{8onA3u?f8a5 9p3 ݃RNutpjK 8kT_aľ6(F8 Cv8#,+nxb.վʼn{k0b>[3X£xQo /7 k>7Bp0y{KO!xw<( \o=Yu0Y=`wLX$NY^o:o.?O[@d|՞֩HBMRo;wm:z:Ry3k\;r(/7rpƻKßa&!rʍ!wo=r)r'vIc3%`}vK}Xo7 h 1KH} vÀ+³.#++[&;aRVHӂ#Ó# 1?7q&-I2Rl"1ę,jg[us['-v1\s:3u9Kh"paR-.jŤwuۆUl6Iي@V}|=řȋ k%&]߯_KLxǹ'ߢzsF~ׇZ]Ì.й(^dyt\ Ażr.L#y'7֚[%NҼY=5$ۧI8չ'-*T@B NlQ3; ZּlD3o>j|2uhQLų֜٢r n{}F l^[vxm A:+[ޜd׼=]R3׊ 2s;nТD_Zrc-=Нyy|pOz܀KnA+x]}_w3T prfR9ۖ|S6oq뗎;us[\1rǎ_1zj:foYg.mӝ4)EEB$DlFIf5\CM)eN~ߜ)el}b#+u}Mͮ#3*{/r+@hM,`(u'϶fA-r˭n9ІϓApFyfkwmsj×]s;-U6| "{F&u;#q卸 -޲KU,_u:TވܶR ԖmFmdoNl'{xBJTjŹm,жϞ1V*jwpvPٙbBqڢݫ8^gqB܎s?dE@[=_0(I GȬN짽iVhQ@2SA5mVgT>E~BuF3*oVwQ9!{#nn7wv*MgTޢvjGӜQ٣xSkCy@!Y~K%s)gLJ{DGnNm qkۇ{WٜP$n #zvOh; "ly R*l "kLweDd8NԽ@8pq 87e70ζDen#k|'oĝ O^n}z S=e 8{Ff?֘){gOQm=ws8egB޶nRxOWJFSo8r׍O|lgAλV>XΎQ"# cj.=hŘQ5[DwsĔZ'۹}-JȚŘZ-3^x=#AO9z$bLD(/;Vk;[Lk2tZɵ?J+8Dѵ=3xč8WeOh.ѵ<=8x[[ZדZY\+͗/H@R.SY8UR M${ibz-wtgbxހDQ̮-sI!6s%osz>;OJ>xS%zI<;!eΕmwE^[$`zm] d| 4m A-ٷ@A[TO RZ G"5hJ/RgK^;eӫ%oX/s>jԚըΖm-nT<[A[{|3&oYթ;u^wnMۑ;i8e7>}U3j-uj]߸ܿ8A*[Rfam wGLU{JjH܈"Xe% ӆA٧l@NogX\'1re=>Y߯ܗT9~N8ReG I^_yxӃX1 DkΓI^Ap_m_"q#t3eMC"a3@y rE0&޼&.Af3GwM,'uM7NM) ;g.H ;T&U~x31$1lE3@ ;hBv̳+dĝ_~*~4;d|c~KC-i ;P~ 1""!qXSň/jhh{*Lj6^ 9BnZn,^mxÜ!i *|iE ga: h"ϱʢPxK{C- > fVxjT1sjx{f/̠݇rD̻]>8lJjDL$j蛃 ٘,yMp޼"A^_ӝ{׮&L$]4D^aOO5ݰw7·Ag,{=u^S9k+^+Օň\]5+=V_c>3++oF O)LXň8}Zy0NZw',Fɤ$c+8 /ok9黆W,_5^Yィڏ=psT:I⸪*c@ yc  O*GU [Qebim7BD\3 յYkfzH縉rzc沢kGeީ=ݒ DAO}g<; }&pASG4Ɲ%>p{*DjZA 7 ˚ Jqw .ܶ{w^RNLnwkVb|_TW:$`v P.{` "k(8ਉ!M3Ʃ6oXA۵q%ocD#zsg E%jJ{r~5N>pd=dҌ /Gٸ_:(IL (F ʪ?609s nJ:| XQf9\~zjzNtڸrӡ7M-}!1YaT(Yw EÇzgfƅsf64~N3xf:|޽y ru7@o4EyG="iqr сMS9MAΩuxaQ+ͧ p vBSQxh,8Iff8ċa\<>|eU`<<- %?cEUJ#[ޔF%$X9 :"|KH{A@bWԪ)c3@wVqg#Sʕ|QՇĻY" V6|'y$SAe =kj UM'V4]=6I?T)i$JAG3ξ1o$Uprw}d$]qLg'=]dg+ݳ{dsh/ 뾂g+d2fRqY}'㱼q:־/~Xd녓L}m帒$+_ c?N s~'[Q>Qh$Egq vo`y ;"$_\ޯs|Vö~îI>㴜0˓,Tl;]W+U{U}'OخKQHT'lxr!OsRvO2$xQ:`u&3v2̆Wv )ϚXl8PęOY+K;6w2k'J&CL (,Qj >.k@v-k@<TM'Y~ŪEyd~*jIɃWt^#Aƺ_1(̪$^Av_<2Iu<ɒE(st9Fd.ķ@v_ޢIgSTnQ ?I=WQ|^[I'﹖&{e|$˻]tEZ6k}tlEt6E5^w@F!j\d**֮Y|#%ObۭXfyd'aތ4keS<c }?ɖydvX֡'o $,?`MK2ͪA>+V$|޷Ye1s+A~Nћ;5kT_%&:ue4@Wmg{u`({岁}X66&nwѓz?PT,KfOۭFtt;7sѥ)\{"qz'SQ^$Щ*K5h%9N$3'u߱$@,zuB'ٺ%: ?H|;u:N)LDyp3upD(FO(ǒI"MQ^в ]қ'v@$d*vFqʟaesy#=}VVT Eܓ#(7{RXPԨIz?|@/SQi(4{~Bk2{RfTuDCQ*mHC'[=P|ˆFEQe'Yz ҘѶGhO)?1: @1z+)IʣrgيmtRۉg? , Cʯ΢?JK_;ݠo)#MAN+A}Ay 0E$;Pwt9 xK-hSoND@[Ю[a>9P&6J knOڠ%h/o8Y11yӁ G)hod>"@d>-f04/i% q2YGԜa%3@){IØ[ȘC/Т5 e 5  $ c1-ĆdiJ'Kꕾ2tiKeJ ASP*WI|KXK-- c-)Kh-[ZҢzQhWTfH>|KEg LNTG#[zCShWTXRܳm+(*,d)B=-dki%#A) [E#t.T@l"Z0dA וS]Q64=e,ZEK?zv.g u'4 znz ahQGyϤBP:)b:@Q*S3jS5T=dӺF*ih Kq:5v}&]1gsH&B3 Gɵd@l2h?eACQ6( 91d{VE9Md+&c\d(&v܁c*{ v衠i ٔ +(u2='Hx@wtЂc&NYr24)=R"MvT#ā OBl$xJjƫ=J)yxc9HǛ x`qv%ZԴ.O3xTx)kc)@%jI꼡RM,'Y\![$ٽÇ,:*1 B[iZ5Ez4m P Q)j* %qޢ?^/ _,)K)wCDA>BѸG(:2N(Z->B6ѺdzJtb@iQHDTJ=\T(dG(vhbz*(PP5[||,jZ䲪gH=^.F?'M## ^Ȣ `DKӮ u>Z|t4-*r"p .R+2iPnap)@Kz/$hiZ|,xEGӪ°ԓ/Ohg+I&%j`UA? x{+7.@ዋ8V+SisMH:8zq @oee8˴( |L|  2@Pޙpc TJ0Wt*ţMK5_{o]r8[5r<+ L:C*h[rר1f#A-~Hn39)w˃$^$wA2[ ^%w C or2FAq!{ !ps 8n!g.ƓI3 q$"ͳT+ɩ[Yr&I+婚cűoljh@W8ޢ*'Kj ݻAϏ(wYjjD ;DQv,t;튲c㈢lY 6%}cP&8;PuH  54I9 \0򳥶b GuI~Tt_GuK~ӏ)wQ;VN?jE[CvQ+\Es'D'5Vꃄ'5 Oj SjL=U$]QaJ1 S9G,Ÿxj-ܭ9 VTPg)pΖ\+QɱƀsV MAl l7Hl `) d+6rzuf]쓉Z%yUo]k I=wZ]OݢzgWBtlZw [KQuHQuJ]`q*[4>ِI7IJ;ԐS4vJҊti(HأWCG(H$"ݺQ4BGJ 06$|6Bх a(mIF$>#VCϴ~H|YO2 (Q& |a Y&a1ċCJoR~fQ5f.IXLR~!WZ CIb:My!jKʯ(ج;dPQluL'QjN«7V vi Eg[͊+,KUK1Ήރ}p"=L-4a0Ȑ$eD$#$> 0:*&PZn9'MI, !~{Ԃf $&LΠ{dšI:;fif"6z<$ޚv3E{jA8F a-I8aI1!k::zM`'I86dI:صb M'F& `޽u/okJ g# XKM[:bp|)ߢjd6^mGb3$akiI|O`Ώc3딣rVRc0߅$*rړrf{YQͼSʏ Og0́DQÞAsH/RԎy3HȋT)?"$T~Ezݡ (L ⃆d09#Z]z)B"KO[ȋlI>m!$|B :R  %_.xS/PH˦B%Sy˦RTLd(J!/%,ET^dHmS!ۅ/2%v!ŋ,]HA2UýړDB%S){*JY/y ^-3j* 5Î"Fd*JE/ӫ[9VT QH(/S9 dGi~ rf[ tP>&@v/lX5RԴb#lEQ 3tEQ^IbG!Qx 0 $g$auHbHLhRċ, _,*]x[0%{𧃧BvvHf3 -5>TEWWCH-5IZ to ohSږVBИ[?bK r༳^md)*@P`%=WIxAo|Ex Nf^ H 4 $@U@ 4ʊ-}K  ?ECQ3`R~:yE!+P ^J"p/XqILo̭Aah*3|Ќ!gZ.8}#ƒ+ '$^dK:2C/I E7L*L2)}["W p?;c2 c)-z(>tN 0K֕d(*FX|vbmrVwWT)$fI۬Y-RJEv#{€X(x lZbT"Kų`*HuvMjtyړ(3t(fڋ$SQP5X HVr*;K4t})bK`rJO$8-0==Sqc$ gSd$ʯAۆdΣK&vJO##tRdf*S[נL5; lyNNflf"ul@igaf*%#,,ʭcO<#– 'JT~ZchDG2RےP^vzJ=N=T\\_lYPba&DzrV"]x(gKQ/Q35ΪTd[k ';Da\dΪTeI-0TH} ƼDJI2ek?*ښri@|v$%VƔTZښRi' 'kLIŭӚoϼRRQiR3x)wXSJ*NVyԎd)(|qP*C}t%>I׆p9@֕6AQ 1 TrJGEL)hK^D4yc+JGaK2^ֹh"$X"e]^]x%IL dHs(I= /y0 K< :KxVۜ ǗSfh% LJ'QgI+J :]TD25|ږd*Juˆ+hHV\D{Ke't]jD^\`+@NUsT0F'H=Pj8p`؊0Xr"M`'\]ʽÉ0WPd(փEQyY0W*J';P{*<*tBd' `nQd*ރUQ(v{ |0Y%1D1XYJ TT0X+N4 6Յ模*Ic\ݪӀlEi0Xp ֥%L=m+TTK^edݦ({ &9Pu ekfRfW<`.u.5*{(JF$6- ـLf6-bt]k0]5{*^SvZxMҼʈd)FeFuTfT0HPT8NC{ 랊 iDi9MY(+I(zOilӔvE0IW~0btտWƳd=^opڐ# ֎vnӖ6Mi(4ǠHnӕvʛx:6)ŇITXT0\T HteQp]*>oNqr`z3 +CMxFoc 잊 J;Y2dq= EA]i߮%PGKٗKH&AP)p&Y J9EP 4$]Q?C) ; U_?'0;R}ب`.U.6"FvOE՚d**L ֊ TqkN¥RNэ65iSrw]Y3G/ < Va(tEQMe\s% jƀܕd)*jG?HT):$6v ld*JGCwNp)?f*H"؊^J<ո-+Y!6]¸V%kk)g+IWTxR)' SQr.5d@]qKm |ݦ𮭎 o:"kV)l+݈Va?ͶNy1d+*l)ͶN; CQ[*[YHBkVW\жN0# d8wأ'a.oh x|k"jeGيaog`(U2 E`/_ Ta/_ [Q/LIud(ʎ8ŕݑd)ʎUQv4L=Y$RS ^*?\DBGX"GW%T- xli T~a/ne(L2eK$ޢϲ,E0>I(/&ҀJYT~PY(Hi69L axKnej%_arKɗHTU0)G+# %_arċl0~@)G:%H;[EŜSU%H;[M?ipIV3 n )#IkJ"K4ŤS0L[lذ9`WdR~ZQ+lR~"W.R~*c1T 0Ed+*lw)2_ip{Jip8$ap{Kˇlp T~0T HT V0*Hb$KQ8ana2Gރ0ƒ$SQ8a8I$\ g0y(1̧tTLO!U1d׆}>{kAmp|70O;/Cnl%Y ar0kP+jc}j)=co储KBodKe({ /v{ /WEA֓`I슘|*Bc^n(f*qI|L-'YR+tE1pE("F1EA$ZR'A<e('A1`3ɷ$TF RשC[(;'1,;'T㘋 k=ɖ-.;'᜘ɌS-$LB{8'f2ER'wTXIIfںiKfE6H~m {mKʏ׶H{mLB%I^!GigꃜR>ڒlEF`&sWߢW)?^{#7>^QIٻ$W{vjA֧Ğ}Jފ ־$uL-\26H]qU&0 qUu鴣HN;t^髣J+v4iG+vIH8`d)*vL [Q.(a(P:[0Nd7R2lvɾfg;m ÷A( Ƽe. Edp|'CQi[>eYviL[1d)墘 cpheCIƒpU@` b27GH ړtnqM@ཱ + )]q=׺@cBpe vmK~O;1ݳ3)$ܳ{{Z Wɽ*{;ؙMuTO&|]6 > ;SR@튝-K".;;0 &р B`Ԛ%D:GD5\RJSn0$nHƐ72ntL L t;\ Ca3]ו$EtY%xI̞ å;f5nv ~#+:5oN ^&Wӊ \fyEA.3sYQx  [E4?\_V7ҤxK;!5'QLW5R oQ:TLRv]ɇ\ L`'= rRAS]xOEf@5w=]sH撉:3z#C6\ʔV#G(kf:SÞɍJ|(B=@P(T==d=A#\dsLcrd I(0IŮ KQ%~$,{Ƌɽ>yHV m؊1:(V Ɠ=Ûld+d(c (0"KEX Nn rY,O2d点ɧ CA6gM+d)_ [QvlMccn1 dñA(z .\;يr-&wEsO8PMsx'MAp {8&T PwOZ@;Qz  ˄C@\LiT%Y,;;&WEAv}f15Pd(ގe8˗cl2iL7qhDͤ~cp]%]LNP^]0:|(v2L~zk+6| Nņ@/Vb/Cp~J; ^h ր^$w.ܟɦ( &3Xz72$w%bʉ.~2kB'AgX!d+*օf "k.HQjLq$SQ2drZE3 #2 6^a r!;X&ƒ-t0<$|˥2L&n'It9$=yM1Ȼ`n2uX&/$SQ4!{ S1w2{ϵa.sqZKZELE suX:Sǐ28tE3\ 2jVPN갴Nׂ5%LE갔<#RTKhŀ G^Vi$SQ.i $'YI؆$$]Ql>glE/wOPﯘ5-W[i-Pq5O4 F&r?(6MQqDH-&J5Eg|V>OBo}=(մHzݢY0Q)a{YIl KQqLXnOAH|9M*q@$ٔj$KQ#7evOB[te,wLSioIߛVT$?ɖ-+~Hޙ&F߻d4Pޕj$wVIZO{w_SkP); S!nN,E]JsZZ3Q*Jk ~#̦A`*(֖ʵe(+rPِ)gņ:Z xB = bC\E2P\EorqRPfy$A֡U*/";׌Tt򒱔$[Ad,ɐ՝NENP`)(VTԭ{}XA}ΝD9lIb}Xj$KQbl5h@W,Tvׇ OT0`ۡ-6(7`XQV;a**KA:lg[U['aI⥁-`<"}_3$lyҗ{x}Ll.Ώ~␮HxFB8&7W{ yVS k+Ko휠ۃ7z a/'A?|[YHF/SWwĘfD䓆U2?^wz-*߷?~?Z.Lo,Ɠ 0 eՏ \SY??|JKͷ⟾Oÿ_?}_awo^_7_0y8?w/>oW|׮W?p޼.} \{)g[F{}>|5~,3cV_KBwQ;sqܾowCKcE1ߍ'=?z}|/뵠`O_|YgwO^/kgٿk6y ¯ow|-.Q_mE]ˡr܏%NS^ 8t?x]߿9dU?~ecNż v._G?^Vq _]ʏ?}+~XgpK>yዷ-6܎Ou&}wQOU~~!5ßowo{T| ,+d/?#yq??6Is~k)] :C_*K{_~6f/c_ƻן|pa]_._wܡS")^ƀ>endstream endobj 187 0 obj << /Filter /FlateDecode /Length 3876 >> stream xn]- [ Bg E c}@+ )*$G)o9sٝ)0`/wgΜ9454؜'7frs_'f%`dBTM3LfDQU+'o+=BE-HtmL7iLg4*ZgLw3x Cs_~IzӯH$3!6BP$PL._]WӦ!T@W=;k=qģj ®Ej8r Ti9t#7ҵ5G8!M#pI)^ę5kȬd$&﷔_F@⏻hAo3gKUCNamSXr΀m~vۉV b-{If{) k࣡A>@Ȥ`5!\\13`5B6 Z:m Չ瘚&N=θ5}r' tq<'ARfCA8û(8JXOL or1nՍL$i,Jvhu23F>Ae4@McWŸ[o) "Ҋ6hlŌ:)K`1\-k؉F၉ts4>iPV6Hn 3VVʮQQwymFkI~Făc2Ɉq8 IuSIʍQc}٦" a/%g^RJ[}<_|݁˽Z8 5֬]^| 1Ւ 辗]Jqp>`”)7PK,Anu%%U]]#uoXA >THLF\| ``)No=D.7fd άǸYpxZqr4j Hx*c:*I*CJ@(B;<7 /U07<¤1zѵ61UC!(V xZ{5!`,B;",4ʙ hͲte]J]NlIBI΂vo|̠ c#I"Z$TZj 7nUy난,GlN/f\T- ]_DY𤜽hTi 5/!#rw]D3BC;xK:גuR$lPi`?uq $*ӻ-ؼ vxkHg;.Ga^M&`Q!nmKaf۔T,c H{1kl#Dxʱp%9E㴦ZMAHq!j|©cf5Qϼ%S.S$7ܗYS\:rB9k)Ojq3Zp,WlwI7 //ޜZn|2&O JapK55ԕOMTɠ SΔ{++20kf 6r2P՘y3|gXup8wWooAv6|׿8l bpbdك8>3RD.cnصpy8zZ^E{whw^~%Vږ{Ԁ~|a~WCqP;\׫=~?Wղm@wz}5=t~^j Ts?seyta~_ڋoeR"7zKwH^mEzm f8\#ŋ`]sl y+fz,tu93οm/1LB&ω&f-9T%K4(D"R/ * ކ.1\S]3M߃mpM4OQɊ?66cYx0IRZN?R[1y8^Nx$S>>^pj,+CpMAW *+3/iUEFj+z]r=AK 1l[[FbPɘ:V@ ֢T+~YԢ`)<-d"VQݗ|Dv*6X@z{V@ͣuAUB%I]vP9LJbݝ> }DH"6o;԰0McrȞ:!p0a4:tRfl(u{px cCNBq?P4$_lL+Snm}6:۸bd<0P8tȆuG+I}秺ɇ}NQ(ހQxt܇"N- N&q̝8a)G!(qgA v쇓9,w#H.OB[i!A-ϥ{D^^5^uGaWyĦPG??1ѝkCؙQ;*>-'&dC=/ eۿ')IށNfi?nJ |`Lkz吭@TQk}1c<ڥ8эas̵80|ͅoXmU8g`l[#Bu=,wWM!|saendstream endobj 188 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1813 >> stream xU}PTυ}/Lh *,veeX|-g]C!aiӖSjdbmK.5m3mg:Ι9y;$᳊ IRyһawpB_zl=2C(iB@ٹZ!ӈ%/""_eKhBK٢F&U5!Kȥ(xLZPP"V(^~UT D\:_.RfkDbT\\ȲT*r4R(F.UgtR+K2d,AM D"qH"!oQD&1D,!~J!#ɹUA*?gO/;+<"ޣZ ^|Aw+L}WLBWEMUp%WdUTeܼB nzCԽ~~}źMֵx9;#F z&䏘dH~ZdIz0#{5pSw! ҍoSH-`Q7T|u6`c!BZntw#+Lb_v< нEd rdyTz^yw0-&sd**a 2>s0| h,:(]ߦuA-=-54Yd*&Jk6֘ޕsN5ǿ.n}2؞f#|B'> ʴS5uPGu- PVh$ >[<лQQ'zAK00g8`Ipj3:1r)tlz|Xh?Z4pj׾p}\ً`Z1Mz8Mו;"WDVRLbdԗq AꥃG$pOBBh]40WY5=p꠽WlD\Ln+a<}ͽN=Q%.|_#$'KXBB-/Y#E]۪+jZ ;[[:X>ss=.BJ8cy+s. -'|mokz-RoIXr;%vBZl=z޽ Hiot qj^cWhO9=5W-/endstream endobj 189 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 755 >> stream xcd`ab`ddH)K-LNO,,Mf!CwޏG?ֳv0w,Y =Z{wOfFF,ʢРpMmmBR%LF%83=OA (K/M+M*-VN+VQJM/I,R,ILFc```/Le`g`abpc`!acL&~#r|UŅ7|@7N|*|;JݐY^%#P=ӻgH^caY.'l0 +Ȓ?tn0~c"?֋u[&F8ygf6|;nyjwGe\7;NˀjHTtn=w9lG6Fċ>c> zt[ů,%I.-$;o]ާkfNi~1ibMTwEMnU]QYB]B7k경{L7bk+氾߹Od6^(g?UJ̼KO_2wE+n84Yyw~g ?ڱ?Y YnUXӘ-ޝ_ 1yzKl'8{\np>$yoqj7W3X$yDf]1m]#y?]]Ü--,ݣ&nσ=SgϽ,w9.vhj+YcACz½d^_ߤI&La`wUendstream endobj 190 0 obj << /Filter /FlateDecode /Length 708 >> stream xTMO1+f> stream x}[G{?>>=k`cgH3"[T٤ݔ4Eddeu4$Y5€ؓWWNot1)RP/6l]K-ӏWgW%Srz).!^U/!S,^\řLHv4]wX]$K5R LcM4SO8y`˖ AOɚpOc̄x "Gҟg ޿9׷/m4'5 zHݷ޿{b\ܵ1, lʳloGφFY{6`Zy6Z2φuVƒkF/+dž"ֱ;6ė~אKvmS+QڐW%Mu׆<`wmBmWwmxkS۞xkul0s#sC&ڝ2~ܐJ[ݹ~6wGᮌ +ޘ:7Xun"m}ȤF&ڂi|HN}HSDo1osC887lP`Eu&œڽHJ|n"Z1M$ yn"ɪ{7M$E@̙sw M$9 vn"PF&& n"-2ۉݐ?7rݛwgamݛq]D a*lw/RivL? dEh l,F6i92snޤ-b-#A-r X*mr0a#4hCUmFLh@=u^-n̋l1ZTb9M M$bE{q1E""&&kJNdZ 4FH!"MbEe-rY#Q1RDE(YcD#F-ld-"Ĕ7Y#$1 k 1b k8A)=c}" FOAL$F+4%P.7\&1sh^پ{3RR ԡI.>r4}Vy}΍_;笩LϳcMk@>71lɒW?}.E|zC>|vVϤFCHi||ismj|_Hy?= ̽~(H!%%4Ahlؾ&lDzl=[".`P#vCE]cPWWF&D =N.+lqT|J*ź.į.~ey8qnU<ѦY:?OUG?U(~gn?>xN *~x>OJ4']V穁0xy!_[.ITs$!؏.^D a(~'gFC~1 uCdFH8b?Sk? Ҕ5"cPsO$ vKl`iт5rjcT wQ&GQFE(UV4 "1Vc﬑4Is+I.-'9H\$959Hfl$; tIVfd#n%0n>bydoQ>]iJQ}]1Ů86]iF]iv9NU [q%dE{wA&MhTc A^V)yb(r==~Bt\bbU=Єd z~%Q=لblzH[Z=)"IHe>xkǎ[eS({p*yp]Yow2kyz{֛ +/+'WR&T+1*uz:>-ʾKêRJR +z&CE5P*bW~Loa| 1CCHKA,;DB u4ҭ7 _czCӏO䦪&.q0Mve.$!r%^խ7l0bz^Yr$=DFZkaGL9y#vȑT]) (Ώp!1&1V{dGR+&JM!6vL޵䤲#<YeաSvL>Kb$rʛLpGvL.+;D^U,ʏɍ8ʌi]%0)3cs؝Oͅp$LWӸ}v4\#LR\%ݧ΢U#j8%k>RE5םEDu4x*rH_n@w]+6X|؜n6JY#,*q,΢kY,!A2ΣǫT'=:J5‡[FQJ3֝hug1Rwaޢo- "] UJ.:c"I$>R[EbdRPoTtwQz% wo*cgW 8%SE%4q]4B 4i%HhϯL ~x+^'WwƤ mH햪(<"HoR$xT<+sT*x 9*x 9*x WcOo' vgN շ_\(* ҧ *Ώ_:`E<.?YNt_Wnzu& k_>=D+Gܟޫ@͕ѷ좔_>& RqDvAXBԠ n-gbdKT]eŀѿD ;0b?Jj+Ҩ&(Se✾0Ix2@Z,Jb2L$K"#tDH' a/@*ȩ=Ⱦa~ҨjW%(P)x'TCGJ<7ϛ#aAUj+|`'1de0UP)iT Hkޱ}c# P)8}TUZ/R%5 *Wv"Bհdx TM4{1`?PawDo ?t:^wCmn؝tv/4{6Ʀu74{6 M^h `wbMnؽtv/4{6 M^h `7&~M^h `BmnؽtngNh `wCmn׽tv/4{6 Mnh `7u/4{6 M^h `wBmn׽tĦu/4{6 Mnh `Bmn؝tv/4;6 M^h `wbMnؽtv'46 M^h `BmNE{6 M:muA ^u=N1ύN4oBW7$:.J̷ )MD{P"Ȳg5'TIc +*UCVT%HZYhTcCcj)\ڊO*#@I-y!-Nj$֓|zޟk?.Uy) qꌹ;.{QF-Ѣ0?PYYWxݢwtpr o46,f5_4"H:*"H:*"H:*"H:*%:=*"H:*"HZGEQtT$IGE/W$-EMc̑r:n#~Tmn:JRxhTJ"ñ$Cu@Lj@'8`7TM7>G>> G۸~=z7մ"\xdK/)r@J/TcyLƑ p3Z :)\ Ny3~F7 # #_B7ygsv%N%fOtYN9xר@Ⱥ,$"DɷVWUevq3:#`N A?;ED 3SW}43d#vӓS5/!;%B°iBܝ3%CMI:y7[/`SyEpB.N.wS'lp|фjO8?2iTUY>F\p>!b& gqׄЗxnˆ}@}5fb0W<ݰ34WȬRqÔ@+Bg UpaҐ.L` }`9!sf|n"_g,2(qh!WlQQ)g .h?N1x աxO=N\-@" ]$iA5I I\gxI| ۼ(0Þ!%E>(È#Z .Y㭚)&F4\2b!'Cx!p\ A3-[&D;;Mٲ5Ö_Xfº 73)N.aܱQ88\3arft|}#nuV%aƀ=r>-7CQAӎ]0CMC#ƙs4.ߡ3wHm!!`|^:֪xnJpL08 }!1ءB> gN ߬7t n2cMVf #mE=E3e#!-0xTz n3&zC)8\A +5%{c=H!2pRr )1*N/AؼBU)lI|ʔ|:.q"XÌwWE!gؒnF䄚(}9Â:r2bc ܌3uY)[yӔmr4S:*9^*?kp):mM&B"A18#bbwNKh Ӿ[.Z~f`/ZlMjgpZ_ ;(;-=\ 9RQ8 evr$R+^5n1M.UJZ5uIh4#l vq?\ۍθ=7D]F wʷ[A+?{wh)$EdLۢN^sEfyB$}r[0!'b@.I!78x/>+U6#A\B1=՘:% HLe)XvA5in]%+WrK)Y#%,RaH@afW]?ܣ Un6 !53CBF3@i\k]I1maḧ́.[` |~ ߘd"@5|ŵp:TV*a%$ X.Fm S<9}5J Z>8䡴 ) Ep!]=kĐP{G@5&< 6EͮҋW4ݓGB,bMVm+LH$sRWX NInQEYH0qܝ 9*#2u¥yQ:.MZloHFlM/:S<fw* <)BEU=왁 &jAno>M+Ճ :#%>qx!t z'^rr-Q 6Ψ ~SSllVeFq0# 9paS26[\:d˪W7!9ȱ<34ANfPfǛ8kvh K\8caZM,aƎ?){Q1#w)Etؼ $x+p]"ps* 6gT8!Cy_fTSK;24!32u)v|R:Epo?cWBxuFoD"8;Uv %)k~xF4D/^5(5GDV*(~i8WT7ϐd"* "neF G)=U#V9rM.wK_9p3 Bw&UT|2b[I؛ nBːH_ݔ׀k/˙_ʫ$^KVvݑ)!-Oor\;; fb`T%LM5C[@9jl?1$bM\wA5P`i9i N6yF|t3i JIxI{tO@ iJD*!Ic0dkrjfkb Y"A.OqVfx%_igSxOx[s-I$Ɖupl'I^Ş/p(do-\gʍlsͩ 5IOa987S{6UcK*W#&<0IWSL+S?x8H8%3EolYuceEj\)2u٨3 %;S9bd:km0cQeЕ9,4L]?eE L0bZZ8W \{~>B<a-9i(ZJ#ދ6vUi oN~ȎJ;6%&X0mYb6JY5 ̸E@|y2CqTv﹔L: #x_?ДL??w<)t8Co.h3TvxrYzlaSxg뭿2RGQ,uKRRGg Q,uKRGQ,uKRG'Q,uK}RGQ,  [6~=:fYOOwHϯNO)}B X\tqzU10O?_|o~-u[{?Dc)z>~mǼAL>͟nVMGt8h@ã3Bw(."v[2%<0zw<Ɲgf+mQ3wwtxsTă8g-$_ /3 :kx(b..[cLq~z-@9+~_E YH]?_A'BYBe 6$AU^7~UeN kY$)Hz8x20;p7x~ӥϋdwT=i /,}~I?/u(x5}u-_VmtgC;ӯPxJ:Dbρeno?>k_PO>АϏXyE6jɯ R~ӿ~ηp_uem_MOw] T՛HCJVi̯ڵMѴHPG|N~l\cUyv&4'%P!2zS.'[ Eȓ-Nme3hӽuoBgP&h?~wE^}Ůtg53_o}\SV6>nphʚc> stream x}Pg7Ui{a&TΪEiճUj;ZyS2`  !y'@b !@[%T8[rTS;Щ[O{wmoܣ3ϛcwgw~?wBX,2{7%3gXY6` }ρt6V-ٱ-GP/6P۲ RRV=/xqW7^ڴi X) {rLbn*yrD n-W[6nTYBYM\Y7U W\#V։KU*>L,x(/9[.SԪJ^yXYE*BYI*eY!|8Hl'NMb7G(LT)^z4kxst(2z2 cIk @1/;*t[NIz5}wjvJjExhpĿ(oCtYqCe3d͢39-~ZA($_U,2I= &zsw&-NPorPcRHL0tΟp{~SwgG& 23e@}^_ s?ĔG*E/dM=Ftn53$r.3z]RjR~ s^:9(ޏ/]~vIo=?< 5"l G~? DD#i qvMCK.MO}SjTS]7솎{J=C[zCC\1~aq1$Z`MBbO0q!ΞXiw;: ;6恪[7=%o~aez"9ne<|8M0d4enq{[Zꪫ&]yڐ O&EIɊ%¦~>ޠS0K,o.<>W PAju2aBU[02;p&&SĩPh+ànd!BQQ@5ZJE+ٌ ̡#7;/1]ַۂc}m_U3.rX\D Ѥ3MNǢ12$0*p+`yY1sۜ`S:#6n\i؈L> stream x}M]9>"6< / KniI̯9佼/4R&UF]E%NOs_>·N?c:w]!Ο;wӝ5^r(bh.^$ow?)R.јj͗g1޷Qv"81mIZԙgv0e(;#1_8:%_ޝOIzɹ||pDw|\O?1^j<9Nb9M6tÝO]*^$I.p;T.)~||}=z\Wo`8T/_pӿ \}ZCw@~xSqZ>5=bIRBKSۭG_ߠOŻ\v {ASJÂiCEY.9a<h\d'WWtRU/.bCKhNe|)F pq|Q )AW v:{ PQ#BqTcq_0hĖqLp\.z`l+0w#a Wh-wid kZVw#CV|pF/,X!BGG3 /lPZ-`Kbi{0cX  ]ɣAhQRM0џ0hö Ύ ת\$u 8ZǾP() vZj.>]ɫ_jV v-G0}#]Aixg"WY-d Ø/M s(dDJ7IW94\kUt("5آ+OJT0yAhx&)0=M\rŏXĆ9LZv`%En8:Hd|yu-(.W!!ަTX=&kr:V œL~8bלdA pcp]yL=@VK Y83Ő)}b7M aN&]/XQ/Q5B+zA2MU@ĚA0Eت+k  OBVs, a !8UWl]=y7,0:gCV{ϷoCF\BeG,OvvV U|S6&G2l%ijQv^~a4xzBĎG^gD\kBr<ЧA{Pd(3RfNjщ:eb=ؙ>}` fSZaHŹp|4Z9P@sYx8`'l;}},ab~ԑp=-@H0o?㛷zQV__zͿcj-5z6Qb4OCJ"dR %ٹ6JRK2q 5#eؑkPf.CLL0t4(3WO0q=QGqo('0JRV ;DW\2J{1qMz& [ph̽=A1d[lAID2/%NQ+JL 2hUi#3(q p\t9p p}W&JJ5QlæC&9byIm߿Lo:?VK{*8JjkפbJ2{|O81&_͝mcoCZp<1F\+X{7i@ur6? 0!-$(D/p(iXg.P q܊FA]"SE{= =J| rǠ@4W]Xq`@X buEPk5xK:@`+/ut0Prؔw0t4쎁h- 0P ',HKz`W :ŭ@0WuQ,ّ(,% ~ ૃ(+>#w31 LYJ)}*.;Ol)Cv ci%3 $ MnfN"aז 2@xF&(,M14Pr9(! 9:@'0PM` L`Dď@4h P}@i˭h m& e %Y&4PbF (\h ,xt4C@ti4y~7( 3@to ^>m6QZP$A\eq -mefAZ^ܯA:Ea؛8"JWgn߼ ܓ3 yļΤ].3 T3ҙ:ebR[cAs $L23o{1䠋i;GD'mG>석o&:v}'; ]袜_zj73ac8[A6y=V)9<sOn;E fpi(sXomD*z-@t`57؄fe(a5C0y8/גmSV!KxQ^:Iu Ȓy| BlVXxI%6M[4An+p 2BXĻHL+42]%,Yw>躃}pI ESQJ! g %:b/[Y靲~:3'"sqh+@p+cmQ1VNem PEUmɢ\W5k솑.B0 4F(&ң1ڡ> pA13X-H4 Y[IyP#, ӭNjKuPPΰzLt.PTM{W"?dzP, )רu/,c`LRJ!&R)/dzTߙD]6JW@%h0g@(1<_a1I߃f%7)x(5._hos$zOAc#9:ܱHDX,XoU y3R53L,Wc7!j634H K~J:3Etdh5F#:/^L%T0݋Ig> eR:}9Hax"xM Fh9A%3at [-t3g;VJ`} DŞ&cc{tG]_NPk_y. Y8bD28;q\` 2\6\5kKA=J<'!T%`mk e],]-E %#D1K*'F@EQI𱿨jjb f04Q›K86N qd̚ ² [*m#FHARE,m<D;0 PS HTRw A6 I`_2T鰶F1fL. SoWuGDk6kdefVވ:Nϙ:~>h52}&1lE 2˸WQmcY0#}LgOPI <#Me}wWthwuYYD}ԠnE,li_򔮹vJ&6^a'sFeMo(W63FN\ebI"?kL\W=L%4,ڞR\#fR:OxD?*aq*}Me1ڏh2sEt8wA9p3Wz/&__-2!4־D`Z*~GbԮEP"Ӌ- gkʼ`ERc`W|kZ"ZO{M,ZiY *`<+0p+ѢKׂM$x+g",%nU?Eˏ>ѠKra{p%n8^^ޠDZxi7,ONى!y_CUŎ^ q 7xfRZErXc yHAisRJ\1[ւ,WtظB٬CB܂Of 4e쯘qˊk`;0azjn5h CXdK&E"а[z:L ݭPЦj5h}3Cڀ[gx6\ W%,#V`EoXQIvxVؽ,Rh5 EFpaH 61S,=I<@H`9ܦ0wxP#OPyԐqtzR{͹9GfY91Y eN`xw_oxaRC':en>/ȕdIG2eF}6FX?/ip ەFV"'37y2ϛ)cr vRWFZKD%M߉ |( 2-È= d'`A#FIN0ѮgǬ /\$:}SdFLdCʧjX`3bhПAA'< UX?W~HLKI'!%< :r[*8fyiE=L+l$b,!幛Z//fx SAcj̵Qv.lF ޸Q&.VG)a(U_޿ؑ-ԑ-Q,1^J`AY++C-p'xSvJ$a$~E 5z*q92suOTW;נTgN9pWM\7~m~0cr:#?;j^w9 //: 1#Wsf,B?({ ckuh#Whn}zXRӦʧԉ|Ub孚[cRw@&I{?M}Okf6oI| 绣w;_wGw_vjB}MoԊ*`T[!Tk}ZէΕ&.R!+;PW<!;;%iR3OE]xa .+f Lg ~V`;jνMPd9P,)]Xu*x +٘B2s=/Nj-BֲƲ*{3"b-͂m0M+x^^~oeOnPݴKiP _lįX%Äy;'lQ+JЫCՉ& pZhOx6ȁp# L< +Ohřg#L< )>&gLSd]^yP#q3_yP#sZ@V[HsEkQ6}yӡ76! 'F"VX߰Kgml'mǴT/odzZ%R /5 /^w2vxD<P1?O0?]WÞ6o6:Os`zô#Xn;{|_\Hb=i@ΊK"`B%ME^cD"ZKV=j0ndhS*S\Akj;tKI o zYˡaQѓE Ue&cB[uT^sRvz͕%t=3K/jV6 WlѢL B&g8`6",MD},HjIJVVXqV^ U467L{˳O5,yb=-6 >H* kDl9^cK{fq6FOsuʁ ).aW~=E≁&/@ )tԾ맅<גtDʑ= E28yjtiEU\4uV"=;VQ*Y0 DW" 0*&М700KI)+)eo"Qy1ZhZ+k]:+NXEu"XmR.}+!r 6p-Y"5(2mYE9Gk2X1]C?[q^\Ђ+pT 9;…`u.Mҧ`겤Aq KSYno(3iQTOzL)5:̭zE5~|n= niH#BCs;8+,'`Ѥ$_e*J(zg,AMׯvi(J 9$N[x3m~sM{^/$99;/LN/XX&ٝ$)i EmQV^$)K날*@ >8xyyMm<B(~g'h:qz95X.r?[*ƲKϯ~5Ï= L`ٳS'Ͻ<σ?e z.endstream endobj 194 0 obj << /Filter /FlateDecode /Length 1135 >> stream xWߏ#5 ~#Fkk*M=$:әJpulv%Qߛ?mvO 6ksh_4fHG N*iHC>,^+%RF4J:J;U,INE*jDrc0dRnJ[gmbGC#ڈd#K-:4PYq7!4 48ݳ ?}'eb=n6Ub 9\#0^[ҳ[@BcAglj=mqpǼbҸbmԚ'n_` Aw|d\HV=j/C!Rӫ))CCF6L؍~Y{Wlϙss}dP娴Cҙo KiIu6=c3rk?ho"5y?fD=p"pv=tש]A+ [vˀOeNŭ߂Ag|g'?Yb{Yyѱ.0N(Xendstream endobj 195 0 obj << /Type /XRef /Length 157 /Filter /FlateDecode /DecodeParms << /Columns 5 /Predictor 12 >> /W [ 1 3 1 ] /Info 3 0 R /Root 2 0 R /Size 196 /ID [] >> stream xcb&F~0 $8J[?` } (_؎p'3(b;l& RD>'AXDJFHk 'H2  RDL`RDrHm-+@Hl͟"9 @$/jK@:?d F endstream endobj startxref 217193 %%EOF