plotmo/0000755000176200001440000000000013555402522011567 5ustar liggesusersplotmo/NAMESPACE0000644000176200001440000000277213443065132013014 0ustar liggesusersimportFrom(plotrix, thigmophobe.labels) importFrom(TeachingDemos, spread.labs) 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.y, default) 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/.Rinstignore0000644000176200001440000000001313275306073014070 0ustar liggesusersslowtests plotmo/README.md0000644000176200001440000001072013304112271013035 0ustar liggesusers[![version](http://www.r-pkg.org/badges/version/plotmo)](https://cran.r-project.org/package=plotmo) [![downloads](http://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/0000755000176200001440000000000013431133540012334 5ustar liggesusersplotmo/man/plotmo.misc.Rd0000644000176200001440000000614113306350242015072 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.Rd0000644000176200001440000003305613136175632014334 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.Rd0000644000176200001440000000616212763547607015200 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. } \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.Rd0000644000176200001440000001075713011412401014426 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.Rd0000644000176200001440000004560413431133540014146 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) } 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/DESCRIPTION0000644000176200001440000000157013555402522013300 0ustar liggesusersPackage: plotmo Version: 3.5.6 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, TeachingDemos 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.0), gbm (>= 2.1.1), glmnet (>= 2.0.5), glmnetUtils (>= 1.0.3), MASS (>= 7.3-45), mlr (>= 2.12.1), neuralnet (>= 1.33), partykit (>= 1.2-2), pre (>= 0.5.0), rpart (>= 4.1-10), rpart.plot (>= 2.1.0) License: GPL-3 LazyData: yes URL: http://www.milbo.users.sonic.net NeedsCompilation: no Packaged: 2019-10-27 20:05:38 UTC; milbo Repository: CRAN Date/Publication: 2019-10-27 21:00:02 UTC plotmo/tests/0000755000176200001440000000000013410604232012721 5ustar liggesusersplotmo/tests/test.plotmo.Rout.save0000644000176200001440000000132313410604232017020 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 Loading required package: TeachingDemos > 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.R0000644000176200001440000000037512764071472015360 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/NEWS0000644000176200001440000003642313554707121012300 0ustar liggesusersChanges to the plotmo package ----------------------------- --- 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/R/0000755000176200001440000000000013555373774012010 5ustar liggesusersplotmo/R/w1.R0000644000176200001440000002145513306353570012453 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.R0000644000176200001440000002014113305324416014102 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(object)[1], # class(object)[1], # " '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(object)[1]) } # 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.R0000644000176200001440000000725213304032663014162 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.R0000644000176200001440000001151513314550545014770 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.R0000644000176200001440000002622513440615525013567 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.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(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 } # 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.R0000644000176200001440000002447613410602132013605 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)) # 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.) attr(object, ".Environment") <- get.model.env(object, object.name, trace) temp <- plotmo_prolog(object, object.name, trace, ...) object <- temp$object my.call <- temp$my.call 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.R0000644000176200001440000000301413440035220014431 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() STOPFUNC(callers.name, MSG, describe.dot(dots, idot), call.=FALSE) } describe.dot <- function(dots, idot) # 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=5) # n=5 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.R0000644000176200001440000000572613304032663013750 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.R0000644000176200001440000003410213413130512013704 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 <- TeachingDemos::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.R0000644000176200001440000002074113440617050013763 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(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.R0000644000176200001440000000575313440525402012707 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)) 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.R0000644000176200001440000000135413316206322013413 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(object)[1], 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.R0000644000176200001440000002103513323750443013300 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) && nzchar(xlab1))) 4 else 3, # bottom if(is.null(ylab1) || (is.specified(ylab1) && 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.R0000644000176200001440000002164713554645370013455 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(class(object)[1] == "Date") paste0("Date:", paste.trunc(object, maxlen=maxlen+12)) else paste0(class(object)[1], ".object") } # 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(i in seq_len(NCOL(x))) if(is.character(x[,i]) && x[,i] != "...") x[,i] <- paste0("\"", x[,i], "\"") print(x) } plotmo/R/plotmo.R0000644000176200001440000022736713555373575013465 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)) # 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.) attr(object, ".Environment") <- get.model.env(object, object.name, trace) temp <- plotmo_prolog(object, object.name, trace, ...) object <- temp$object my.call <- temp$my.call # 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), 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(object)[1], "(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) list(pred.names = colnames.x, abbr.pred.names = abbreviate(strip.space(colnames.x), minlength=minlength, method="both.sides"), 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(object)[1]) 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") 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(object)[1]) 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") } 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") { 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") { 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.R0000644000176200001440000001267113442071413013550 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(object)[1]) 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(object)[1]) } } 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.R0000644000176200001440000000541313375404604013251 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.R0000644000176200001440000001323713323512123014101 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.R0000644000176200001440000000323213316511024012473 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) && 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.R0000644000176200001440000001133713407370616013563 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.R0000644000176200001440000001121513316511030012646 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.R0000644000176200001440000001545113554637635013775 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)) # TODO revisit, not really reliable because it may use parent.frame attr(object, ".Environment") <- get.model.env(object, object.name, trace) 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.R0000644000176200001440000000664213314322613013373 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. errmsg 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.R0000644000176200001440000012276213504761352012676 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, 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, quotify(class(object)[1])) } 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) && !isDate(lim)) { stopifnot(is.numeric(lim), length(lim) == 2) # constants below are arbitrary small <- max(1e-6, .001 * abs(lim[1]), .001 * abs(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 (TODO except possibly if make.unique kicks in). gen.colnames <- function(x, prefix="x", alt.prefix=prefix, trace=0, xname=NULL) { 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] } colnames <- make.unique(strip.space(colnames)) if(trace >= 2 && !identical(org.colnames, colnames)) trace2(trace, "%s colname%s %s now %s\n", if(is.null(xname)) trunc.deparse(substitute(x)) else xname, 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) { # check args, because this func is called very early in plotmo (and friends) stopifnot.string(object.name) check.numeric.scalar(trace, logical.ok=TRUE) if(is.null(object)) stopf("%s is NULL", object.name) if(!is.list(object)) stopf("%s is not an S3 model", object.name) if(class(object)[1] == "list") stopf("%s is a plain list, not an S3 model", object.name) 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) call <- getCall(object) if(is.null(call)) printf("object class is \"%s\" with no call\n", class(object)[1]) else printf.wrap("object call is %s\n", strip.deparse(call), maxlen=80) printf("--get.model.env for %s object\n", class(object)[1]) } # following will fail for non-formula models because they have no terms field terms <- try(terms(object), silent=trace < 3) if(!is.try.err(terms) && !is.null(terms)) { model.env <- attr(terms, ".Environment") if(is.null(model.env)) { if(inherits(object, "glmnet.formula") || # glmnetUtils package inherits(object, "cv.glmnet.formula")) if(inherits(object, "glmnet.formula")) stop0( "for this plot, glmnet.formula must be called with use.model.frame=TRUE") if(inherits(object, "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 with the %s model: %s\n", class(object)[1], environment.as.char(model.env)) return(model.env) } } model.env <- attr(object, ".Environment") if(is.environment(model.env)) { trace2(trace, "using attr(object,\".Environment\") saved with %s model: %s\n", class(object)[1], environment.as.char(model.env)) return(model.env) } if(!is.null(model.env)) stop0("attr(object, \".Environment\") is not an environment") model.env <- parent.frame(n=2) # caller of the function that called model.env trace2(trace, "assuming the environment of the %s model is that of %s's caller: %s\n", class(object)[1], callers.name, environment.as.char(model.env)) return(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"), err.msg.has.index=FALSE, # TRUE if integer "arg" is legal elsewhere err.msg="", # error message, "" for automatic err.msg.ext="") # extension to error message { err.msg.ext <- paste0( if(err.msg.has.index) " an integer index or" else "", if(nchar(err.msg.ext)) paste0(" ", err.msg.ext, " or") else "") if(nchar(err.msg) == 0) err.msg <- sprint("Choose%s one of: %s", err.msg.ext, quotify(choices)) if(!is.character(arg) || length(arg) != 1 || !nzchar(arg)) stopf("illegal %s argument\n%s", quotify(argname, "'"), err.msg) 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), err.msg.ext, quotify(choices)) else stopf("%s=\"%s\" is not allowed\n%s", argname, paste(arg), err.msg) } if(length(imatch) > 1) stopf("%s=\"%s\" is ambiguous\n%s", argname, paste(arg), err.msg) } imatch } isDate <- function(x) { inherits(x, "Date") } # 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)), err.msg="", # error message ("" for automatic) err.msg.ext="") # extension to error message { choices[imatch.choices(arg, choices, argname, err.msg=err.msg, err.msg.ext=err.msg.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.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 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.R0000644000176200001440000000037213304032663013577 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.R0000644000176200001440000001156613304032663013604 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 <- TeachingDemos::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.R0000644000176200001440000002067613413121111013766 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) && class(gridval)[1] != class(x)) 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.R0000644000176200001440000010626113504767632014323 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) stopifnot(is.null(p$fit) || (p$fit - fitted == 0)) 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), paste(versus)) } 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.R0000644000176200001440000000637013504763263013225 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") 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.R0000644000176200001440000001237113304032663013066 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(object)[1]) 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(object)[1], " 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/type.R0000644000176200001440000000665613555373774013131 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 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.R0000644000176200001440000015213013554645736012574 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(object)[1]) 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, xname="x") 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(object)[1]) y <- plotmo.y(object, trace, naked=is.null(nresponse), 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 for columns 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(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 source <- temp$source # model.frame.x is now x or y or NULL or an err msg if(is.good.data(model.frame.x)) { 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))) } 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) is that we issue trace messages # here in the helper routine, and the caller silently checks # the returned value for good data. get.object.x.or.y <- 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(object)[1]) 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, 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 { err.msg <- sprint(...) trace2(trace, "%s\n", err.msg) list(x=err.msg, do.subset=FALSE, 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) temp <- get.model.frame(object, field, trace, naked, na.action, newdata) if(!is.good.data(temp$x)) return(temp) model.frame <- temp$x do.subset <- temp$do.subset source <- temp$source isFormula <- temp$isFormula 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 allowed 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, 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=do.subset, source=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.subset, 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.model.frame <- function(object, field, trace, naked, na.action="auto", newdata=NULL) { ret <- function(x, do.subset=FALSE, isFormula=FALSE, source="model frame") { list(x=x, do.subset=do.subset, isFormula=isFormula, source=source) } #--- get.model.frame starts here # get.model.formula returns a Formula or formula with an environment, or an error string formula <- get.model.formula(object, trace, naked) if(is.errmsg(formula)) return(ret(formula)) # return errmsg isFormula <- inherits(formula, "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, isFormula, "object$model")) } 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)) { err.msg <- sprint("bad na.action: %s", as.char(na.action)) trace2(trace, "%s\n", err.msg) return(ret(err.msg)) } 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 model.frame.string <- sprint("model.frame(%s, data=%s, na.action=%s)", paste.trunc(strip.space(format(formula)), maxlen=40), data.source, trunc.deparse(na.action)) trace2(trace, "stats::%s\n", model.frame.string) 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 < 2 && trace.call.global >= 1 && field == "y" && # is.good.data(x, xname=field, trace=0)) # printf("%s\n", model.frame.string) if(trace >= 3) print_summary(x, "model.frame returned", trace) ret(x, if(is.null(newdata)) TRUE else FALSE, isFormula, model.frame.string) } get.data.for.model.frame <- function(object, trace) { ret <- function(err.msg, data=NULL, source="model frame") { if(!is.null(err.msg)) trace2(trace, "%s\n", err.msg) 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 { s <- sprint(...) trace2(trace, "%s\n", s) s } #--- 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 ask Formula package people to extend # (currently only earth supports attr(terms, "Formula") and "Response" form <- attr(terms, "Formula") isFormula <- !is.null(form) 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$err.msg, fixed=TRUE)) return(ret(form$err.msg)) } # 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$err.msg)) # 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 { err.msg <- sprint(...) trace2(trace, "%s\n", err.msg) list(formula=NULL, err.msg=err.msg) } 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 <- strip.space(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("%s: \"$\" in the formula is not allowed by plotmo, %s", gsub("([+~])", " \\1 ", rhs), "will try to get the data elsewhere") return(ret.null("%s: \"$\" in formula is not allowed", form.name)) } list(form.as.char=form.as.char, err.msg=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) { old.form.as.char <- form.as.char form.as.char <- naken.formula.string(form.as.char) trace2(trace, if(form.as.char == old.form.as.char) "naked formula is the same\n" # e.g. O3~vh+wind else "naked formula is %s\n", form.as.char) } 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) } form } # Given a formula (as string), return a string with the "naked" predictors. # # Example: log(y) ~ x9 + ns(x2,4) + s(x3,x4,df=4) + x5:sqrt(x6) # becomes: log(y) ~ x9 + x2 + x3 + x4 + x5 + x6 (but with no spaces) # 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 should be replaced with something that uses the parse tree. # # TODO this sometimes returns a string with "++" in it naken.formula.string <- function(form.as.char) { stopifnot(is.character(form.as.char)) form.as.char <- strip.space(paste.collapse(form.as.char)) args <- gsub(".*~", "", form.as.char) # extract everything after ~ args <- naken(args) response <- "" if(grepl("~", form.as.char)) { response <- gsub("~.*", "", form.as.char) # extract up to the ~ if(nchar(response)) response <- paste0(strip.space(response), "~") } strip.space(paste.collapse(response, args)) } naken <- function(s) # e.g. "s(x3,x4,df=4)" becomes "x3+x4" { s <- paste.collapse(strip.space(s)) # We don't want to mess with anything in [square brackets]. # So we replace the bracketed expression with "#BRACKETS#", # and then replace that back again at the end. # Needed for e.g. lm(trees[,3]~trees[,1:2]) brackets <- replace.brackets("\\[.*\\]", "#BRACKETS#", s) s <- brackets$s 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) if(grepl("[._$[:alnum:]]*[(]", s)) { s <- gsub("[._$[:alnum:]]*[(]", "", 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="+") sub("#BRACKETS#", brackets$brackets, s) # change #BRACKETS# back to what it was } replace.brackets <- function(pattern, place.holder, s) # utility for naken { brackets <- "" i <- regexpr(pattern, s) if(i > 0) { last <- i + attr(i,"match.length") - 1 stopifnot(last > i) brackets <- substr(s, i, last) # remember the bracketed expression s <- paste0(substr(s, 1, i-1), place.holder, substring(s, last+1)) # replace [.*] with #BRACKETS# } return(list(s=s, brackets=brackets)) } 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(colname) } naked } # Return an err msg if colnames(x) is not "naked". # Return NULL if everything is ok. # # Example: # object$x, object$data, and object$model have # colnames like "poly(Height, degree = 3)1" # for lm(Volume~poly(Height, degree=3), data=trees, x=T) 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) } msg <- sprint( "%s variable on the %s side of the formula is a matrix or data.frame", 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(object)[1]) } 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.R0000644000176200001440000000344013304032663012522 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(object)[1]) 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(object)[1]) 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(object)[1]) list(bx=bx, icolumns=icolumns) } plotmo/R/check.index.R0000644000176200001440000001720313451731471014304 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.col.index, 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 check.character.index <- function(index, index.name, object, names, len, is.col.index, # 0=row index, 1=col index, 2=exact non-regex col name if char allow.empty, is.degree.spec) { stopifnot(is.character(index)) is.col.index <- check.integer.scalar(is.col.index, min=0, max=2) # certain regular expressions match everything, even if names not avail if(is.col.index != 2 && length(index) == 1 && index %in% c("", ".", ".*")) return(1:len) if(is.col.index && 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] igrep <- if(is.col.index == 2) { # exact match, not a regular exp? if(nchar(name) == 0) warning0(unquote(index.name), "[", i, "] is an empty string \"\"") which(name == names) } else grep(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 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.R0000644000176200001440000004525013554637564013066 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 allowed 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(object)[1]), 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))) { 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))) { 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, err.msg.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=TRUE, 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.R0000644000176200001440000000407613462166643013411 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.R0000644000176200001440000003002013504733612014433 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=TeachingDemos::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.R0000644000176200001440000001724113440633272012707 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.R0000644000176200001440000001702113462162014013554 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. 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(object)[1]) else { trace2(trace, "formula(object) returned %s\n", strip.space(format(formula))) # Note that formula() returns a formula with "." expanded. # After as.character: [1] is "~", [2] is lhs, and [3] is rhs form <- as.character(formula(object))[3] # rhs of formula if(grepl("\\-", form)) { # "-" in formula? # formula() gives "(Girth + Height)-Height" for Volume~.-Height form <- sub("\\-.*", "", form) # delete "-" and all after form <- gsub("\\(|\\)", "", form) # delete ( and ) } formula.vars <- unlist(strsplit(form, "+", fixed=TRUE)) formula.vars <- strip.space(formula.vars) 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(object)[1]) 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)) } 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. # # TODO this would probably be done best by processing the parse tree 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), "\n") trace2(trace, "pred.names: %s\n", quotify.trunc(pred.names), "\n") pairs <- matrix(0, nrow=0, ncol=2) # no pairs initially for(i in 1:length(term.labels)) { 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.R0000644000176200001440000002700113440633316013516 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.R0000644000176200001440000001651113504766104013410 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.R0000644000176200001440000002416013424400663013042 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]]) && !isDate(u1) && 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") names(xgrid) <- pred.names xgrid <- as.data.frame(xgrid) 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.R0000644000176200001440000001317413304032663013436 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.R0000644000176200001440000006705013440632600014001 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.", "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.R0000644000176200001440000001417113405342460012707 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/MD50000644000176200001440000002055513555402522012106 0ustar liggesuserseb3272eabfc38e97bc2c8d750856ce84 *DESCRIPTION 62273e778a297164bf456f9da0f88699 *NAMESPACE 67d8611e1ef4ecabe1a51dbab64a34bd *NEWS 1b32f707cff45fa442f5bcac644aa921 *R/as.char.R 8dc3262f5fd5deeb14f6c7c1adccd968 *R/bx.R e38eae1405c96db98492d25a0b9abfc5 *R/c50.R a8a382411b4193cd470e8b26448ad179 *R/call.dots.R c5b115d625f22ad26c7b4445b4521d5e *R/caret.R 603fad4b5796d460ea897428e7510be4 *R/check.index.R 46e84213d0eb9d5fe9ff59d183266ffd *R/do.par.R 3c28173aa59055555bf5ed7079e0f51b *R/dot.R 4c6d18adedd8fc8f8b00d7e83aa5f53b *R/dotlib.R 861fba8a34b68a1dd39a3e0f62ab7f14 *R/elegend.R fc659fa5f851f0df094c0bb5534ac32d *R/fitted.R c349f1cba5091dadeeb4c716caf4bb1e *R/gbm.R bd0084551926aeb1ff4bada9b67cbb22 *R/gbm.backcompat.R 5172a61a9d181a16591b6a93942b1aca *R/glmnet.R 1765be5ac38e47763a8f87ee40c9a78d *R/grid.R b31ecdd78e23a172da7be1567c8921fe *R/grid.func.R 0e0ab780975f24288aa94236ebddef6f *R/lib.R 25bb7fab3ad77cfecc41e9f696919e50 *R/meta.R 3ba4894d247eef152076d87cf92acb56 *R/methods.R 004839b1e52cb50638840b2635bba62b *R/mlr.R 6f52870d57875b89b4307c37b92d1f7b *R/partdep.R e66354831eed299a9fc3edbc084e4d0b *R/partykit.R 5563b2962c911f7a3f3752307eefc29f *R/pint.R a81e0cfe91e3e67dd369f3fd8abf8455 *R/plot_gbm.R b12f91ade0b6af39f213e19257475088 *R/plot_glmnet.R a17d1cc6b2d82145e27e308bc6f11b2e *R/plotcum.R c6eaeb8ce78ccbb0ed56014fb3ceb98c *R/plotmo.R df1786a88b8cd00b6b956c8258ca906c *R/plotqq.R d5e3d290de627c4451b4a75f4fab8640 *R/plotres.R 2d1c3f76e51cb52b9d162ada26bc2b98 *R/plotresids.R 437bc692cd0c566359d997e6e5105cb1 *R/pre.R 703e1b62858fe9bb4975b66d49d55b97 *R/predict.R bdf8896a82a46f9c2097e337c0f4a217 *R/predict.nn.R a7cfa01bdb6be6069eeed7f427df35ee *R/printcall.R d4d8b2b318c51c581f0d5d4cc50ec4dc *R/prolog.R 54dfa8ee78967bfd14bfe08adcef43cb *R/quantreg.R b02994e24cdf5ff52578a4a750054e8c *R/residuals.R cd86d41f993231db05976d5873f69d36 *R/response.R 9dd8f0a7e56fda7f21bb776f7486bb07 *R/rpart.R dc4d6fc38bd01fd9391ccc13d7adbabb *R/singles.R a556d185d5c55facadd00539ab77433c *R/stop.if.dots.R 44ea2e5b6c9007054bdc1c14658b52c8 *R/type.R 633ca35ebb5bcdd1e634a9fc4360f942 *R/w1.R 56f3cb29e97b0e21d67feaea1bdfb896 *R/xgboost.R c831ba3c9bc7f1eaaac2bccd6f59425f *R/xy.R fcd452ea1937a9ecf4c87e34f29cdb13 *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 90c9eea38a834007c5e7cb152ed83efa *inst/doc/modguide.pdf cd6d59ab5561e1e317a2a1496cee032b *inst/doc/plotmo-notes.pdf aac7ed2d455e5e54353ea7592e98805a *inst/doc/plotres-notes.pdf 9e35189fa10d4674f2284552fcbbfe64 *inst/slowtests/README.txt c244382fafdbd194c3e2b67f096f66ae *inst/slowtests/linmod.R 42c25d22bd1996d34193935c602afef7 *inst/slowtests/linmod.methods.R 72d2ea19f32d670c448703471b187346 *inst/slowtests/make.README.R f89c7b2fb22300d941492dd41e0be1d2 *inst/slowtests/make.README.bat 07d625248e3a7c2bcd017771e0b84eb4 *inst/slowtests/make.README.figs.R a8c34610c31cc4130bdca68135e5011b *inst/slowtests/make.bat c5bf9446a0eeb97275ad7a7e61ed86b4 *inst/slowtests/modguide.model1.R 08fe3d6be516a61bf72da88502c184c2 *inst/slowtests/modguide.model2.R c2ddbbb20a0c65ef2ccd60de7523d92d *inst/slowtests/test.c50.R 81673320767dd608d41171c5678385c5 *inst/slowtests/test.c50.Rout.save a49a32b780a9566c1452aef7766377de *inst/slowtests/test.c50.bat 742380b7471caee92b4418a5ba94fc1e *inst/slowtests/test.caret.R 9625c8a0a0dec16defe96dd088014cdf *inst/slowtests/test.caret.Rout.save 9de7e464139943aa7acb3b6d9f285c70 *inst/slowtests/test.caret.bat 08890c43763882c3f9c60f1e4db81d23 *inst/slowtests/test.center.R b80585f497c8e41f5720dc538014f495 *inst/slowtests/test.center.Rout.save dc3588fddcac263cb363835f732a5113 *inst/slowtests/test.center.bat e95f02c639e24975dc755b57b740042a *inst/slowtests/test.degree.R acbb7208a491e97b170d26b707c6a889 *inst/slowtests/test.degree.Rout.save 6048355819acad4159898158df2d22da *inst/slowtests/test.degree.bat 9560837bec5e854fa4c622d2744b5f15 *inst/slowtests/test.dots.R 70ea8e42501d122ab53d8da3b10160c8 *inst/slowtests/test.dots.Rout.save 721a8dcf2bb5d00c7698299ef695e5b5 *inst/slowtests/test.dots.bat 95882ca0307f52411bb6a1477edc5de5 *inst/slowtests/test.emma.R 4d86ae388b14b2868dc4f15a39fb62a1 *inst/slowtests/test.emma.Rout.save de87f88e08d6eb664182115e82000ae5 *inst/slowtests/test.emma.bat 7306baea0c61d656121cd743183c8172 *inst/slowtests/test.epilog.R d8dd1aa1fdfd8a908d1d568d5646da4f *inst/slowtests/test.fac.R a4a1f1e9323e339d4c7f72efb284d46b *inst/slowtests/test.fac.Rout.save a8fc621b267ec7d759e4eef1fa84fa03 *inst/slowtests/test.fac.bat 8b25091cc695a622e255a168f6ad9a5a *inst/slowtests/test.gbm.R e213292dc4b4da63d230686dd4bfb57a *inst/slowtests/test.gbm.Rout.save b6f536a79e5371edf53edc004a3236c0 *inst/slowtests/test.gbm.bat 3fb6cb7dc7719a4cdfa0162f5d25ad00 *inst/slowtests/test.glmnet.R bbad51ae3cc496f278623e4fa4116b28 *inst/slowtests/test.glmnet.Rout.save 898c9bc715915d405f62a2cece0d111f *inst/slowtests/test.glmnet.bat 0298289d03b9702637ce8298ddacabde *inst/slowtests/test.glmnetUtils.R e2dce66e98a72a0d114793340360d9f4 *inst/slowtests/test.glmnetUtils.Rout.save cca8a236a278039e4754f75756eed8d0 *inst/slowtests/test.glmnetUtils.bat 9175cc9b6f23554c5dc2a610992521f3 *inst/slowtests/test.linmod.R bfebad2742a21c9a569bb26dbb4e6188 *inst/slowtests/test.linmod.Rout.save 6532b72c3d6f8ae960eb6cbf0b13b669 *inst/slowtests/test.linmod.bat 1b44ef5359097c2072e4fe3cfcf6e432 *inst/slowtests/test.mlr.R a10693bf236b7d3ac9d9993548408cfd *inst/slowtests/test.mlr.Rout.save 9d7b1bf6560ef9da877deb0753ec5a76 *inst/slowtests/test.mlr.bat a121b7276e80faf4206b7c7e6427b246 *inst/slowtests/test.modguide.R 377ee026a5852da1ce3182c5a59cde3d *inst/slowtests/test.modguide.Rout.save e2293029533ada7f1803f4e8df22c8a2 *inst/slowtests/test.modguide.bat cdc383cbe648420ed2c360755ceff3e3 *inst/slowtests/test.non.earth.R 0a83981fdaaa273c3e9a854320f547e4 *inst/slowtests/test.non.earth.Rout.save ba87654b3c0d2b0cd2cd28167b49b702 *inst/slowtests/test.non.earth.bat a09cfa697b83844954ef7f553f5b8e11 *inst/slowtests/test.partdep.R 852d4cf5e5e07c3bc8124b5eb0c294b8 *inst/slowtests/test.partdep.Rout.save 0e6289400f4eade11aba6b0798aa6505 *inst/slowtests/test.partdep.bat e7b4ddac909472912a9e8328be7f94b4 *inst/slowtests/test.partykit.R 6cb577c828b714dcff6ffb6c88d414c3 *inst/slowtests/test.partykit.Rout.save c3fe2b98c6542b3e05e7f84d44c4a50f *inst/slowtests/test.partykit.bat c5e859e9f208795d0a7a3151192491d9 *inst/slowtests/test.plotmo.R 7a41720e124b347e0046cb53ed3bae2c *inst/slowtests/test.plotmo.Rout.save d6f780c4d9cbe3b5ad3b4d8ea6ebcf5d *inst/slowtests/test.plotmo.args.R a28cb9eaede9c7c527afbe451950ebcb *inst/slowtests/test.plotmo.args.Rout.save 21d24bb63757180999c0b3f496405c21 *inst/slowtests/test.plotmo.args.bat 58b1fb7ad47f54c2e82f09cfbb58f8ef *inst/slowtests/test.plotmo.bat 465214a6f9cdad37371bf71339064f17 *inst/slowtests/test.plotmo.dots.R 1d188ad39a94bb8e8156cb04524eabdc *inst/slowtests/test.plotmo.dots.Rout.save 401cb8d312a54f6143c9a06e7e31d371 *inst/slowtests/test.plotmo.dots.bat 3db79f76ebc47ddf2bb0034a6dae04b5 *inst/slowtests/test.plotmo.x.R a0f757bd700b1a7ed59d894f0a2ed223 *inst/slowtests/test.plotmo.x.Rout.save aa7a64265ea83ef5e35c367a8a8060f7 *inst/slowtests/test.plotmo.x.bat e100a67301cf88d3763c66ea79c72ea2 *inst/slowtests/test.plotmo3.R bf34dec9e6a4e992a47478ab526903a6 *inst/slowtests/test.plotmo3.Rout.save 308bdd88c79f6bad2d9944556c42ddc3 *inst/slowtests/test.plotmo3.bat 07a4106136c30e4487bf904a619e4264 *inst/slowtests/test.plotres.R 36951152af67f1eb1b81b8d0dd0d4190 *inst/slowtests/test.plotres.Rout.save e3e68656e209f77f1c7a91a5187b5309 *inst/slowtests/test.plotres.bat 9f36e306d2bf52ebbb260a966e988a74 *inst/slowtests/test.pre.R 8e43e37510c2a357e45f68f705c8c176 *inst/slowtests/test.pre.Rout.save 05bac77db4315533c1bd63653794f89a *inst/slowtests/test.pre.bat 6e1bdddcf2d7ae571462722b81db918e *inst/slowtests/test.printcall.R 58ea024dd0b7e15fa2291756547512a2 *inst/slowtests/test.printcall.Rout.save f7df7c1228db203ef5ea4eab5922cfe3 *inst/slowtests/test.printcall.bat 66ce05be66fb1d7bf00df61d6cfc1bde *inst/slowtests/test.prolog.R 97f4b1936b2d0a85e0d0e4c6e8717dfa *man/plot_gbm.Rd dcc94dda3dcbf37fa5dcec9799a52bcc *man/plot_glmnet.Rd 0edc604d9bf4a8f0afc744656fed4e6b *man/plotmo.Rd 751ab8af1d939886b1a97fb7381b6991 *man/plotmo.misc.Rd 7015c263000f0c68c97afca760fced54 *man/plotres.Rd 3ac7804a66f1f72eabc7d38afc3d4565 *tests/test.plotmo.R 894653fa2210a605b1ddb1ae0b07dbf0 *tests/test.plotmo.Rout.save plotmo/inst/0000755000176200001440000000000013276021276012547 5ustar liggesusersplotmo/inst/README-figures/0000755000176200001440000000000013275637223015152 5ustar liggesusersplotmo/inst/README-figures/plotres-randomForest.png0000644000176200001440000002376213304017674022016 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.png0000644000176200001440000002607213276114300021371 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.png0000644000176200001440000004724613276533451021647 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/0000755000176200001440000000000013555374221014617 5ustar liggesusersplotmo/inst/slowtests/test.glmnet.R0000644000176200001440000004564313554112136017214 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 old.par <- par(no.readonly=TRUE) 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(old.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 old.par <- par(no.readonly=TRUE) 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(old.par) # test w1 and non w1 args passed old.par <- par(no.readonly=TRUE) 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(old.par) old.par <- par(no.readonly=TRUE) 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(old.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) old.par <- par(no.readonly=TRUE) 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(old.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") old.par <- par(no.readonly=TRUE) 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(old.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)) old.par <- par(no.readonly=TRUE) 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(old.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") old.par <- par(no.readonly=TRUE) 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(old.par) # compare to earth old.par <- par(no.readonly=TRUE) 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(old.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") old.par <- par(no.readonly=TRUE) 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(old.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(old.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") 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") plotmo(glmnet.mgaussian, nresponse=1, SHOWCALL=TRUE) plotmo(glmnet.mgaussian, nresponse=2, SHOWCALL=TRUE) old.par <- par(no.readonly=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(old.par) old.par <- par(no.readonly=TRUE) 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(old.par) old.par <- par(no.readonly=TRUE) 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(old.par) old.par <- par(no.readonly=TRUE) 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(old.par) old.par <- par(no.readonly=TRUE) 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(old.par) #-- make sure that we can work with all families set.seed(2016) old.par <- par(no.readonly=TRUE) 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(old.par) # test col argument old.par <- par(no.readonly=TRUE) 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(old.par) source("test.epilog.R") plotmo/inst/slowtests/test.prolog.R0000644000176200001440000000310413403045157017213 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") { msg <- attr(object, "condition")$message[1] if(length(grep(expected.msg, msg, fixed=TRUE))) cat0("Got error as expected from ", deparse(substitute(object)), "\n") else stop(sprint("Expected: %s\n Got: %s", expected.msg, substr(msg[1], 1, 1000))) } else stop("Did not get expected error: ", expected.msg) } 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") old.par <- par(no.readonly=TRUE) set.seed(2018) plotmo/inst/slowtests/test.glmnet.Rout.save0000644000176200001440000013435413554714126020706 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 Loading required package: TeachingDemos > library(glmnet) Loading required package: Matrix Loaded glmnet 3.0 > 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 > old.par <- par(no.readonly=TRUE) > 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(old.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, ...) object call is cv.glmnet(x=xmat, y=tit[, 4], nfolds=3) --get.model.env for cv.glmnet object 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 terms.default(object) : 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, ...) object call is cv.glmnet(x=xmat, y=tit[, 4], nfolds=3) --get.model.env for cv.glmnet object 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, ...) object call is cv.glmnet(x=xmat, y=tit[, 4], nfolds=3) --get.model.env for cv.glmnet object using attr(object,".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 > old.par <- par(no.readonly=TRUE) > 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(old.par) > > # test w1 and non w1 args passed > old.par <- par(no.readonly=TRUE) > 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(old.par) > old.par <- par(no.readonly=TRUE) > 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(old.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) > > old.par <- par(no.readonly=TRUE) > 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(old.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") > old.par <- par(no.readonly=TRUE) > 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(old.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)) > > old.par <- par(no.readonly=TRUE) > 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(old.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]], 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 error as expected from try(plotres(glmnet, w1.col = nonesuch)) > > printf("======== glmnet multinomial (multnet)\n") ======== glmnet multinomial (multnet) > old.par <- par(no.readonly=TRUE) > 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 Fortran 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(old.par) > > # compare to earth > old.par <- par(no.readonly=TRUE) > 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(old.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") > old.par <- par(no.readonly=TRUE) > 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(old.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(old.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") > 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") > 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 > > old.par <- par(no.readonly=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(old.par) > old.par <- par(no.readonly=TRUE) > 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(old.par) > old.par <- par(no.readonly=TRUE) > 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(old.par) > old.par <- par(no.readonly=TRUE) > 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(old.par) > old.par <- par(no.readonly=TRUE) > 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(old.par) > > #-- make sure that we can work with all families > > set.seed(2016) > old.par <- par(no.readonly=TRUE) > 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(old.par) > > # test col argument > old.par <- par(no.readonly=TRUE) > 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(old.par) > > source("test.epilog.R") plotmo/inst/slowtests/test.modguide.bat0000755000176200001440000000154713514230363020065 0ustar liggesusers@rem test.modguide.bat: test model1 and model2 (linmod examples) in modguide.pdf @echo test.modguide.bat @"C:\PROGRA~1\R\R-3.6.1\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/test.plotmo3.R0000644000176200001440000005200313554115065017313 0ustar liggesusers# test.plotmo3.R: extra tests for plotmo version 3 and higher source("test.prolog.R") library(earth) data(ozone1) data(etitanic) check.naken <- function(s, expected) { nude <- plotmo:::naken.formula.string(s) printf("%-60.60s %-s\n", s, nude) stopifnot(nude == expected) } printf("=== checking naken.formula.string\n") check.naken("y ~ x1 : x2 + x3", "y~x1+x2+x3") check.naken("y ~ x1 + x2 - x3", "y~x1+x2+x3") check.naken("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") 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") 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]") check.naken("Salary~Hitters[,-1]", "Salary~Hitters[,-1]") check.naken("Salary~Hitters[,c(1,2)]", "Salary~Hitters[,c(1,2)]") check.naken("Salary~Hitters[,1:2]", "Salary~Hitters[,1:2]") check.naken("Salary~Hitters[,c(1,2)]", "Salary~Hitters[,c(1,2)]") 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 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.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() mod.lm.age <- lm(age~., data=tit) plotmo1(mod.lm.age) plotmo1(mod.lm.age, level=.95) plotmo1(mod.lm.age, level=.95, col.resp=3) sexn <- as.numeric(tit$sex) mod.lm.sexn <- lm(sexn~.-sex, data=tit) plotmo1(mod.lm.sexn) plotmo1(mod.lm.sexn, level=.95) mod.earth.age <- earth(age~., data=tit, degree=2, nfold=3, ncross=3, varmod.method="lm") plotmo1(mod.earth.age) plotmo1(mod.earth.age, level=.9, degree2=0) # tit[,4] is age mod.earth.tit <- earth(tit[,-4], tit[,4], degree=2, nfold=3, ncross=3, varmod.method="lm") plotmo1(mod.earth.tit) plotmo1(mod.earth.tit, level=.9, degree2=0) a.earth.sex <- earth(sex~., data=tit, 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") # tit[,3] is sex mod.earth.tit <- earth(tit[,-3], tit[,3], degree=2, nfold=3, ncross=3, varmod.method="lm") plotmo1(mod.earth.tit) plotmo1(mod.earth.tit, level=.9, degree2=0) plotmo1(mod.earth.tit, type="class") expect.err(try(plotmo1(mod.earth.tit, level=.9, degree2=0, type="class")), "predicted values are strings") mod.earth.sex <- earth(sex~., data=tit, 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") # tit[,3] is sex mod.earth.tit <- earth(tit[,-3], tit[,3], degree=2, nfold=3, ncross=3, varmod.method="earth", glm=list(family=binomial)) plotmo1(mod.earth.tit) plotmo1(mod.earth.tit, type="link") plotmo1(mod.earth.tit, type="class") plotmo1(mod.earth.tit, level=.9, type="earth") # check factor handling when factors are not ordered alphabetically tit.orgpclass <- etitanic[seq(1, nrow(etitanic), by=12), ] tit <- get.tit() tit$logage <- NULL tit.orgpclass$parch <- NULL stopifnot(names(tit.orgpclass) == names(tit)) a.tit.orgpclass <- earth(pclass~., degree=2, data=tit.orgpclass) a.tit <- earth(pclass~., degree=2, data=tit) old.warn <- options(warn=2) # treat warnings as errors expect.err(try(plotmo(a.tit)), "Defaulting to nresponse=1, see above messages") options(warn=old.warn$warn) # following two graphs should be identical plotmo1(a.tit.orgpclass, nresponse="1st", all1=T, col.resp=3, type2="im") plotmo1(a.tit, nresponse="first", all1=T, col.resp=3, type2="im") # following two graphs should be identical plotmo1(a.tit.orgpclass, nresponse="2nd", all1=T) plotmo1(a.tit, nresponse="class2", all1=T) tit <- get.tit() mod.earth.pclass <- earth(pclass~., data=tit, degree=2) old.warn <- options(warn=2) # treat warnings as errors expect.err(try(plotmo1(mod.earth.pclass)), "Defaulting to nresponse=1, see above messages") options(warn=old.warn$warn) 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(tit$pclass)+1, pt.pch=1) # tit[,1] is pclass mod.earth.tit <- earth(tit[,-1], tit[,1], degree=2) old.warn <- options(warn=2) # treat warnings as errors expect.err(try(plotmo1(mod.earth.tit)), "Defaulting to nresponse=1, see above messages") options(warn=old.warn$warn) plotmo1(mod.earth.tit, nresponse="first") plotmo1(mod.earth.tit, type="class") mod.earth.pclass2 <- earth(pclass~., data=tit, 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") # tit[,1] is pclass mod.earth.tit <- earth(tit[,-1], tit[,1], degree=2, glm=list(family=binomial)) plotmo1(mod.earth.tit, nresponse=3) plotmo1(mod.earth.tit, type="link", nresponse=3) plotmo1(mod.earth.tit, 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)), "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 tit <- get.tit() mod.glm.sex <- glm(sex~., data=tit, family=binomial) plotmo1(mod.glm.sex, pt.col=as.numeric(tit$pclass)+1) # tit[,4] is age, tit[,1] is pclass printf("library(lars)\n") library(lars) set.seed(2015) xmat <- as.matrix(tit[,c(2,5,6)]) mod.lars.xmat <- lars(xmat, tit[,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,tit[,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 old.warn <- options("warn") options(warn=2) data(gasoline, package="pls") earth.octane <- earth(octane ~ NIR, data=gasoline) expect.err(try(plotmo(earth.octane)), "the variable on the right side of the formula is a matrix or data.frame") library(ElemStatLearn) x <- mixture.example$x g <- mixture.example$y lm.mixture.example <- lm(g ~ x) expect.err(try(plotmo(lm.mixture.example)), "the variable on the right side of the formula is a matrix or data.frame") options(warn=old.warn$warn) # 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 ------------------------------------- old.par <- par(no.readonly=TRUE) 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(old.par) old.par <- par(no.readonly=TRUE) 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(old.par) source("test.epilog.R") plotmo/inst/slowtests/test.fac.bat0000755000176200001440000000154213514230362017013 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-3.6.1\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.save0000644000176200001440000003567313514232742021107 0ustar liggesusers> # test.plotres.R > > source("test.prolog.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix Loading required package: TeachingDemos > 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) > plotres(elm, col=survived+2, SHOWCALL=TRUE) > plotres(elm, col=survived+2, col.rsq="darkorange", lty.rsq=1, 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 > 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) > emulti <- earth(cbind(Volume, Volume + 100 + 5 * rnorm(nrow(trees)))~., 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+logage, 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+logage, 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.16.1 > 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) Warning in model.matrix.default(mt, mf, contrasts) : non-list contrasts argument ignored > 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) Warning in model.matrix.default(mt, mf, contrasts) : non-list contrasts argument ignored > plotres(gam.linear.humidity.only, versus="b:", SHOWCALL=TRUE) > > library(mda) Loading required package: class Loaded mda 0.4-10 > 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.degree.R0000644000176200001440000001046513430131510017141 0ustar liggesusers# test.pre.R: test the "pre" package with plotmo and plotres 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 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=2) # treat warnings as errors plotmo(a81) # degree1 tests old.par <- par(no.readonly=TRUE) 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") expect.err(try(plotmo(a81, do.par=FALSE, degree1="survived", degree2=0)), '"survived" in degree1 does not match any names') 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(old.par) # degree2 tests old.par <- par(no.readonly=TRUE) 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")') expect.err(try(plotmo(a81, do.par=FALSE, degree1=0, degree2=c("pclass", "nonesuch"))), "\"nonesuch\" in degree2 does not match any names") expect.err(try(plotmo(a81, do.par=FALSE, degree1=0, degree2=c("nonesuch1", "nonesuch2"))), "\"nonesuch1\" in degree2 does not match any names") expect.err(try(plotmo(a81, do.par=FALSE, degree1=0, degree2=c("nonesuch", "pclass"))), "\"nonesuch\" in degree2 does not match any names") par(old.par) old.par <- par(no.readonly=TRUE) options(warn=1) # print warnings as they occur 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(old.par) source("test.epilog.R") plotmo/inst/slowtests/test.c50.bat0000755000176200001440000000142313514230362016647 0ustar liggesusers@rem test.c50.bat: c50 tests for plotmo and plotres @echo test.c50.bat @"C:\PROGRA~1\R\R-3.6.1\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.R0000644000176200001440000002510113530362056016217 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") # The code below preempts code in model.frame that issues # Warning: 'newdata' had M rows but variables found have N rows # This code gives a clearer error message. # The var names check is necessary else model.frame can return bad data. varnames <- names(dataClasses) varnames <- varnames[-attr(terms, "response")] missing <- which(!(varnames %in% colnames(newdata))) if(length(missing)) stop("variable '", varnames[missing[1]], "' is missing from newdata") 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)) # paranoia, shouldn't be needed stop("newdata has ", NROW(newdata), " rows but model.frame returned ", NROW(mf), " rows") .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.save0000644000176200001440000002400013443071772021372 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 Loading required package: TeachingDemos > 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.bat0000755000176200001440000000160113514230363020524 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-3.6.1\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.emma.R0000644000176200001440000000110613315504534016631 0ustar liggesusers# test.emma.R: regression tests for emma with plotmo # Stephen Milborrow, Shrewsbury Nov 2014 source("test.prolog.R") print(R.version.string) library(emma) print(citation("emma")) in.name <- c("x1","x2") nlev <- c(10, 10) lower <- c(-2.048, -2.048) upper <- c(2.048, 2.048) out.name <- "y" weight <- 1 C <- 3 pr.mut <- c(0.1, 0.07, 0.04, rep(0.01, C-3)) emma(in.name, nlev, lower, upper, out.name, opt = "mn", nd = 8, na = 5, weight, C , w1 = 0.7, w2 = 0.4, c1i = 2.5, c1f = 0.5, c2i = 0.5, c2f = 2.5, b = 5, pr.mut, graph = "yes", fn1 = ackley) source("test.epilog.R") plotmo/inst/slowtests/test.linmod.R0000644000176200001440000016624513444566511017222 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=2) # treat warnings as errors 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 numeric 'envir' arg not of length one 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))), "variable 'Height' is missing from newdata") expect.err(try(predict(linmod.form.Volume.tr, newdata=c(8.3, 70))), "variable 'Girth' is missing from newdata") 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) == "matrix") print(head(linmod.xy.keep$y)) stopifnot(dim(linmod.xy.keep$y) == c(nrow(trees), 1)) stopifnot(class(linmod.xy.keep$y) == "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) == "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) == "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 different 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])), "numeric 'envir' arg not of length one") # following checks that predict.linmod gives better error messages than predict.lm 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)), "variable 'Girth' is missing from newdata") colnames(newdata) <- c("Girth", "Height99", "Volume") expect.err(try(predict(linmod.form.Volume.tr, newdata=newdata)), "variable 'Height' is missing from newdata") 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 different 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) using type = \"numeric\" with a factor response will be ignored") # 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("==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) old.par <- par(no.readonly=TRUE) old.par <- par(no.readonly=TRUE) 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(old.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'") 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])), "variable 's' is missing from newdata") expect.err(try(predict(a41, newdata=data6[1:3,c(1,1)])), "variable 'num' is missing from newdata") 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)), "variable 's' is missing from newdata") 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 = linmod)") expect.err(try(summary(linmod(trees[,1:2], trees[,3]), nonesuch=linmod)), "unused argument (nonesuch = linmod)") expect.err(try(print(linmod(trees[,1:2], trees[,3]), nonesuch=linmod)), "unused argument (nonesuch = linmod)") 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 one of \"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))) old.par <- par(no.readonly=TRUE) 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(old.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]) old.par <- par(no.readonly=TRUE) par(mfrow=c(2,2)) plot(linmod.onepred.form) plot(lm.onepred.form, which=1, main="lm.onepred.form") plot(linmod.onepred.xy) par(old.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)), "variable 'Girth' is missing from newdata") 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"])), "variable 'Girth' is missing from newdata") # 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)))) old.par <- par(no.readonly=TRUE) par(mfrow=c(2,2)) plot(linmod.noint) plot(lm.noint, which=1, main="lm.noint") par(old.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)), "variable 'Girth' is missing from newdata") 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"])), "variable 'Girth' is missing from newdata") # 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)))) old.par <- par(no.readonly=TRUE) par(mfrow=c(2,2)) plot(linmod.onepred.noint) plot(lm.onepred.noint, which=1, main="lm.onepred.noint") par(old.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)])), "variable 'var297' is missing from newdata") 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 variable 'V1' is missing from newdata # 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 old.par <- par(no.readonly=TRUE) 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(old.par) cat0("==linmod.formula(keep=TRUE): change data used to build the model\n") old.par <- par(no.readonly=TRUE) 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(old.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 old.par <- par(no.readonly=TRUE) 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(old.par) cat0("==linmod.default(keep=TRUE): change data used to build the model\n") old.par <- par(no.readonly=TRUE) 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(old.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 } old.par <- par(no.readonly=TRUE) 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(old.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.linmod.Rout.save0000644000176200001440000040044313444566632020702 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=2) # treat warnings as errors > > 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 error as expected 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 error as expected 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 numeric 'envir' arg not of length one 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 error as expected 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))), "variable 'Height' is missing from newdata") Error in process.newdata.formula(object, newdata) : variable 'Height' is missing from newdata Got error as expected 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))), "variable 'Girth' is missing from newdata") Error in process.newdata.formula(object, newdata) : variable 'Girth' is missing from newdata Got error as expected 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 error as expected 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 error as expected 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 Loading required package: TeachingDemos > 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) == "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) == "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) == "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) == "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 different numeric args\n") ==test model building with different 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 error as expected 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 error as expected 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)=matrix 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 error as expected from try(predict(lm1, newdata = trees[3:5, 1, drop = FALSE])) > expect.err(try(predict(lm1, newdata=trees[3:5,1,drop=TRUE])), + "numeric 'envir' arg not of length one") Error in eval(predvars, data, env) : numeric 'envir' arg not of length one Got error as expected from try(predict(lm1, newdata = trees[3:5, 1, drop = TRUE])) > > # following checks that predict.linmod gives better error messages than predict.lm > expect.err(try(predict(linmod.y1.x1, newdata=trees[3:5,1,drop=FALSE])), + "variable 'x1' is missing from newdata") Error in process.newdata.formula(object, newdata) : variable 'x1' is missing from newdata Got error as expected 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 error as expected 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])), + "variable 'x1' is missing from newdata") Error in process.newdata.formula(object, newdata) : variable 'x1' is missing from newdata Got error as expected from try(predict(linmod.y1.x1, newdata = trees[3:5, 1, drop = TRUE])) > > 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)), + "variable 'Girth' is missing from newdata") Error in process.newdata.formula(object, newdata) : variable 'Girth' is missing from newdata Got error as expected 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)), + "variable 'Height' is missing from newdata") Error in process.newdata.formula(object, newdata) : variable 'Height' is missing from newdata Got error as expected 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 different non numeric args\n") ==test model building with different 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected from try(linmod(response ~ ., data = data.string.response)) > # lm.formula > expect.err(try(lm(response~., data=data.string.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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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("==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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 NA NA NA x1 -0.05212 NA NA NA x2 -0.82339 NA NA NA 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 > > old.par <- par(no.readonly=TRUE) > old.par <- par(no.readonly=TRUE) > 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(old.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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected from try(linmod(x, y)) > > 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.191616e-15 1.2247449 -9.729507e-16 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 error as expected 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.191616e-15 1.2247449 -9.729507e-16 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])), "variable 's' is missing from newdata") Error in process.newdata.formula(object, newdata) : variable 's' is missing from newdata Got error as expected from try(predict(a41, newdata = data6[1:3, 1])) > expect.err(try(predict(a41, newdata=data6[1:3,c(1,1)])), "variable 'num' is missing from newdata") Error in process.newdata.formula(object, newdata) : variable 'num' is missing from newdata Got error as expected 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 error as expected from try(predict(a41, newdata = data.frame(s = 1, num = 2, y = 3))) > > expect.err(try(predict(a41, newdata=1:9)), + "variable 's' is missing from newdata") Error in process.newdata.formula(object, newdata) : variable 's' is missing from newdata Got error as expected 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 error as expected 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 NA NA NA sa9 3.6 NA NA NA sb -2.2 NA NA NA sc 0.8 NA NA NA num 0.4 NA NA NA 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected from try(linmod(Volume ~ ., data = trees, nonesuch = 99)) > expect.err(try(linmod(trees[,1:2], trees[,3], nonesuch=linmod)), "unused argument (nonesuch = linmod)") Error in stop.if.dot.arg.used(...) : unused argument (nonesuch = linmod) Got error as expected 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 = linmod)") Error in stop.if.dot.arg.used(...) : unused argument (nonesuch = linmod) Got error as expected 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 = linmod)") Error in stop.if.dot.arg.used(...) : unused argument (nonesuch = linmod) Got error as expected 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 error as expected 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 one of \"response\"") Error in match.arg(type, "response") : 'arg' should be one of "response" Got error as expected 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 error as expected 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 error as expected 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 error as expected from try(model.matrix(linmod.xy.Volume.tr)) > stopifnot(almost.equal(logLik(linmod.xy.Volume.tr), logLik(lm.Volume.tr))) > > old.par <- par(no.readonly=TRUE) > 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(old.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 > > old.par <- par(no.readonly=TRUE) > par(mfrow=c(2,2)) > plot(linmod.onepred.form) > plot(lm.onepred.form, which=1, main="lm.onepred.form") > plot(linmod.onepred.xy) > par(old.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)), "variable 'Girth' is missing from newdata") Error in process.newdata.formula(object, newdata) : variable 'Girth' is missing from newdata Got error as expected 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 error as expected 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 error as expected from try(predict(linmod.noint, newdata = trees[0, ])) > expect.err(try(predict(linmod.noint, newdata=trees[3:5,"Height"])), "variable 'Girth' is missing from newdata") Error in process.newdata.formula(object, newdata) : variable 'Girth' is missing from newdata Got error as expected 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)))) > > old.par <- par(no.readonly=TRUE) > par(mfrow=c(2,2)) > plot(linmod.noint) > plot(lm.noint, which=1, main="lm.noint") > par(old.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)), "variable 'Girth' is missing from newdata") Error in process.newdata.formula(object, newdata) : variable 'Girth' is missing from newdata Got error as expected 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 error as expected 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 error as expected from try(predict(linmod.onepred.noint, newdata = trees[0, 1])) > expect.err(try(predict(linmod.onepred.noint, newdata=trees[3:5,"Height"])), "variable 'Girth' is missing from newdata") Error in process.newdata.formula(object, newdata) : variable 'Girth' is missing from newdata Got error as expected 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)))) > > old.par <- par(no.readonly=TRUE) > par(mfrow=c(2,2)) > plot(linmod.onepred.noint) > plot(lm.onepred.noint, which=1, main="lm.onepred.noint") > par(old.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 error as expected 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 error as expected 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 error as expected 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)])), "variable 'var297' is missing from newdata") Error in process.newdata.formula(object, newdata) : variable 'var297' is missing from newdata Got error as expected 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)=matrix > 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 error as expected 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 error as expected 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 variable 'V1' is missing from newdata 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 > old.par <- par(no.readonly=TRUE) > 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected from try(plotmo(linmod2.trees1)) > > par(old.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 > old.par <- par(no.readonly=TRUE) > 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(old.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 > old.par <- par(no.readonly=TRUE) > 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 in plotmo(linmod2.x1) : object 'linmod2.x1' not found Got error as expected from try(plotmo(linmod2.x1)) > > par(old.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 > old.par <- par(no.readonly=TRUE) > 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(old.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 + } > old.par <- par(no.readonly=TRUE) > 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 error as expected from try(pr(linmod.xy)) > > linmod.xy.keep <- linmod.xy.func(keep=TRUE) > pr(linmod.xy.keep) > > par(old.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.save0000644000176200001440000001330113555142216020166 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 Loading required package: TeachingDemos > library(earth) # for ozone1 > 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 > > old.par <- par(no.readonly=TRUE) > 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(old.par) > > # compare pairplot and plotmo > > old.par <- par(no.readonly=TRUE) > par(mfrow=c(2,3)) # 6 plots per page > > pairplot(pre.mod, c("Temp", "Wind"), main="pairplot") Loading required namespace: akima NOTE: function pairplot uses package 'akima', which has an ACM license. See also https://www.acm.org/publications/policies/software-copyright-notice. > 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(old.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 error as expected 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.save0000644000176200001440000001512713437343026021656 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 Loading required package: TeachingDemos > data(ozone1) > > old.warn <- options("warn") > 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected from try(plotmo(a, lw = 2, trace = 1, thresh = 0.9, SHOWCALL = TRUE)) > > options(warn=old.warn$warn) > > # 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 > 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 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 > > source("test.epilog.R") plotmo/inst/slowtests/test.caret.bat0000755000176200001440000000152213514230362017356 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-3.6.1\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.R0000644000176200001440000000447613301574464017732 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.bat0000755000176200001440000000154513514230363017600 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-3.6.1\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.R0000644000176200001440000001251013451304512017555 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.bat0000755000176200001440000000151613514230363017661 0ustar liggesusers@rem test.plotmo3.bat: extra tests for plotmo version 3 and higher @echo test.plotmo3.bat @"C:\PROGRA~1\R\R-3.6.1\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.save0000644000176200001440000005412413443073056021206 0ustar liggesusers> # test.modguide.bat: test model1 and model2 (linmod examples) in modguide.pdf > > source("test.prolog.R") > 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 error as expected 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 error as expected from try(predict(fit1, newdata = as.matrix(tr[1:3, ]))) > library(plotmo) Loading required package: Formula Loading required package: plotrix Loading required package: TeachingDemos > 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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.txt0000644000176200001440000000114213306007333016302 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.bat0000755000176200001440000000154513514230362017545 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-3.6.1\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.save0000644000176200001440000005245113470064604021260 0ustar liggesusers> # test.partykit.R: test partykit and evtree packages > > source("test.prolog.R") > library(plotmo) Loading required package: Formula Loading required package: plotrix Loading required package: TeachingDemos > 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) object call is lmtree(formula=medv~log.lstat+rm.squared|crim+ptratio+tax+dis+...--get.model.env for lmtree object using the environment saved with 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+dis+rad+chas) 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... na.action(object) is "na.pass" stats::model.frame(medv~log.lstat+rm.squared+crim+ptrati..., 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+dis+rad+chas) 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... na.action(object) is "na.pass" stats::model.frame(medv~log.lstat+rm.squared+crim+ptrati..., 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+dis+rad+chas) 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... na.action(object) is "na.pass" stats::model.frame(medv~log.lstat+rm.squared+crim+ptrati..., 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+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... na.action(object) is "na.pass" stats::model.frame(medv~log.lstat+rm.squared+(crim+ptrat..., 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+ptrat..., 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+ptrat..., 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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.bat0000755000176200001440000000156113514230363020546 0ustar liggesusers@rem test.plotmo.dots.R: test handling of dots arguments @echo test.plotmo.dots.bat @"C:\PROGRA~1\R\R-3.6.1\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.R0000644000176200001440000007360113470064501016671 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\\.|^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") old.warn <- options("warn") 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=old.warn$warn) 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.R0000644000176200001440000000441213303407512017710 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.bat0000755000176200001440000000157313514230363020576 0ustar liggesusers@rem test.glmnetUtils.bat: glmnetUtils tests for plotmo and plotres @echo test.glmnetUtils.bat @"C:\PROGRA~1\R\R-3.6.1\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.R0000644000176200001440000001122613443743356017207 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.R0000644000176200001440000005252013443046705016470 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) old.par <- par(no.readonly=TRUE) 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(old.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 old.par <- par(no.readonly=TRUE) 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(old.par) old.par <- par(no.readonly=TRUE) 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(old.par) # test xlim and ylim old.par <- par(no.readonly=TRUE) 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(old.par) # test the smooth argument old.par <- par(no.readonly=TRUE) 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(old.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) old.par <- par(no.readonly=TRUE) 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(old.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) old.par <- par(no.readonly=TRUE) 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(old.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) # old.par <- par(no.readonly=TRUE) # 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(old.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) old.par <- par(no.readonly=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(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(old.par) old.par <- par(no.readonly=TRUE) plotmo(gbm.bernoulli, do.par=2) print(summary(gbm.bernoulli)) # will also plot par(old.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) old.par <- par(no.readonly=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(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(old.par) old.par <- par(no.readonly=TRUE) plotmo(gbm.huberized, do.par=2) print(summary(gbm.huberized)) # will also plot par(old.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) old.par <- par(no.readonly=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(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(old.par) old.par <- par(no.readonly=TRUE) plotmo(gbm.adaboost, do.par=2) print(summary(gbm.adaboost)) # will also plot par(old.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))) # old.par <- par(no.readonly=TRUE) # 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(old.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(old.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) # old.par <- par(no.readonly=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(old.par) # # old.par <- par(no.readonly=TRUE) # plotmo(gbmt.bernoulli, do.par=2) # print(summary(gbmt.bernoulli)) # will also plot # par(old.par) source("test.epilog.R") plotmo/inst/slowtests/test.modguide.R0000644000176200001440000003315113315504533017513 0ustar liggesusers# test.modguide.bat: test model1 and model2 (linmod examples) in modguide.pdf source("test.prolog.R") 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.R0000644000176200001440000000747613555142171016521 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 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 old.par <- par(no.readonly=TRUE) 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(old.par) # compare pairplot and plotmo old.par <- par(no.readonly=TRUE) 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(old.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.bat0000755000176200001440000000142313514230363017047 0ustar liggesusers@rem test.pre.bat: pre tests for plotmo and plotres @echo test.pre.bat @"C:\PROGRA~1\R\R-3.6.1\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/linmod.methods.R0000644000176200001440000000517613315243437017675 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/test.emma.bat0000755000176200001440000000147713514230362017210 0ustar liggesusers@rem test.emma.R: regression tests for emma with plotmo @rem Stephen Milborrow, Shrewsbury Nov 2014 @"C:\PROGRA~1\R\R-3.6.1\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.emma.R @if %errorlevel% equ 0 goto good1: @echo R returned errorlevel %errorlevel%, see test.emma.Rout: @echo. @tail test.emma.Rout @echo test.emma.R @exit /B 1 :good1 mks.diff test.emma.Rout test.emma.Rout.save @if %errorlevel% equ 0 goto good2: @echo === Files are different === @rem @diffps -s Rplots.ps ..\..\.#\test-reference\test.emma.save.ps @exit /B 1 :good2 @rem test.emma.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.emma.save.ps @if %errorlevel% equ 0 goto good3: @echo === Files are different === @exit /B 1 :good3 @rm -f test.emma.Rout @rm -f Rplots.ps @exit /B 0 plotmo/inst/slowtests/make.bat0000755000176200001440000000457213553744647016252 0ustar liggesusers@rem plotmo/inst/slowtests/make.bat time /T @call test.plotmo.bat @if %errorlevel% NEQ 0 goto error @call test.degree.bat @if %errorlevel% NEQ 0 goto error @call test.plotmo.x.bat @if %errorlevel% NEQ 0 goto error @call test.printcall.bat @if %errorlevel% NEQ 0 goto error @call test.plotmo.dots.bat @if %errorlevel% NEQ 0 goto error @call test.plotmo3.bat @if %errorlevel% NEQ 0 goto error @call test.plotmo.args.bat @if %errorlevel% NEQ 0 goto error @call test.non.earth.bat @if %errorlevel% NEQ 0 goto error @call test.caret.bat @if %errorlevel% NEQ 0 goto error @call test.fac.bat @if %errorlevel% NEQ 0 goto error @call test.center.bat @if %errorlevel% NEQ 0 goto error @rem TODO test.emma removed for R version 3.5.2 because it gives: package 'clusterSim' could not be loaded @rem @call test.emma.bat @if %errorlevel% NEQ 0 goto error @call test.plotres.bat @if %errorlevel% NEQ 0 goto error @call test.glmnet.bat @if %errorlevel% NEQ 0 goto error @call test.glmnetUtils.bat @if %errorlevel% NEQ 0 goto error @call test.gbm.bat @if %errorlevel% NEQ 0 goto error @call test.pre.bat @if %errorlevel% NEQ 0 goto error @call test.mlr.bat @if %errorlevel% NEQ 0 goto error @call test.modguide.bat @if %errorlevel% NEQ 0 goto error @call test.linmod.bat @if %errorlevel% NEQ 0 goto error @call test.dots.bat @if %errorlevel% NEQ 0 goto error @call test.partdep.bat @if %errorlevel% NEQ 0 goto error @call test.c50.bat @if %errorlevel% NEQ 0 goto error @call test.partykit.bat @if %errorlevel% NEQ 0 goto error @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 error @call make.bat @if %nerrorlevel% NEQ 0 goto error @cd \a\r\plotmo\inst\slowtests @goto done :error @echo ==== ERROR ==== :done time /T @exit /B 0 plotmo/inst/slowtests/test.plotmo.x.R0000644000176200001440000002734213403043541017476 0ustar liggesusers# test.plotmo.x.R: test plotmo_x and related functions source("test.prolog.R") library(plotmo) library(earth) 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") old.warn <- 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=old.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.bat0000755000176200001440000000156113514230362017516 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-3.6.1\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.R0000644000176200001440000001011313376045434020163 0ustar liggesusers# test.plotmo.args..R: test dot and other argument handling in plotmo source("test.prolog.R") library(earth) data(ozone1) old.warn <- options("warn") 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=old.warn$warn) # 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) 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) source("test.epilog.R") plotmo/inst/slowtests/test.mlr.R0000644000176200001440000003725113431101134016502 0ustar liggesusers# test.mlr.R: test the "mlr" package with plotmo and plotres # # 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") old.par <- par(no.readonly=TRUE) 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) expect.err(try(plotmo(earth, do.par=0, degree1=1, degree2=0)), "cannot get the original model predictors") par(old.par) 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) old.warn <- options(warn=2) # treat warnings as errors expect.err(try(plotmo(classif.rf.with.call)), "Defaulting to nresponse=1, see above messages") options(warn=old.warn$warn) 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") old.warn <- 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=old.warn$warn) 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.save0000644000176200001440000002673113504762666020524 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 Loading required package: TeachingDemos > library(earth) > library(caret) Loading required package: lattice Loading required package: ggplot2 > 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) + } > 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 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+ibh+dpg+ibt+..., 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 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+ibh+dpg+ibt+..., 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) Warning in model.matrix.default(Terms, m, contrasts) : non-list contrasts argument ignored > 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 > > # TODO following doesn't work properly, factors are plotted as continuous? > # trace=1 to display "Fixed rank deficient bx by removing 1 term" messages > a.bag3 <- bagEarth(survived~., data=etitanic, degree=2, B=3, trace=1) Warning in model.matrix.default(Terms, m, contrasts) : non-list contrasts argument ignored x[1046,7] with colnames pclass1st pclass2nd pclass3rd sexmale age sibsp parch y[1046,1] with colname subY, and values 0, 0, 0, 1, 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.425 RSq 0.462 Prune backward penalty 3 nprune null: selected 11 of 15 terms, and 6 of 7 preds After pruning pass GRSq 0.434 RSq 0.461 x[1046,7] with colnames pclass1st pclass2nd pclass3rd sexmale age sibsp parch y[1046,1] with colname subY, and values 1, 0, 0, 0, 1, 1, 1, 0, 0, 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.383 RSq 0.432 Prune backward penalty 3 nprune null: selected 7 of 18 terms, and 5 of 7 preds After pruning pass GRSq 0.401 RSq 0.418 x[1046,7] with colnames pclass1st pclass2nd pclass3rd sexmale age sibsp parch y[1046,1] with colname subY, and values 1, 0, 1, 1, 1, 1, 0, 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.450 RSq 0.488 Prune backward penalty 3 nprune null: selected 13 of 16 terms, and 5 of 7 preds After pruning pass GRSq 0.458 RSq 0.488 > 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 > > # example by Max Kuhn on stackoverflow > set.seed(2015) > etit <- etitanic > etit$survived <- factor(ifelse(etit$survived == 1, "yes", "no"), + levels = c("yes", "no")) > # TODO pairs are not automatically plotted > caret.earth.mod2 <- train(survived ~ ., + data = etit, + method = "earth", + tuneGrid = data.frame(degree = 2, nprune = 9), + trControl = trainControl(method = "none", + classProbs = TRUE)) > plotmo(caret.earth.mod2, trace=1, SHOWCALL=TRUE) plotmo.prolog(object$finalModel) succeeded 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+parch, data=call$data, na.action="na.fail") 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 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+parch, data=call$data, na.action="na.fail") training rsq 0.21 > > data(ozone1) > 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 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+ibh+dpg+ibt+..., 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 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+ibh+dpg+ibt+..., 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) > plotmo(mod, pt.col=2, all2=TRUE) plotmo grid: Height Volume 76 24.2 > > source("test.epilog.R") plotmo/inst/slowtests/make.README.R0000644000176200001440000000041013315504404016576 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.linmod.bat0000755000176200001440000000147013514230363017545 0ustar liggesusers@rem test.linmod.bat: test example S3 model in linmod.R @echo test.linmod.bat @"C:\PROGRA~1\R\R-3.6.1\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.bat0000755000176200001440000000143513514230362017234 0ustar liggesusers@rem test.dots.R: test handling of dots arguments @echo test.dots.bat @"C:\PROGRA~1\R\R-3.6.1\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.R0000644000176200001440000002721013336670701016452 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.save0000644000176200001440000002617713470064240021722 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 Loading required package: TeachingDemos > 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) + 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, ...) + par(old.par) + } > 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 error as expected 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 error as expected 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 > > 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") > > # # 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) > > old.par <- par(no.readonly=TRUE) > 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 > > #-- make sure that we can work with all families > > set.seed(2016) > old.par <- par(no.readonly=TRUE) > 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 > # 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 > # TODO formula interface not tested for cox models > > source("test.epilog.R") plotmo/inst/slowtests/test.fac.Rout.save0000644000176200001440000004220213443072125020130 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 Loading required package: TeachingDemos > 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.save0000644000176200001440000000717613443072125021674 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 Loading required package: TeachingDemos > library(earth) > data(ozone1) > > 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 error as expected 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()") > > old.warn <- options("warn") > 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 error as expected 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 error as expected from try(plotmo(a, lw = 2)) > > # 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+ibh+dpg+ibt+..., 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+ibh+dpg+ibt+..., 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 > > options(warn=old.warn$warn) > > source("test.epilog.R") plotmo/inst/slowtests/test.mlr.Rout.save0000644000176200001440000011006113504722566020201 0ustar liggesusers> # test.mlr.R: test the "mlr" package with plotmo and plotres > # > # TODO generally, plotres residuals for WrappedModel prob models aren't right > > source("test.prolog.R") > library(mlr) Loading required package: ParamHelpers > library(plotmo) Loading required package: Formula Loading required package: plotrix Loading required package: TeachingDemos > 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=========================== > > old.par <- par(no.readonly=TRUE) > 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) > expect.err(try(plotmo(earth, do.par=0, 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 error as expected from try(plotmo(earth, do.par = 0, degree1 = 1, degree2 = 0)) > par(old.par) > > cat("==regression model with randomForest (binary response)============================\n") ==regression model with randomForest (binary response)============================ > > library(randomForest) randomForest 4.6-14 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 : Discrete value supplied to 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) > > old.warn <- 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 error as expected from try(plotmo(classif.rf.with.call)) > options(warn=old.warn$warn) > 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) object call is train.with.call(learner=lrn.classif.rf, task=task.classif.rf, ...--get.model.env for WrappedModel object 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 : 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 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 error as expected from try(plotres(classif.lda$learner.model)) > > old.warn <- 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 error as expected from try(plotres(classif.lda$learner.model, type = "response")) > options(warn=old.warn$warn) > > 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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.5 > # 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.R0000644000176200001440000002025713335165371017365 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) # 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") old.par <- par(no.readonly=TRUE) 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(old.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) old.par <- par(no.readonly=TRUE) 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(old.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") old.par <- par(no.readonly=TRUE) 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(old.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) old.par <- par(no.readonly=TRUE) 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(old.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") old.par <- par(no.readonly=TRUE) 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(old.par) source("test.epilog.R") plotmo/inst/slowtests/test.plotmo.Rout.save0000644000176200001440000034407013527067042020726 0ustar liggesusers> # test.plotmo.R: regression tests for plotmo > # Stephen Milborrow, Petaluma Jan 2007 > > print(R.version.string) [1] "R version 3.6.1 (2019-07-05)" > > source("test.prolog.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix Loading required package: TeachingDemos > data(ozone1) > 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 select plotmo+ # 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+ibh+dpg+ibt+..., 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) object call is earth(formula=O3~., data=ozone1, pmethod="n", degree=2, nk=30) --get.model.env for earth object using the environment saved with 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+doy 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+ibh+dpg+ibt+..., 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+doy 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+ibh+dpg+ibt+..., 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+doy 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+ibh+dpg+ibt+..., 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+ibh+dpg+ibt+..., 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) object call is earth(formula=O3~., data=ozone1, pmethod="n", degree=2, nk=16) --get.model.env for earth object using the environment saved with 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+doy 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+ibh+dpg+ibt+..., 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+doy 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+ibh+dpg+ibt+..., 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+doy 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+ibh+dpg+ibt+..., 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+ibh+dpg+ibt+..., 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, ndiscrete=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, ndiscrete=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, ndiscrete=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) object call is earth(formula=O3~temp+humidity, data=oz, degree=2) --get.model.env for earth object using the environment saved with 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 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") 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) object call is earth(x=oz[, 2:3], y=oz[, 1], degree=2) --get.model.env for earth object 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 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=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 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 error as expected 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) object call is lm(formula=y~x1+x2, x=TRUE, y=TRUE) --get.model.env for lm object using the environment saved with 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 naked formula is the same 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected from try(plotmo(lm.x1.x2.x3, degree1 = "x2", do.par = 0, pmethod = "partdep", grid.levels = list(x1 = "1"))) > par(old.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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected from try(plotmo(lm.bad)) > expect.err(try(plotmo(99)), "'99' is not an S3 model") Error : '99' is not an S3 model Got error as expected 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 error as expected 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 error as expected 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 Warning: 'newdata' had 50 rows but variables found have 10 rows Error : predict returned the wrong length (got 10 but expected 50) Got error as expected 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 Warning: 'newdata' had 11 rows but variables found have 10 rows Error : predict returned the wrong length (got 10 but expected 11) Got error as expected 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: 'newdata' had 50 rows but variables found have 10 rows Error : predict returned the wrong length (got 10 but expected 50) Got error as expected 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 error as expected 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 error as expected 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 error as expected from try(plotmo(a.foo7, col.response = 3)) > foo8 <- function() + { + i <- 1 + a.foo8 <- lm(y~x[,i]+x[,2]) + # causes Warning: 'newdata' had 8 rows but variables found have 10 rows + expect.err(try(plotmo(a.foo8)), "predict returned the wrong length (got 10 but expected 50)") + } > foo8() Warning: 'newdata' had 50 rows but variables found have 10 rows Error : predict returned the wrong length (got 10 but expected 50) Got error as expected from try(plotmo(a.foo8)) > 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: x[,1] + x[,my.list$j]: "$" in the formula is not allowed by plotmo, will try to get the data elsewhere 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 error as expected 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) + old.par <- par(no.readonly=TRUE) + on.exit(par(old.par)) + 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 > > foo20.func <- function() + { + old.par <- par(no.readonly=TRUE) + on.exit(par(old.par)) + 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 > > 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 > > old.par <- par(no.readonly=TRUE) > 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 > 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(old.par) > > # nrug argument > > old.par <- par(no.readonly=TRUE) > 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(old.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.save0000644000176200001440000001764313437343026020651 0ustar liggesusers> # test.pre.R: test the "pre" package with plotmo and plotres > > source("test.prolog.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix Loading required package: TeachingDemos > 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 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 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 match any names Available names are "vh" "wind" "humidity" "temp" "ibh" "dpg" "ibt" "vis" "doy" Warning: "nonesuch2" in degree2 does not 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=2) # treat warnings as errors > plotmo(a81) plotmo grid: pclass sex age sibsp parch 3rd male 28 0 0 > > # degree1 tests > old.par <- par(no.readonly=TRUE) > 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 > expect.err(try(plotmo(a81, do.par=FALSE, degree1="survived", degree2=0)), '"survived" in degree1 does not match any names') Error : (converted from warning) "survived" in degree1 does not match any names Available names are "pclass" "sex" "age" "sibsp" "parch" Got error as expected from try(plotmo(a81, do.par = FALSE, degree1 = "survived", degree2 = 0)) > 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(old.par) > > # degree2 tests > old.par <- par(no.readonly=TRUE) > 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")') > expect.err(try(plotmo(a81, do.par=FALSE, degree1=0, degree2=c("pclass", "nonesuch"))), "\"nonesuch\" in degree2 does not match any names") Error : (converted from warning) "nonesuch" in degree2 does not match any names Available names are "pclass" "sex" "age" "sibsp" "parch" Got error as expected 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 match any names") Error : (converted from warning) "nonesuch1" in degree2 does not match any names Available names are "pclass" "sex" "age" "sibsp" "parch" Got error as expected 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 match any names") Error : (converted from warning) "nonesuch" in degree2 does not match any names Available names are "pclass" "sex" "age" "sibsp" "parch" Got error as expected from try(plotmo(a81, do.par = FALSE, degree1 = 0, degree2 = c("nonesuch", "pclass"))) > par(old.par) > > old.par <- par(no.readonly=TRUE) > options(warn=1) # print warnings as they occur > 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 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 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 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 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(old.par) > > source("test.epilog.R") plotmo/inst/slowtests/test.plotmo.dots.R0000644000176200001440000000365313430131510020171 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) 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()") old.warn <- options("warn") 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'") # 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 options(warn=old.warn$warn) source("test.epilog.R") plotmo/inst/slowtests/test.c50.Rout.save0000644000176200001440000000606313443072026017773 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 Loading required package: TeachingDemos > 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/test.gbm.bat0000755000176200001440000000142313514230363017026 0ustar liggesusers@rem test.gbm.bat: gbm tests for plotmo and plotres @echo test.gbm.bat @"C:\PROGRA~1\R\R-3.6.1\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.save0000644000176200001440000017064113553740254021313 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 Loading required package: TeachingDemos > 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) > plotmo(a, do.par=FALSE, caption=caption, ylim=NA, col.response=3, pt.pch=20, smooth.col="indianred") plotmo grid: vh wind humidity temp ibh 5760 5 64 62 2112.5 > termplot(a) > > 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) > 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) > > 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 > > 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 > > 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) > > # 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) > 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)") object call is glm(formula=response~temp, family="binomial", data=orings) --get.model.env for glm object using the environment saved with 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 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 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 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 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), ylim=c(-0.1,1.1)) > a902 <- glm(cbind(damage, 6-damage)~temp, family="binomial", data=orings) > 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) > plotmo(a902, type="response", main="type=\"response\"", col.response=2, do.par=F) > par(mfrow=c(1,1)) > > 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) > 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)) > > if(length(grep("package:gam", search()))) + detach("package:gam") > library(mgcv) Loading required package: nlme This is mgcv 1.8-29. 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)) > 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) > > 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) > > detach("package:mgcv") > library(gam) Loading required package: splines Loading required package: foreach Loaded gam 1.16.1 > 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) Warning in model.matrix.default(mt, mf, contrasts) : non-list contrasts argument ignored > 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") > > library(mda) Loading required package: class Loaded mda 0.4-10 > 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) object call is mars(x=ozone1[, -1], y=ozone1[, 1], degree=2) --get.model.env for mars object 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 terms.default(object) : 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 > > 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 > > # 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) > 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 > > # 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 > 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 > > # 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) > > 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 > > 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) > > 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) > > 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) > 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) > > if(length(grep("package:gam", search()))) + detach("package:gam") > library(mgcv) This is mgcv 1.8-29. 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)) > 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) > > # 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) > # 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") > > # 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) > # plotmo(a, col.response="gray", level=.95, nrug=-1, do.par=FALSE, caption=caption) > # termplot(a) > > 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) > > 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 > > 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) > > 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) > > # 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]) > 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 > > # # 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") > # plotmo(a, type="class", all2=TRUE, type2="contour", degree1=NA, do.par=FALSE, > # col.response=as.numeric(cush.data$tp)+1) > # 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) > # 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(mfrow=c(1,1)) > > 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)) > par(mfrow=c(3, 3)) > old.mar <- par(mar=c(3, 3, 2, .5)) # small margins to pack figs in > set.seed(9) # for jitter > 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(mar=old.mar) > > # kyphosis data, rpart models (also test ngrid2) > fit1 <- rpart(Kyphosis ~ ., data=kyphosis) > plotres(fit1, SHOWCALL=TRUE) > par(mfrow=c(3, 3)) > old.par <- 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)) > 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") > 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)) > 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(mar=old.par$mar, mgp=old.par$mgp) > > 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 error as expected from try(plotmo(fit1, type = "none.such1")) > > # rpart model with ozone data > data(ozone1) > par(mfrow=c(4,4)) > old.par <- 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 error as expected 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 error as expected 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 error as expected 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 error as expected from try(plotmo(a, type = c("abc", "def"))) > > # 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(mar=old.par$mar, cex=old.par$cex, mgp=old.par$mgp) > > 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) > 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)) > 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) > 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) > 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.6-14 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+parch, 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+parch, 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+parch, 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+parch, 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+parch, 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(mfrow=c(1,1)) > > 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 error as expected 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 > > # 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 > 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" > 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: lattice Attaching package: 'lattice' The following object is masked from 'package:faraway': melanoma Loading required package: ggplot2 Attaching package: 'ggplot2' The following object is masked from 'package:randomForest': margin 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 > > 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 error as expected 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 error as expected 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) > > source("test.epilog.R") plotmo/inst/slowtests/test.caret.R0000644000176200001440000000547113504763015017022 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) } 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) # TODO following doesn't work properly, factors are plotted as continuous? # trace=1 to display "Fixed rank deficient bx by removing 1 term" messages 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) # example by Max Kuhn on stackoverflow set.seed(2015) etit <- etitanic etit$survived <- factor(ifelse(etit$survived == 1, "yes", "no"), levels = c("yes", "no")) # TODO pairs are not automatically plotted caret.earth.mod2 <- train(survived ~ ., data = etit, method = "earth", tuneGrid = data.frame(degree = 2, nprune = 9), trControl = trainControl(method = "none", classProbs = TRUE)) plotmo(caret.earth.mod2, trace=1, SHOWCALL=TRUE) plotres(caret.earth.mod2, trace=1, SHOWCALL=TRUE) data(ozone1) 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) plotmo(mod, pt.col=2, all2=TRUE) source("test.epilog.R") plotmo/inst/slowtests/test.non.earth.R0000644000176200001440000007005513451305140017610 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) plotmo(a, do.par=FALSE, caption=caption, ylim=NA, col.response=3, pt.pch=20, smooth.col="indianred") termplot(a) 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) plotmo(a, do.par=FALSE, caption=caption, ylim=NA, col.resp=3, pt.pch=20, clip=FALSE, smooth.col="indianred") termplot(a) 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 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 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) # 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) 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) 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) plotmo(a902, type="response", main="type=\"response\"", col.response=2, do.par=F) par(mfrow=c(1,1)) 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) 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)) 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)) 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) 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) 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) 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") 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) 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) # 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) 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) # 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 plotmo(a, caption=caption, inverse.func = exp, col.response = "pink", func=my.func, func.col="gray", ngrid1=1000, type2="p", smooth.col="indianred") # 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) 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) 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) 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) 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) 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) 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)) 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) # 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) # 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") # 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) # plotmo(a, col.response="gray", level=.95, nrug=-1, do.par=FALSE, caption=caption) # termplot(a) 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) 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) 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) 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) # 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]) 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)) # # 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") # plotmo(a, type="class", all2=TRUE, type2="contour", degree1=NA, do.par=FALSE, # col.response=as.numeric(cush.data$tp)+1) # 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) # 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(mfrow=c(1,1)) library(rpart) data(kyphosis) # kyphosis data, earth model a <- earth(Kyphosis ~ ., data=kyphosis, degree=2, glm=list(family=binomial)) par(mfrow=c(3, 3)) old.mar <- par(mar=c(3, 3, 2, .5)) # small margins to pack figs in set.seed(9) # for jitter 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(mar=old.mar) # kyphosis data, rpart models (also test ngrid2) fit1 <- rpart(Kyphosis ~ ., data=kyphosis) plotres(fit1, SHOWCALL=TRUE) par(mfrow=c(3, 3)) old.par <- 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)) 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) 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)) 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(mar=old.par$mar, mgp=old.par$mgp) 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)) old.par <- 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")))) # 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(mar=old.par$mar, cex=old.par$cex, mgp=old.par$mgp) 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) 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)) 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) 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) 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(mfrow=c(1,1)) 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) # 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))) 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" 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) 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) source("test.epilog.R") plotmo/inst/slowtests/test.c50.R0000644000176200001440000000412613315504432016303 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.bat0000755000176200001440000000162013514230363020154 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-3.6.1\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.bat0000755000176200001440000000024713514230362017156 0ustar liggesusers@rem Create README.html from README.md "C:\PROGRA~1\R\R-3.6.1\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.R0000644000176200001440000010452313527066774017251 0ustar liggesusers# test.plotmo.R: regression tests for plotmo # Stephen Milborrow, Petaluma Jan 2007 print(R.version.string) source("test.prolog.R") library(earth) data(ozone1) 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, ndiscrete=1, caption="varied.type.lm\nndiscrete=1") plotmo(varied.type.lm, all2=TRUE, ndiscrete=2, caption="varied.type.lm\nndiscrete=2") plotmo(varied.type.lm, all2=TRUE, ndiscrete=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(old.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() foo8 <- function() { i <- 1 a.foo8 <- lm(y~x[,i]+x[,2]) # causes Warning: 'newdata' had 8 rows but variables found have 10 rows expect.err(try(plotmo(a.foo8)), "predict returned the wrong length (got 10 but expected 50)") } foo8() 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) old.par <- par(no.readonly=TRUE) on.exit(par(old.par)) 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() foo20.func <- function() { old.par <- par(no.readonly=TRUE) on.exit(par(old.par)) 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() 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 old.par <- par(no.readonly=TRUE) 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(old.par) # nrug argument old.par <- par(no.readonly=TRUE) 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(old.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.bat0000755000176200001440000000150713514230363017723 0ustar liggesusers@rem test.partdep.bat: partdep tests for plotmo and plotres @echo test.partdep.bat @"C:\PROGRA~1\R\R-3.6.1\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.save0000644000176200001440000006330013470064266020155 0ustar liggesusers> # test.gbm.R: gbm tests for plotmo and plotres > > source("test.prolog.R") > library(gbm) Loaded gbm 2.1.5 > 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 Loading required package: TeachingDemos > 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 error as expected 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) > old.par <- par(no.readonly=TRUE) > 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(old.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 > old.par <- par(no.readonly=TRUE) > 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(old.par) > > old.par <- par(no.readonly=TRUE) > 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(old.par) > > # test xlim and ylim > old.par <- par(no.readonly=TRUE) > 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(old.par) > > # test the smooth argument > old.par <- par(no.readonly=TRUE) > 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(old.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) > old.par <- par(no.readonly=TRUE) > 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(old.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) > old.par <- par(no.readonly=TRUE) > 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(old.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) > # old.par <- par(no.readonly=TRUE) > # 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(old.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) > old.par <- par(no.readonly=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(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(old.par) > > old.par <- par(no.readonly=TRUE) > 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(old.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) > old.par <- par(no.readonly=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(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(old.par) > > old.par <- par(no.readonly=TRUE) > 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(old.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) > old.par <- par(no.readonly=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(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(old.par) > > old.par <- par(no.readonly=TRUE) > 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(old.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") Error : gbm distribution="multinomial" is not yet supported (A direct call to plot_gbm may work) Got error as expected 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 error as expected 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))) > # old.par <- par(no.readonly=TRUE) > # 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(old.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(old.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) > # old.par <- par(no.readonly=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(old.par) > # > # old.par <- par(no.readonly=TRUE) > # plotmo(gbmt.bernoulli, do.par=2) > # print(summary(gbmt.bernoulli)) # will also plot > # par(old.par) > > source("test.epilog.R") plotmo/inst/slowtests/test.center.Rout.save0000644000176200001440000001305013443764330020664 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 Loading required package: TeachingDemos > 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.bat0000755000176200001440000000077013514230363020255 0ustar liggesusers@rem test.printcall.R: test printcall @echo test.printcall.bat @"C:\PROGRA~1\R\R-3.6.1\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.R0000644000176200001440000000034013315504415017166 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.save0000644000176200001440000016321413470064514020362 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 in eval(dots[[idot]], parent.frame(1)) : object 'none.such' not found Error : cannot evaluate 'a' Got error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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\\.|^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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected from try(foo3(10, 99)) > expect.err(try(foo3(10, y=plot)), "foo3: unrecognized argument 'y'") Error : foo3: unrecognized argument 'y' Got error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected from try(foo2(2)) > expect.err(try(foo2(y=plot)), "foo2: unrecognized argument 'y'") Error : foo2: unrecognized argument 'y' Got error as expected 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 error as expected 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 error as expected from try(foo2a(function(x = 1, ...) plotmo:::stop.if.dots(...), x = 1, y = 2)) > > cat0("=== test warn.if.dots\n") === test warn.if.dots > > old.warn <- options("warn") > 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected from try(foo4(2)) > expect.err(try(foo4(y=plot)), "foo4 ignored argument 'y'") Error : (converted from warning) foo4 ignored argument 'y' Got error as expected 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 error as expected from try(foo4(plot)) > > options(warn=old.warn$warn) > 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 error as expected 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.plotmo.x.Rout.save0000644000176200001440000007073113443071765021200 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 Loading required package: TeachingDemos > library(earth) > 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) object call is earth(formula=Y~., data=DF) --get.model.env for earth object using the environment saved with 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) object call is earth(formula=Y~., data=DF) --get.model.env for earth object using the environment saved with 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) object call is earth(formula=Y~., data=DF) --get.model.env for earth object using the environment saved with 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 error as expected 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) object call is earth(formula=Y~X1+X2, data=DF) --get.model.env for earth object using the environment saved with 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) object call is earth(formula=Y~X1+X2, data=DF) --get.model.env for earth object using the environment saved with 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 error as expected 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) object call is earth(formula=Y~X1+X2, data=DF) --get.model.env for earth object using the environment saved with 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) object call is earth(formula=Y~X1+X2, data=DF) --get.model.env for earth object using the environment saved with 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) object call is earth(formula=Y~X1+X2, data=DF) --get.model.env for earth object using the environment saved with 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) object call is earth(formula=Y~X1+X2, data=DF) --get.model.env for earth object using the environment saved with 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) object call is earth(formula=Y~., data=DF, keepxy=TRUE) --get.model.env for earth object using the environment saved with 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) object call is earth(formula=Y~., data=DF, keepxy=TRUE) --get.model.env for earth object using the environment saved with 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) object call is earth(formula=Y~., data=DF, keepxy=TRUE) --get.model.env for earth object using the environment saved with 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) object call is earth(formula=Y~., data=DF, keepxy=TRUE) --get.model.env for earth object using the environment saved with 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) object call is earth(formula=Y~., data=DF, keepxy=TRUE) --get.model.env for earth object using the environment saved with 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) object call is earth(formula=Y~., data=DF, keepxy=TRUE) --get.model.env for earth object using the environment saved with 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) object call is earth(formula=Y~., data=DF, keepxy=TRUE) --get.model.env for earth object using the environment saved with 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) object call is earth(formula=Y~., data=DF, keepxy=TRUE) --get.model.env for earth object using the environment saved with 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) object call is lm(formula=Y~., data=DF, model=FALSE) --get.model.env for lm object using the environment saved with 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) object call is lm(formula=Y~., data=DF, model=FALSE) --get.model.env for lm object using the environment saved with 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) object call is lm(formula=Y~., data=DF, model=FALSE) --get.model.env for lm object using the environment saved with 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 error as expected 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) object call is earth(formula=Y~X1+X2, data=DF) --get.model.env for earth object using the environment saved with 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) object call is lm(formula=Y~X1+X2, data=DF, model=FALSE) --get.model.env for lm object using the environment saved with 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 error as expected 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) object call is lm(formula=Y~X1+X2, data=DF, model=FALSE) --get.model.env for lm object using the environment saved with 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) object call is lm(formula=Y~X1+X2, data=DF, model=FALSE) --get.model.env for lm object using the environment saved with 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) object call is lm(formula=Y~X1+X2, data=DF, model=FALSE) --get.model.env for lm object using the environment saved with 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) object call is lm(formula=Y~., data=DF) --get.model.env for lm object using the environment saved with 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) object call is lm(formula=Y~., data=DF) --get.model.env for lm object using the environment saved with 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) object call is lm(formula=Y~., data=DF) --get.model.env for lm object using the environment saved with 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) object call is lm(formula=Y~., data=DF) --get.model.env for lm object using the environment saved with 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) object call is lm(formula=Y~., data=DF) --get.model.env for lm object using the environment saved with 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) object call is lm(formula=Y~., data=DF) --get.model.env for lm object using the environment saved with 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) object call is lm(formula=Y~., data=DF) --get.model.env for lm object using the environment saved with 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) object call is lm(formula=Y~., data=DF) --get.model.env for lm object using the environment saved with 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) object call is lm(formula=Y~., data=DF, model=FALSE, x=TRUE) --get.model.env for lm object using the environment saved with 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) object call is lm(formula=Y~., data=DF, model=FALSE, x=TRUE) --get.model.env for lm object using the environment saved with 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) object call is lm(formula=Y~., data=DF, model=FALSE, x=TRUE) --get.model.env for lm object using the environment saved with 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 error as expected 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) object call is lm(formula=Y~., data=DF, model=FALSE, x=TRUE) --get.model.env for lm object using the environment saved with 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) > old.warn <- 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) object call is lm(formula=Y~., data=DF, model=FALSE, x=TRUE) --get.model.env for lm object using the environment saved with 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 error as expected from try(plotmo(lm.form.df.model.false.x.true, trace = 100)) > options(warn=old.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) object call is earth(formula=survived~pclass, data=tit1, linpreds=TRUE) --get.model.env for earth object using the environment saved with 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) object call is earth(formula=survived~char.pclass, data=tit1) --get.model.env for earth object using the environment saved with 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) object call is earth(formula=survived~pclass, data=tit1, linpreds=TRUE) --get.model.env for earth object using the environment saved with 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) object call is earth(formula=survived~char.pclass, data=tit1) --get.model.env for earth object using the environment saved with 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.bat0000755000176200001440000000147213514230363017553 0ustar liggesusers@rem test.glmnet.bat: glmnet tests for plotmo and plotres @echo test.glmnet.bat @"C:\PROGRA~1\R\R-3.6.1\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.bat0000755000176200001440000000145713514230363017760 0ustar liggesusers@rem test.plotres.bat: test plotres @echo test.plotres.bat @"C:\PROGRA~1\R\R-3.6.1\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.R0000644000176200001440000000751113410151060017674 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.save0000644000176200001440000012240513470063430020777 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 Loading required package: TeachingDemos > data(ozone1) > data(etitanic) > > check.naken <- function(s, expected) + { + nude <- plotmo:::naken.formula.string(s) + printf("%-60.60s %-s\n", s, nude) + stopifnot(nude == expected) + } > printf("=== checking naken.formula.string\n") === checking naken.formula.string > check.naken("y ~ x1 : x2 + x3", "y~x1+x2+x3") y ~ x1 : x2 + x3 y~x1+x2+x3 > check.naken("y ~ x1 + x2 - x3", "y~x1+x2+x3") y ~ x1 + x2 - x3 y~x1+x2+x3 > check.naken("cbind(damage, 6-damage)~temp", "cbind(damage,6-damage)~temp") 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") 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]") Salary~Hitters[,1] Salary~Hitters[,1] > check.naken("Salary~Hitters[,-1]", "Salary~Hitters[,-1]") Salary~Hitters[,-1] Salary~Hitters[,-1] > check.naken("Salary~Hitters[,c(1,2)]", "Salary~Hitters[,c(1,2)]") 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)]") Salary~Hitters[,c(1,2)] Salary~Hitters[,c(1,2)] > 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 check.numeric.scalar > > xtest <- NA > expect.err(try(plotmo:::check.numeric.scalar(xtest)), "'xtest' is NA") Error : 'xtest' is NA Got error as expected 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 error as expected from try(plotmo:::check.numeric.scalar(xtest)) > expect.err(try(plotmo:::check.numeric.scalar(NA)), "argument is NA") Error : argument is NA Got error as expected from try(plotmo:::check.numeric.scalar(NA)) > expect.err(try(plotmo:::check.numeric.scalar(NULL)), "argument is NULL") Error : argument is NULL Got error as expected 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 error as expected 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 error as expected from try(plotmo:::check.numeric.scalar("try")) > expect.err(try(plotmo:::check.numeric.scalar(NULL)), "argument is NULL") Error : argument is NULL Got error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected from try(plotmo:::check.integer.scalar(xtest)) > expect.err(try(plotmo:::check.integer.scalar(NA)), "argument is NA") Error : argument is NA Got error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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 error as expected 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.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() > > mod.lm.age <- lm(age~., data=tit) > 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(tit$sex) > mod.lm.sexn <- lm(sexn~.-sex, data=tit) > 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 > > mod.earth.age <- earth(age~., data=tit, 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 > > # tit[,4] is age > mod.earth.tit <- earth(tit[,-4], tit[,4], degree=2, nfold=3, ncross=3, varmod.method="lm") > plotmo1(mod.earth.tit) plotmo1(object=mod.earth.tit) plotmo grid: pclass survived sex sibsp logage classthird 0 male 0 3.06991 > plotmo1(mod.earth.tit, level=.9, degree2=0) plotmo1(object=mod.earth.tit,level=0.9,degree2=0) plotmo grid: pclass survived sex sibsp logage classthird 0 male 0 3.06991 > > a.earth.sex <- earth(sex~., data=tit, 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 error as expected from try(plotmo1(a.earth.sex, level = 0.9, degree2 = 0, type = "class")) > > # tit[,3] is sex > mod.earth.tit <- earth(tit[,-3], tit[,3], degree=2, nfold=3, ncross=3, varmod.method="lm") > plotmo1(mod.earth.tit) plotmo1(object=mod.earth.tit) plotmo grid: pclass survived age sibsp logage classthird 0 30 0 3.06991 > plotmo1(mod.earth.tit, level=.9, degree2=0) plotmo1(object=mod.earth.tit,level=0.9,degree2=0) plotmo grid: pclass survived age sibsp logage classthird 0 30 0 3.06991 > plotmo1(mod.earth.tit, type="class") plotmo1(object=mod.earth.tit,type="class") plotmo grid: pclass survived age sibsp logage classthird 0 30 0 3.06991 > expect.err(try(plotmo1(mod.earth.tit, level=.9, degree2=0, type="class")), "predicted values are strings") plotmo1(object=mod.earth.tit,level=0.9,degree2=0,type="class") Error : the level argument is not allowed when the predicted values are strings Got error as expected from try(plotmo1(mod.earth.tit, level = 0.9, degree2 = 0, type = "class")) > > mod.earth.sex <- earth(sex~., data=tit, degree=2, nfold=3, ncross=3, varmod.method="earth", glm=list(family=binomial)) > 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 > > # tit[,3] is sex > mod.earth.tit <- earth(tit[,-3], tit[,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.tit) plotmo1(object=mod.earth.tit) plotmo grid: pclass survived age sibsp logage classthird 0 30 0 3.06991 > plotmo1(mod.earth.tit, type="link") plotmo1(object=mod.earth.tit,type="link") plotmo grid: pclass survived age sibsp logage classthird 0 30 0 3.06991 > plotmo1(mod.earth.tit, type="class") plotmo1(object=mod.earth.tit,type="class") plotmo grid: pclass survived age sibsp logage classthird 0 30 0 3.06991 > plotmo1(mod.earth.tit, level=.9, type="earth") plotmo1(object=mod.earth.tit,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 > tit.orgpclass <- etitanic[seq(1, nrow(etitanic), by=12), ] > tit <- get.tit() > tit$logage <- NULL > tit.orgpclass$parch <- NULL > stopifnot(names(tit.orgpclass) == names(tit)) > a.tit.orgpclass <- earth(pclass~., degree=2, data=tit.orgpclass) > a.tit <- earth(pclass~., degree=2, data=tit) > old.warn <- options(warn=2) # treat warnings as errors > expect.err(try(plotmo(a.tit)), "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 error as expected from try(plotmo(a.tit)) > options(warn=old.warn$warn) > # following two graphs should be identical > plotmo1(a.tit.orgpclass, nresponse="1st", all1=T, col.resp=3, type2="im") plotmo1(object=a.tit.orgpclass,nresponse="1st",all1=T,col.resp=3,type2="im") plotmo grid: survived sex age sibsp 0 male 30 0 > plotmo1(a.tit, nresponse="first", all1=T, col.resp=3, type2="im") plotmo1(object=a.tit,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.tit.orgpclass, nresponse="2nd", all1=T) plotmo1(object=a.tit.orgpclass,nresponse="2nd",all1=T) plotmo grid: survived sex age sibsp 0 male 30 0 > plotmo1(a.tit, nresponse="class2", all1=T) plotmo1(object=a.tit,nresponse="class2",all1=T) plotmo grid: survived sex age sibsp 0 male 30 0 > > tit <- get.tit() > mod.earth.pclass <- earth(pclass~., data=tit, degree=2) > old.warn <- 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 error as expected from try(plotmo1(mod.earth.pclass)) > options(warn=old.warn$warn) > 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(tit$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(tit$pclass)+1,pt.pch=1) plotmo grid: survived sex age sibsp logage 0 female 30 0 3.06991 > > # tit[,1] is pclass > mod.earth.tit <- earth(tit[,-1], tit[,1], degree=2) > old.warn <- options(warn=2) # treat warnings as errors > expect.err(try(plotmo1(mod.earth.tit)), "Defaulting to nresponse=1, see above messages") plotmo1(object=mod.earth.tit) 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 error as expected from try(plotmo1(mod.earth.tit)) > options(warn=old.warn$warn) > plotmo1(mod.earth.tit, nresponse="first") plotmo1(object=mod.earth.tit,nresponse="first") plotmo grid: survived sex age sibsp logage 0 male 30 0 3.06991 > plotmo1(mod.earth.tit, type="class") plotmo1(object=mod.earth.tit,type="class") plotmo grid: survived sex age sibsp logage 0 male 30 0 3.06991 > > mod.earth.pclass2 <- earth(pclass~., data=tit, 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 > > # tit[,1] is pclass > mod.earth.tit <- earth(tit[,-1], tit[,1], degree=2, glm=list(family=binomial)) > plotmo1(mod.earth.tit, nresponse=3) plotmo1(object=mod.earth.tit,nresponse=3) plotmo grid: survived sex age sibsp logage 0 male 30 0 3.06991 > plotmo1(mod.earth.tit, type="link", nresponse=3) plotmo1(object=mod.earth.tit,type="link",nresponse=3) plotmo grid: survived sex age sibsp logage 0 male 30 0 3.06991 > plotmo1(mod.earth.tit, type="class") plotmo1(object=mod.earth.tit,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.4-10 > 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)), "not supported for rpart objects") plotmo1(object=rpart.model.vignette,level=0.9) Error : the level argument is not supported for rpart objects Got error as expected 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.5 > 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 > > tit <- get.tit() > > mod.glm.sex <- glm(sex~., data=tit, family=binomial) > plotmo1(mod.glm.sex, pt.col=as.numeric(tit$pclass)+1) plotmo1(object=mod.glm.sex,pt.col=as.numeric(tit$pclass)+1) plotmo grid: pclass survived age sibsp logage classthird 0 30 0 3.06991 > > # tit[,4] is age, tit[,1] is pclass > printf("library(lars)\n") library(lars) > library(lars) Loaded lars 1.2 > set.seed(2015) > xmat <- as.matrix(tit[,c(2,5,6)]) > mod.lars.xmat <- lars(xmat, tit[,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,tit[,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 > > old.warn <- options("warn") > options(warn=2) > > data(gasoline, package="pls") > earth.octane <- earth(octane ~ NIR, data=gasoline) > 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 Got error as expected from try(plotmo(earth.octane)) > > library(ElemStatLearn) > x <- mixture.example$x > g <- mixture.example$y > lm.mixture.example <- lm(g ~ x) > expect.err(try(plotmo(lm.mixture.example)), "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 Got error as expected from try(plotmo(lm.mixture.example)) > > options(warn=old.warn$warn) > > # 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: ozone1$doy: "$" in the formula is not allowed by plotmo, will try to get the data elsewhere 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 error as expected from try(plotmo(a)) > > a <- earth(O3~ozone1$doy + temp, data=ozone1) > expect.err(try(plotmo(a)), "cannot get the original model predictors") Warning: ozone1$doy + temp: "$" in the formula is not allowed by plotmo, will try to get the data elsewhere 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 error as expected from try(plotmo(a)) > > a <- lm(O3~ozone1$doy, data=ozone1) > expect.err(try(plotmo(a)), "cannot get the original model predictors") Warning: ozone1$doy: "$" in the formula is not allowed by plotmo, will try to get the data elsewhere 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 error as expected from try(plotmo(a)) > > a <- lm(O3~ozone1$doy + temp, data=ozone1) > expect.err(try(plotmo(a)), "cannot get the original model predictors") Warning: ozone1$doy + temp: "$" in the formula is not allowed by plotmo, will try to get the data elsewhere 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 error as expected from try(plotmo(a)) > > #--- test interaction of w1. and non w1 args ------------------------------------- > > old.par <- par(no.readonly=TRUE) > 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(old.par) > old.par <- par(no.readonly=TRUE) > 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(old.par) > > source("test.epilog.R") plotmo/inst/slowtests/test.partykit.bat0000755000176200001440000000145513514230363020135 0ustar liggesusers@rem test.partykit.bat @echo test.partykit.bat @"C:\PROGRA~1\R\R-3.6.1\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.R0000644000176200001440000000310413306001532017522 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.emma.Rout.save0000644000176200001440000001747613437343026020341 0ustar liggesusers> # test.emma.R: regression tests for emma with plotmo > # Stephen Milborrow, Shrewsbury Nov 2014 > > source("test.prolog.R") > print(R.version.string) [1] "R version 3.5.2 (2018-07-02)" > library(emma) Loading required package: earth Loading required package: Formula Loading required package: plotmo Loading required package: plotrix Loading required package: TeachingDemos Loading required package: clusterSim Loading required package: cluster Loading required package: MASS This is package 'modeest' written by P. PONCET. For a complete list of functions, use 'library(help = "modeest")' or 'help.start()'. > print(citation("emma")) To cite package 'emma' in publications use: Laura Villanova, Kate Smith-Miles and Rob J Hyndman. (2011). emma: Evolutionary model-based multiresponse approach. R package version 0.1-0. https://CRAN.R-project.org/package=emma A BibTeX entry for LaTeX users is @Manual{, title = {emma: Evolutionary model-based multiresponse approach}, author = {Laura Villanova and Kate Smith-Miles and Rob J Hyndman.}, year = {2011}, note = {R package version 0.1-0}, url = {https://CRAN.R-project.org/package=emma}, } ATTENTION: This citation information has been auto-generated from the package DESCRIPTION file and may need manual editing, see 'help("citation")'. > > in.name <- c("x1","x2") > nlev <- c(10, 10) > lower <- c(-2.048, -2.048) > upper <- c(2.048, 2.048) > out.name <- "y" > weight <- 1 > C <- 3 > pr.mut <- c(0.1, 0.07, 0.04, rep(0.01, C-3)) > > emma(in.name, nlev, lower, upper, out.name, opt = "mn", nd = 8, na = 5, + weight, C , w1 = 0.7, w2 = 0.4, c1i = 2.5, c1f = 0.5, c2i = 0.5, + c2f = 2.5, b = 5, pr.mut, graph = "yes", fn1 = ackley) [1] "PERFORM THE FOLLOWING EXPERIMENTS ( t = 0 )" x1 x2 34 -0.6826667 -0.6826667 46 0.2275556 -0.2275556 6 0.2275556 -2.0480000 20 2.0480000 -1.5928889 99 1.5928889 2.0480000 29 1.5928889 -1.1377778 58 1.1377778 0.2275556 13 -1.1377778 -1.5928889 [1] "PERFORM THE FOLLOWING EXPERIMENTS ( t = 1 )" x1 x2 22 -1.5928889 -1.1377778 33 -1.1377778 -0.6826667 9 1.5928889 -2.0480000 70 2.0480000 0.6826667 95 -0.2275556 2.0480000 [1] "PERFORM THE FOLLOWING EXPERIMENTS ( t = 2 )" x1 x2 59 1.5928889 0.2275556 48 1.1377778 -0.2275556 44 -0.6826667 -0.2275556 36 0.2275556 -0.6826667 17 0.6826667 -1.5928889 plotmo grid: x1 x2 0.4551111 -0.6826667 $xpop x1 x2 34 -0.6826667 -0.6826667 46 0.2275556 -0.2275556 6 0.2275556 -2.0480000 20 2.0480000 -1.5928889 99 1.5928889 2.0480000 29 1.5928889 -1.1377778 58 1.1377778 0.2275556 13 -1.1377778 -1.5928889 22 -1.5928889 -1.1377778 33 -1.1377778 -0.6826667 9 1.5928889 -2.0480000 70 2.0480000 0.6826667 95 -0.2275556 2.0480000 59 1.5928889 0.2275556 48 1.1377778 -0.2275556 44 -0.6826667 -0.2275556 36 0.2275556 -0.6826667 17 0.6826667 -1.5928889 $ypop y1 34 4.607458 46 2.457189 6 6.044857 20 7.798963 99 7.798963 29 6.643627 58 4.261612 13 6.643627 22 6.643627 33 5.014016 9 7.798963 70 6.667417 95 6.044857 59 6.081880 48 4.261612 44 3.779749 36 3.779749 17 6.528924 $xspace x1 x2 1 -2.0480000 -2.0480000 2 -1.5928889 -2.0480000 3 -1.1377778 -2.0480000 4 -0.6826667 -2.0480000 5 -0.2275556 -2.0480000 6 0.2275556 -2.0480000 7 0.6826667 -2.0480000 8 1.1377778 -2.0480000 9 1.5928889 -2.0480000 10 2.0480000 -2.0480000 11 -2.0480000 -1.5928889 12 -1.5928889 -1.5928889 13 -1.1377778 -1.5928889 14 -0.6826667 -1.5928889 15 -0.2275556 -1.5928889 16 0.2275556 -1.5928889 17 0.6826667 -1.5928889 18 1.1377778 -1.5928889 19 1.5928889 -1.5928889 20 2.0480000 -1.5928889 21 -2.0480000 -1.1377778 22 -1.5928889 -1.1377778 23 -1.1377778 -1.1377778 24 -0.6826667 -1.1377778 25 -0.2275556 -1.1377778 26 0.2275556 -1.1377778 27 0.6826667 -1.1377778 28 1.1377778 -1.1377778 29 1.5928889 -1.1377778 30 2.0480000 -1.1377778 31 -2.0480000 -0.6826667 32 -1.5928889 -0.6826667 33 -1.1377778 -0.6826667 34 -0.6826667 -0.6826667 35 -0.2275556 -0.6826667 36 0.2275556 -0.6826667 37 0.6826667 -0.6826667 38 1.1377778 -0.6826667 39 1.5928889 -0.6826667 40 2.0480000 -0.6826667 41 -2.0480000 -0.2275556 42 -1.5928889 -0.2275556 43 -1.1377778 -0.2275556 44 -0.6826667 -0.2275556 45 -0.2275556 -0.2275556 46 0.2275556 -0.2275556 47 0.6826667 -0.2275556 48 1.1377778 -0.2275556 49 1.5928889 -0.2275556 50 2.0480000 -0.2275556 51 -2.0480000 0.2275556 52 -1.5928889 0.2275556 53 -1.1377778 0.2275556 54 -0.6826667 0.2275556 55 -0.2275556 0.2275556 56 0.2275556 0.2275556 57 0.6826667 0.2275556 58 1.1377778 0.2275556 59 1.5928889 0.2275556 60 2.0480000 0.2275556 61 -2.0480000 0.6826667 62 -1.5928889 0.6826667 63 -1.1377778 0.6826667 64 -0.6826667 0.6826667 65 -0.2275556 0.6826667 66 0.2275556 0.6826667 67 0.6826667 0.6826667 68 1.1377778 0.6826667 69 1.5928889 0.6826667 70 2.0480000 0.6826667 71 -2.0480000 1.1377778 72 -1.5928889 1.1377778 73 -1.1377778 1.1377778 74 -0.6826667 1.1377778 75 -0.2275556 1.1377778 76 0.2275556 1.1377778 77 0.6826667 1.1377778 78 1.1377778 1.1377778 79 1.5928889 1.1377778 80 2.0480000 1.1377778 81 -2.0480000 1.5928889 82 -1.5928889 1.5928889 83 -1.1377778 1.5928889 84 -0.6826667 1.5928889 85 -0.2275556 1.5928889 86 0.2275556 1.5928889 87 0.6826667 1.5928889 88 1.1377778 1.5928889 89 1.5928889 1.5928889 90 2.0480000 1.5928889 91 -2.0480000 2.0480000 92 -1.5928889 2.0480000 93 -1.1377778 2.0480000 94 -0.6826667 2.0480000 95 -0.2275556 2.0480000 96 0.2275556 2.0480000 97 0.6826667 2.0480000 98 1.1377778 2.0480000 99 1.5928889 2.0480000 100 2.0480000 2.0480000 $yspace y 1 9.247237 2 8.627953 3 8.008669 4 7.389385 5 6.770102 6 6.044857 7 6.842377 8 7.533936 9 7.798963 10 8.917054 11 8.171553 12 7.552269 13 6.643627 14 6.313701 15 5.694417 16 5.075134 17 6.528924 18 6.458251 19 7.149810 20 7.798963 21 7.095869 22 6.643627 23 5.857301 24 5.238017 25 4.618733 26 3.999449 27 4.691008 28 5.382567 29 6.643627 30 6.765685 31 6.020184 32 5.400901 33 5.014016 34 4.607458 35 3.543049 36 3.779749 37 3.615324 38 4.306883 39 4.998442 40 5.690001 41 6.410708 42 5.791424 43 5.172140 44 3.779749 45 3.933572 46 2.457189 47 4.005847 48 4.261612 49 5.388965 50 6.080524 51 6.801231 52 6.181947 53 5.562663 54 4.943379 55 4.324095 56 3.704811 57 4.396370 58 4.261612 59 6.081880 60 6.471047 61 7.191754 62 6.572470 63 5.953186 64 5.333902 65 4.714618 66 4.095335 67 4.786893 68 5.478452 69 6.170011 70 6.667417 71 7.582277 72 6.962993 73 6.343709 74 5.724425 75 5.105142 76 4.485858 77 5.177417 78 5.868976 79 6.560535 80 7.252094 81 7.972800 82 7.353516 83 6.734232 84 6.114949 85 5.495665 86 4.876381 87 5.567940 88 6.259499 89 6.951058 90 7.642617 91 8.363323 92 7.744039 93 7.124756 94 6.505472 95 6.044857 96 5.266904 97 5.958463 98 6.650022 99 7.798963 100 8.033140 $opt [1] "mn" $nd [1] 8 $na [1] 5 $tested [1] 34 46 6 20 99 29 58 13 22 33 9 70 95 59 48 44 36 17 $time [1] 2 $weight [1] 1 $Gb 46 46 $Pb [1] 34 46 6 29 58 $Gb.arch 46 46 46 $Pb.arch [1] 34 46 6 29 58 34 46 6 29 58 $v x1 x2 34 2.748552 1.3742761 46 2.158830 0.5379049 6 -2.158830 1.7101397 29 -1.956788 -1.5691073 58 1.031202 -3.5331058 $sam.x [1] 59 48 44 36 17 $add [1] 0 attr(,"class") [1] "emma" > > source("test.epilog.R") plotmo/inst/slowtests/test.plotmo.x.bat0000755000176200001440000000152213514230363020041 0ustar liggesusers@rem test.plotmo.x.bat: test plotmo_x and related functions @echo test.plotmo.x.bat @"C:\PROGRA~1\R\R-3.6.1\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.save0000644000176200001440000002450113504722566021051 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 Loading required package: TeachingDemos > 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 > > # compare to gbm with an artifical function of variables with a very strong interaction > library(gbm) Loaded gbm 2.1.5 > 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") > old.par <- par(no.readonly=TRUE) > 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(old.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.6-14 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? > old.par <- par(no.readonly=TRUE) > 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(old.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") > old.par <- par(no.readonly=TRUE) > 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(old.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) > old.par <- par(no.readonly=TRUE) > 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(old.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") > old.par <- par(no.readonly=TRUE) > 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(old.par) > > source("test.epilog.R") plotmo/inst/slowtests/test.glmnetUtils.R0000644000176200001440000001413113375565445020241 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) 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, ...) par(old.par) } 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) 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") # # 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) old.par <- par(no.readonly=TRUE) 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) #-- make sure that we can work with all families set.seed(2016) old.par <- par(no.readonly=TRUE) 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) } # 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) # TODO formula interface not tested for cox models source("test.epilog.R") plotmo/inst/slowtests/test.mlr.bat0000755000176200001440000000142313514230363017053 0ustar liggesusers@rem test.mlr.bat: mlr tests for plotmo and plotres @echo test.mlr.bat @"C:\PROGRA~1\R\R-3.6.1\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.R0000644000176200001440000003130313315504534017404 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) plotres(elm, col=survived+2, SHOWCALL=TRUE) plotres(elm, col=survived+2, col.rsq="darkorange", lty.rsq=1, 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 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) emulti <- earth(cbind(Volume, Volume + 100 + 5 * rnorm(nrow(trees)))~., 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/0000755000176200001440000000000012537325257013321 5ustar liggesusersplotmo/inst/doc/modguide.pdf0000644000176200001440000024646713555374221015630 0ustar liggesusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 3144 /Filter /FlateDecode /N 52 /First 405 >> stream xZ[s6~_FtƗv\If Kō,DR8s`eL+2* 3*c9y2$1)>cMSäb4jRƔ)GJtfQoeR߳T)LX9SS )S2#P5&3eV=ˌ)&J/d6KAbցhN3E0fL ʎ9eκ95f^ a^9"yꏩ=T 7 ,X%V`+Ed06\ G+eF?ɫxX Yb  }Z^~ VrΞI>c'˻u=9A KL,KSa⻦ r<<߱ &Kv3}s]9/Navcܣcv4)b4/n*ſQ5W| Cϋjn T3pTn\㠼a|[@5N` ԕYHb 64g7M9V=TG,?ʤ_ ]iY]|lY2 dph?Pq IJ@L!qI e'SM=*w\>.Ij*m"{2۰⠜U u5^Q߳]Ey;4uE1"?xi9+ IYmFCfVɦp/%v.Hv:]i&m݊*M:I~Ea?;$L&$l: H]Nㆤqȗ4f=eqkCp||||_Le qh5I(!r~=2f6ozk^.0#?}'ΟF帘]rdEu0v"ABɺCL[6$~-$+jsDYm˼eZRCg ƘBMXpԦasl!NO=>ZYxZV:#\%z)4~YEF*m_N!1mJIq0EZ|"/&M{J(|>?Ώ ~_3>9_{ ~1a.&?i9yÌ<~/O9K#k>3U^7K0e ₍C4l s(/"."f^|1%:+^MyΫO?_|^~td`StxE>P.;{l~^LsMJ/󮤾 UfWp/U'|U/@5³u&=Mprrjklo(V+S iO) ȅ6Ϻ7͟ (#sfe]uSy1 &1!Td pCk]zMMt2S#5$/A,NmHn#RFIm@5O'~]͏[{ f4=x]mVvu_j״е|gSKv~\li}j6=NCڄ Hr:@q;ְ)bZZGRK捘▱HI]1ޯq-4Tڭ2ӓ7% ]KHLh|zp1Y RhK ږBoȩ2aζxBԵ1}sF_y%šh_|4Zu @ 7I4 _2R j³,kҥwτHCmfk>VmψfV3Rz0ME=3:DijVNǔvЂ6!0G#%C8q,a24B$lvg"_m~%=@Gwy%mH!Hm0 /%!Z/!}*!_t; kOc˦6(>gFc:f1~ȇQQ:b:Α%aY|6_ m-B;\x7j5'VԞ`ȐhM ^a'+жô){YW;Y o=F%]%L։2t%&J:6Kx"T,J,,2!^ afBcDA0fI66#ԽP9H:Wxs/i|"HhE%Q54z)JXonRKI[۹17o]~sm͈@Dzư&. mBF#6H ]yGW1O5nog8@=wJ(p`MwEte]ʇ^E=F]3W_ q+r :Ne6ela q`l6LDnMi݀Ia#wJ$tDd!ʔ:}(4dw÷έ:$߲oƒ> stream GPL Ghostscript 9.19 2019-10-25T16:55:47-07:00 2019-10-25T16:55:47-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 xYr۶}Wౝ3#i:q+ILhȢIwԅr#K @kX‰qDhK'2bKޡEQSD& [! DJ%(u NJI8EU8M( L 99y(MD Q{IxRFAЎBq{&h1vƒ QvEGuCR1F) B%Հ.4Kx & |1ga#IYywREnP ߰VZi,<OYEaRg9AuLϩfdu {Q,*].eC,RNN͛ݵETǠ'o2_ۣ `66;9wJ6ʖ?ZX$o;ac6a,gl 6g Vլ򜭾I۞:gvza#oZMozWNȧHV1]xƴO܋tO*j{W룍k㊔D֐lz#E";Htو@Ku\H^u~|ݏqXƸN?ĦNur; 5St^j|*8HA.U"Xl:nLl:ldǠwi w$r mt OdPH{&',$:BXTRS66VS6y:~0mr6}}4oVقV˪Ӳ2̢3"/ʳ<ͦ5]_|yM9֊8}8$}5I!5#q+a p? "A%hB#d" 'ժK % N=$J4=2O+QQ8 ż+H`k,="t(KvOi hO@_4$DZ? TGae(V>k'jKa9+*`a/!dz3ɯaegJԔ=fwX1*Qջ?u͝?O򦣬VVE%ꮨ,r+{q l{4B}j"!IF×t|K,[l}T&t/>k&첆N\pРMdeiy2E,B{z0(ﮯi _fSzϖ3vr8(6g8SO%RTp"HHGq.*xRRB!Fx\ITD1ȳH! 1_"9ܤ/4GZlRfM:N=[{~<8 ]gAj?"o]˾!2[ |@E[eº#kL`)~6lYVVX ;mw0QqqW"y޼E[+2hT?0@endstream endobj 107 0 obj << /Filter /FlateDecode /Length 4582 >> stream x\Is3ǔ9RN*q̪l(.#n#-˿>hfm9*q8i4z~ԛ7#ysLO7O8lSvszuDʍvr>lГۣo_I !>u;k'f{_1j7lLocVo: Fk-Wxe3*4DMmW@.<'!'w015_}2 +(DwԆH3ij#mN jt@K!}ʒ J l[X = @ <~9rn ۫Sc f$7)$jHߌ9!9An<0\GZqhˮ?!j%uCH?)iM ;/#BM7Zp]]A^M~ȮϲoHy͚S6if\klHs2)$&͡hThtEbwd>+dAK0e9߾`D_E:$B>BX(üU3䊦QBH#,U+*dˑOeçkbG(MD!+_c&'|^FɌbAuwT4-*{$%gYꐃH|Lk풑y'@` ͧ \JC&c`$&Jqyh쭪!OZb!g3b*>1 Q]\\G0HރuURi?ɟ 9GFP.ZúL֧HF@~[ 0?%m.dcIg. ^ҜZ'|4PMʐ ywl!A5s2ZG T*8EqSۿ$dJIUh m@>4X_-!vN(U-M~WO5/mZ0:Om"+&/maHU^,!R5lQ?/p%a,)U&gPzg0uAl3$NN s} E,xAh7ݱgO,yk#Z7a},E!q5^خ|^W@gJ o~s!IAP*PZpZͭ\rLOm\(]fmqH'?ҔC_DQ %Dt+RaǮ6v.i=7-c\ZuIϹ!˸8`g+^,lELE ӦYI8LKWʠ=N|ehGWitNzNd>UlF}ّ^] پj2Pj{+sNSa3Tܐ~%+fhtO.v>F&mK~Rж#wbs&c„T pmԢ#XK"KԌJOc(B6D?:C۶ԶVZ:7ᎁ1b¥czIk$~Yg((!Iu}b>R!_aV3mML#:~`CrxF8Cmؘ yY|L cpR+AK#+.띛66<auex7&=GݒғP|7Az.ʁ8anwHѤR9Q 8]<ϵTqYJ,dB"8*/u[q7~K Z[Qj=])kb}C;Sp{pFG[!sj,*Ӝ*Af3':ϛ66E~j80@7$a`7Vk6P ;dbcx8}=9ikIo+ <."o!oP[5A#eq /BTKOȺ3F]K|ցqTci4<}pG3MRe:^jj[-'j5ᦨ?C!) i]ԡآ#.@NFi!c{_,d! thj,(vѥqXASV5'tUؽq52\Y<=d!eIȜ ~Q.ٲ^!(ƕUZZy0R1HKW۸uZp/E~;նKӇobIJBK`%4]fIGŔR;:;c!u%+|u #`wX4qRo9%â fkmx8낭[:|wDVơmĺY=nW}Y3Zn(B) KI@е;/t)沈zRxvL7\{:[j.Mg;B`%Ϣx.}Ĕ;\CsSSSEȆAH9nf?sسƦ/.S\pWMj0h}vt@l:)O l.|@[[LCRH,mc#^>3FT*dӈ;bMH^{[Q-E7npzi{Z wį̀3|9O~L!fxY[*}q,Pk7GI['2@?:~"xsH]&0xOh@,s^97'h&I+ C鲍c sV`Kir#xpst{|~Jm'}_1D>JfEJIWv%$38pxJKhB4 *yv0ܪ>_&6ggiA~u^3-RV=Xa:)_[4}8)5Ț1ERѰ3>x閎)p|b,v/km9ۖQm# ^uex p+=OuS1KGu$X 9p`pGoaR7>(/#6^`tZ<DcTEfٜκXL3H Aƿ2qaLaE~u?Jendstream 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 [<5fade7bed92ad91ae65080ed3a9f79e3>] >> stream xcb&F~0 $8J@g{f_ ÷FÐГ:d MX DZ R&H5 RLH 3ɒ"E@$)$9JAl)I )D20 endstream endobj startxref 84905 %%EOF plotmo/inst/doc/plotmo-notes.pdf0000644000176200001440000334206113554705460016463 0ustar liggesusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 17851 /N 76 /First 633 >> stream 2 0 3 107 4 364 5 605 6 753 7 804 8 1286 9 1734 10 2195 11 2696 12 3096 13 3425 14 3519 15 3861 16 4140 17 4156 18 4219 19 4367 20 4552 21 4921 22 5151 23 5325 24 5506 25 6037 26 6569 27 6717 28 7155 29 7650 30 8092 31 8539 32 8697 33 8917 34 9075 35 9295 36 9727 37 10073 38 10261 39 10410 40 10558 41 10706 42 11223 43 11815 44 12005 45 12232 46 12554 47 12840 48 12989 49 13139 50 13395 51 13643 52 13659 53 13773 54 13973 55 14171 56 14319 57 14446 58 14629 59 14778 60 14987 61 15003 62 15119 63 15268 64 15451 65 15598 66 15779 67 15926 68 16113 69 16262 70 16342 71 16389 72 16548 73 16675 74 16754 75 16859 76 16990 77 17091 << /Metadata 78 0 R /PageLabels << /Nums [ 0 << /S /D >> 1 << /S /D >> ] >> /Pages 4 0 R /Type /Catalog >> << /Author (Stephen Milborrow) /CreationDate (D:20191025165421-07'00') /Creator (LaTeX with hyperref package) /Keywords () /ModDate (D:20191025165421-07'00') /Producer (GPL Ghostscript 9.19) /Subject (plotmo) /Title (Plotting model surfaces with plotmo) >> << /Count 27 /Kids [ 5 0 R 20 0 R 19 0 R 83 0 R 80 0 R 161 0 R 21 0 R 236 0 R 241 0 R 81 0 R 82 0 R 245 0 R 247 0 R 280 0 R 249 0 R 22 0 R 253 0 R 131 0 R 162 0 R 53 0 R 257 0 R 299 0 R 163 0 R 23 0 R 262 0 R 30 0 R 27 0 R ] /Type /Pages >> << /Contents 310 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 16 0 R /Font 17 0 R /ProcSet [ /PDF /Text ] >> /Type /Page >> << /BM /Normal /OPM 1 /TK true /Type /ExtGState >> << /BaseFont /AVDPEA+CMBX12 /Encoding 72 0 R /FirstChar 12 /FontDescriptor 8 0 R /LastChar 121 /Subtype /Type1 /Type /Font /Widths [ 625 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 581 0 0 0 0 312 437 437 0 0 312 375 312 0 562 562 562 562 562 562 562 562 562 562 312 0 0 0 0 531 0 849 799 812 0 738 707 0 879 418 0 0 675 1067 879 844 768 844 839 625 782 0 0 1162 0 0 0 0 581 0 0 0 0 546 625 500 625 513 343 562 625 312 0 593 312 937 625 562 625 0 459 443 437 625 593 812 593 593 ] >> << /Ascent 750 /CapHeight 700 /CharSet (/A/B/C/E/F/H/I/L/M/N/O/P/Q/R/S/T/W/a/b/c/colon/comma/d/e/eight/f/fi/five/four/g/h/hyphen/i/k/l/m/n/nine/o/one/p/parenleft/parenright/period/question/quotedblleft/quotedblright/quoteright/r/s/seven/six/t/three/two/u/v/w/x/y/zero) /Descent -251 /Flags 6 /FontBBox [ 0 -251 1139 750 ] /FontFile3 311 0 R /FontName /AVDPEA+CMBX12 /ItalicAngle 0 /MissingWidth 500 /StemV 144 /Type /FontDescriptor /XHeight 456 >> << /BaseFont /INOASV+CMTT12 /Encoding /WinAnsiEncoding /FirstChar 34 /FontDescriptor 10 0 R /LastChar 126 /Subtype /Type1 /Type /Font /Widths [ 514 514 0 0 0 0 514 514 514 514 514 514 514 514 514 514 514 514 514 514 0 514 0 514 514 0 514 514 0 0 0 514 0 514 0 514 514 0 0 0 0 0 514 514 514 514 514 0 514 514 514 514 0 0 0 0 0 514 0 514 0 0 0 514 514 514 514 514 514 514 514 514 514 514 514 514 514 514 514 514 514 514 514 514 514 514 514 514 514 0 0 0 514 ] >> << /Ascent 694 /AvgWidth 514 /CapHeight 625 /CharSet (/A/C/E/F/L/M/N/O/P/R/S/T/U/a/asciitilde/asterisk/b/bracketleft/bracketright/c/colon/comma/d/e/equal/f/five/four/g/h/hyphen/i/j/k/l/less/m/n/nine/numbersign/o/one/p/parenleft/parenright/period/plus/q/quotedbl/r/s/seven/slash/t/three/two/u/v/w/x/y/z/zero) /Descent -229 /Flags 33 /FontBBox [ -1 -229 524 694 ] /FontFile3 312 0 R /FontName /INOASV+CMTT12 /ItalicAngle 0 /MaxWidth 514 /MissingWidth 514 /StemV 78 /Type /FontDescriptor /XHeight 443 >> << /BaseFont /FXCXSZ+Helvetica /Encoding 69 0 R /FirstChar 32 /FontDescriptor 12 0 R /LastChar 122 /Subtype /Type1 /Type /Font /Widths [ 278 0 0 0 0 0 0 0 0 0 0 0 0 584 278 0 556 556 556 556 556 556 556 556 556 556 0 0 0 0 0 0 0 0 0 0 0 0 611 0 0 0 0 0 0 0 0 0 667 0 722 0 611 0 0 0 0 0 0 0 0 0 0 0 0 556 556 500 556 556 0 556 556 222 0 0 222 833 556 556 556 0 333 500 278 556 0 722 500 500 500 ] >> << /Ascent 729 /CapHeight 729 /CharSet (/F/P/R/T/a/b/c/d/e/eight/five/four/g/h/i/l/m/minus/n/nine/o/one/p/period/r/s/seven/six/space/t/three/two/u/w/x/y/z/zero) /Descent -218 /Flags 4 /FontBBox [ 0 -218 762 729 ] /FontFile3 313 0 R /FontName /FXCXSZ+Helvetica /ItalicAngle 0 /MissingWidth 278 /StemV 114 /Type /FontDescriptor >> << /BaseFont /ZapfDingbats /Encoding 73 0 R /Subtype /Type1 /ToUnicode 314 0 R /Type /Font >> << /BaseFont /NKGHPW+CMR17 /Encoding /WinAnsiEncoding /FirstChar 44 /FontDescriptor 15 0 R /LastChar 119 /Subtype /Type1 /Type /Font /Widths [ 249 0 0 0 458 458 458 0 0 458 0 0 0 458 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 850 0 719 0 0 0 510 0 0 0 0 0 0 0 0 0 0 0 0 0 0 510 406 0 406 0 0 510 249 0 0 249 0 510 458 510 0 354 0 354 0 0 667 ] >> << /Ascent 699 /CapHeight 699 /CharSet (/M/O/S/b/c/comma/e/five/h/i/l/n/nine/o/one/p/r/t/two/w/zero) /Descent -195 /Flags 32 /FontBBox [ 0 -195 796 699 ] /FontFile3 315 0 R /FontName /NKGHPW+CMR17 /ItalicAngle 0 /MissingWidth 500 /StemV 119 /Type /FontDescriptor /XHeight 442 >> << /R7 6 0 R >> << /R10 9 0 R /R12 11 0 R /R14 13 0 R /R15 14 0 R /R8 7 0 R >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 19 0 R /XYZ 85.039 763.654 null ] /Rect [ 84.043 724.417 177.609 734.712 ] /Subtype /Link /Type /Annot >> << /Annots [ 26 0 R 164 0 R 165 0 R ] /Contents 316 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 166 0 R /Font 167 0 R /ProcSet [ /PDF /Text ] >> /Type /Page >> << /Annots [ 18 0 R 157 0 R 158 0 R 159 0 R 160 0 R 234 0 R 235 0 R 237 0 R 238 0 R 239 0 R 240 0 R 242 0 R 243 0 R 244 0 R 246 0 R 248 0 R 250 0 R 251 0 R 252 0 R 254 0 R 255 0 R 256 0 R 258 0 R 259 0 R 260 0 R 261 0 R ] /Contents 317 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 263 0 R /Font 264 0 R /ProcSet [ /PDF /Text ] >> /Type /Page >> << /Annots [ 37 0 R 38 0 R 39 0 R 40 0 R 100 0 R 101 0 R 102 0 R 103 0 R 104 0 R ] /Contents 318 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 105 0 R /Font 106 0 R /ProcSet [ /PDF /Text ] >> /Type /Page >> << /Annots [ 47 0 R 48 0 R ] /Contents 319 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 51 0 R /Font 52 0 R /ProcSet [ /PDF /Text ] >> /Type /Page >> << /Annots [ 56 0 R 57 0 R 58 0 R ] /Contents 320 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 60 0 R /Font 61 0 R /ProcSet [ /PDF /Text ] >> /Type /Page >> << /BaseFont /OTXRBD+CMR12 /Encoding 71 0 R /FirstChar 11 /FontDescriptor 25 0 R /LastChar 124 /Subtype /Type1 /Type /Font /Widths [ 571 543 0 815 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 489 0 0 815 0 271 380 380 0 761 271 326 271 489 489 489 489 489 489 489 489 489 489 489 271 271 0 0 0 462 0 734 693 707 747 666 639 768 734 353 503 761 611 897 734 761 666 761 720 543 707 734 734 1006 0 734 598 271 489 271 0 0 0 489 543 435 543 435 299 489 543 271 299 516 271 815 543 489 543 516 380 386 380 543 516 707 516 516 435 489 979 ] >> << /Ascent 750 /CapHeight 750 /CharSet (/A/B/C/D/E/F/G/H/I/J/K/L/M/N/O/P/Q/R/S/T/U/V/W/Y/Z/a/b/bracketleft/bracketright/c/colon/comma/d/e/eight/emdash/endash/f/ff/ffi/fi/five/four/g/h/hyphen/i/j/k/l/m/n/nine/o/one/p/parenleft/parenright/percent/period/plus/q/question/quotedblleft/quotedblright/quoteright/r/s/semicolon/seven/six/slash/t/three/two/u/v/w/x/y/z/zero) /Descent -251 /Flags 4 /FontBBox [ -34 -251 988 750 ] /FontFile3 321 0 R /FontName /OTXRBD+CMR12 /ItalicAngle 0 /MissingWidth 500 /StemV 148 /Type /FontDescriptor >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 27 0 R /XYZ 85.039 690.76 null ] /Rect [ 338.538 711.134 352.236 725.081 ] /Subtype /Link /Type /Annot >> << /Annots [ 65 0 R 66 0 R 67 0 R 68 0 R 200 0 R 201 0 R 202 0 R 203 0 R 204 0 R 205 0 R 206 0 R 207 0 R 208 0 R 209 0 R 210 0 R 211 0 R 212 0 R 213 0 R 214 0 R 215 0 R 216 0 R 217 0 R 218 0 R 219 0 R 220 0 R 221 0 R 222 0 R 223 0 R 224 0 R 225 0 R 226 0 R 227 0 R 228 0 R 229 0 R 230 0 R ] /Contents 322 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 231 0 R /Font 232 0 R /ProcSet [ /PDF /Text ] >> /Type /Page >> << /BaseFont /OXBULW+CMTI12 /Encoding 75 0 R /FirstChar 11 /FontDescriptor 29 0 R /LastChar 122 /Subtype /Type1 /Type /Font /Widths [ 600 550 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 500 0 0 0 0 300 400 400 0 0 300 350 300 500 500 500 500 500 500 0 500 500 0 0 300 0 0 0 0 500 0 726 688 700 738 663 638 756 0 376 0 0 613 876 726 750 663 750 713 550 700 726 726 976 0 0 0 0 500 0 0 0 0 500 450 450 500 450 300 450 500 300 300 450 250 800 550 500 500 450 412 400 325 525 450 650 450 475 400 ] >> << /Ascent 750 /CapHeight 750 /CharSet (/A/B/C/D/E/F/G/I/L/M/N/O/P/Q/R/S/T/U/V/W/a/b/c/colon/comma/d/e/f/ff/fi/four/g/h/hyphen/i/j/k/l/m/n/o/one/p/parenleft/parenright/period/q/question/quotedblleft/quotedblright/quoteright/r/s/seven/six/slash/t/three/two/u/v/w/x/y/z/zero) /Descent -251 /Flags 4 /FontBBox [ -36 -251 1103 750 ] /FontFile3 323 0 R /FontName /OXBULW+CMTI12 /ItalicAngle 0 /MissingWidth 500 /StemV 165 /Type /FontDescriptor >> << /Annots [ 62 0 R 63 0 R 64 0 R 134 0 R 135 0 R 136 0 R 137 0 R 138 0 R 139 0 R 140 0 R 141 0 R 142 0 R 143 0 R 144 0 R 145 0 R 146 0 R 147 0 R 148 0 R 149 0 R 150 0 R 151 0 R 152 0 R 153 0 R 185 0 R 186 0 R 187 0 R 188 0 R 189 0 R 190 0 R 191 0 R 192 0 R 193 0 R 194 0 R 195 0 R 196 0 R 197 0 R ] /Contents 324 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 198 0 R /Font 199 0 R /ProcSet [ /PDF /Text ] >> /Type /Page >> << /BaseFont /UTYDWN+CMR8 /Encoding /WinAnsiEncoding /FirstChar 49 /FontDescriptor 32 0 R /LastChar 51 /Subtype /Type1 /Type /Font /Widths [ 531 531 531 ] >> << /Ascent 665 /CapHeight 665 /CharSet (/one/three/two) /Descent -21 /Flags 65568 /FontBBox [ 0 -21 486 665 ] /FontFile3 325 0 R /FontName /UTYDWN+CMR8 /ItalicAngle 0 /MissingWidth 500 /StemV 72 /Type /FontDescriptor >> << /BaseFont /UMABGF+CMR7 /Encoding /WinAnsiEncoding /FirstChar 49 /FontDescriptor 34 0 R /LastChar 51 /Subtype /Type1 /Type /Font /Widths [ 569 569 569 ] >> << /Ascent 664 /CapHeight 664 /CharSet (/one/three/two) /Descent -20 /Flags 65568 /FontBBox [ 0 -20 514 664 ] /FontFile3 326 0 R /FontName /UMABGF+CMR7 /ItalicAngle 0 /MissingWidth 500 /StemV 77 /Type /FontDescriptor >> << /BaseFont /FBQRDA+CMR10 /Encoding 77 0 R /FirstChar 12 /FontDescriptor 36 0 R /LastChar 121 /Subtype /Type1 /Type /Font /Widths [ 555 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 500 0 0 0 0 277 0 0 0 0 277 333 277 0 0 0 500 500 0 0 0 0 0 0 0 0 0 0 0 0 0 0 708 0 763 680 652 0 0 0 0 0 0 0 0 0 0 0 0 0 722 0 0 0 0 0 0 0 500 0 0 0 0 500 555 444 555 444 305 500 555 277 0 527 277 833 555 500 555 0 391 394 388 555 527 722 527 527 ] >> << /Ascent 705 /CapHeight 683 /CharSet (/B/D/E/F/T/a/b/c/comma/d/e/f/fi/g/h/hyphen/i/k/l/m/n/o/p/period/quotedblleft/quotedblright/quoteright/r/s/t/three/two/u/v/w/x/y) /Descent -206 /Flags 4 /FontBBox [ 0 -206 813 705 ] /FontFile3 327 0 R /FontName /FBQRDA+CMR10 /ItalicAngle 0 /MissingWidth 500 /StemV 121 /Type /FontDescriptor /XHeight 453 >> << /A << /S /URI /Type /Action /URI (http://www.milbo.org/doc/plotres-notes.pdf) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 104.438 583.546 186.161 598.556 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 30 0 R /XYZ 85.039 421.885 null ] /Rect [ 233.844 478.008 241.689 491.956 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 30 0 R /XYZ 85.039 567.672 null ] /Rect [ 421.867 463.562 429.713 477.51 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 22 0 R /XYZ 85.039 751.698 null ] /Rect [ 509.122 366.592 516.968 380.54 ] /Subtype /Link /Type /Annot >> << /BaseFont /LHYPGD+CMTT10 /Encoding 76 0 R /FirstChar 13 /FontDescriptor 42 0 R /LastChar 126 /Subtype /Type1 /Type /Font /Widths [ 525 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 525 525 525 0 0 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 0 525 525 525 525 525 525 525 525 0 525 525 0 525 525 525 525 0 525 0 0 0 525 525 525 0 525 0 525 525 525 525 525 525 0 0 0 525 525 525 0 0 0 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 0 525 0 525 525 ] >> << /Ascent 694 /AvgWidth 525 /CapHeight 623 /CharSet (/A/C/D/E/F/H/L/M/N/P/R/S/T/U/V/W/a/asciitilde/asterisk/at/b/backslash/braceleft/braceright/bracketleft/bracketright/c/colon/comma/d/dollar/e/eight/equal/f/five/four/g/greater/h/hyphen/i/j/k/l/less/m/n/nine/numbersign/o/one/p/parenleft/parenright/period/plus/q/quotedbl/quoteright/quotesingle/r/s/semicolon/seven/slash/t/three/two/u/v/w/x/y/zero) /Descent -229 /Flags 5 /FontBBox [ -4 -229 537 694 ] /FontFile3 328 0 R /FontName /LHYPGD+CMTT10 /ItalicAngle 0 /MaxWidth 525 /MissingWidth 525 /StemV 80 /Type /FontDescriptor /XHeight 442 >> << /BaseFont /XYEJHW+CMSY10 /Encoding 74 0 R /FirstChar 2 /FontDescriptor 44 0 R /LastChar 15 /Subtype /Type1 /ToUnicode 329 0 R /Type /Font /Widths [ 777 0 0 0 0 0 0 0 0 0 0 0 500 500 ] >> << /Ascent 491 /CapHeight 491 /CharSet (/bullet/multiply/openbullet) /Descent 0 /Flags 4 /FontBBox [ 0 0 630 491 ] /FontFile3 330 0 R /FontName /XYEJHW+CMSY10 /ItalicAngle 0 /MissingWidth 500 /StemV 94 /Type /FontDescriptor >> << /BaseFont /BDGDHK+CMITT10 /Encoding /WinAnsiEncoding /FirstChar 46 /FontDescriptor 46 0 R /LastChar 120 /Subtype /Type1 /Type /Font /Widths [ 525 0 525 525 525 0 0 525 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 525 0 0 0 525 525 0 0 0 0 0 0 0 525 0 525 0 0 0 525 ] >> << /Ascent 622 /AvgWidth 525 /CapHeight 622 /CharSet (/e/five/i/j/one/period/r/t/two/x/zero) /Descent -228 /Flags 33 /FontBBox [ 0 -228 584 622 ] /FontFile3 331 0 R /FontName /BDGDHK+CMITT10 /ItalicAngle 0 /MaxWidth 525 /MissingWidth 525 /StemV 87 /Type /FontDescriptor /XHeight 437 >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 21 0 R /XYZ 85.039 763.654 null ] /Rect [ 300.344 641.103 308.189 653.722 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 22 0 R /XYZ 136.251 117.073 null ] /Rect [ 480.537 560.442 488.382 573.394 ] /Subtype /Link /Type /Annot >> << /BaseFont /ZOXINL+CMBXTI10 /Encoding /WinAnsiEncoding /FirstChar 76 /FontDescriptor 50 0 R /LastChar 116 /Subtype /Type1 /Type /Font /Widths [ 697 1072 0 0 0 0 859 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 591 532 400 532 591 355 0 0 296 0 0 0 0 0 0 0 385 ] >> << /Ascent 702 /CapHeight 686 /CharSet (/L/M/R/d/e/f/g/h/i/l/t) /Descent -202 /Flags 32 /FontBBox [ -19 -202 1180 702 ] /FontFile3 332 0 R /FontName /ZOXINL+CMBXTI10 /ItalicAngle 0 /MissingWidth 500 /StemV 177 /Type /FontDescriptor /XHeight 452 >> << /R7 6 0 R >> << /R10 9 0 R /R12 11 0 R /R139 41 0 R /R176 45 0 R /R199 49 0 R /R66 24 0 R /R77 28 0 R /R8 7 0 R /R90 90 0 R >> << /Annots [ 54 0 R 55 0 R 177 0 R 178 0 R 179 0 R ] /Contents 333 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 180 0 R /Font 181 0 R /ProcSet [ /PDF /Text ] >> /Type /Page >> << /A << /S /URI /Type /Action /URI (http://cran.r-project.org/doc/contrib/Faraway-PRA.pdf) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 350.336 721.246 463.991 736.92 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 30 0 R /XYZ 85.039 739.859 null ] /Rect [ 468.667 721.246 476.512 736.92 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 5 0 R /Fit ] /Rect [ 471.85 657.834 478.575 671.958 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (http://www.milbo.org/doc/modguide.pdf) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 309.083 478.309 497.242 493.984 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 27 0 R /XYZ 85.039 763.654 null ] /Rect [ 503.203 478.309 516.901 493.984 ] /Subtype /Link /Type /Annot >> << /CharProcs << /a36 334 0 R >> /Encoding 70 0 R /FirstChar 36 /FontBBox [ 6 -8 45 69 ] /FontMatrix [ 0.01004 0 0 0.01004 0 0 ] /LastChar 36 /Subtype /Type3 /ToUnicode 335 0 R /Type /Font /Widths [ 51.2 ] >> << /R7 6 0 R >> << /R10 9 0 R /R101 33 0 R /R103 35 0 R /R139 41 0 R /R152 43 0 R /R261 59 0 R /R66 24 0 R /R8 7 0 R /R99 31 0 R >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 53 0 R /XYZ 84.039 817.907 null ] /Rect [ 459.658 716.447 473.356 730.395 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (https://CRAN.R-project.org/package=car) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 167.446 677.925 403.71 690.876 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 21 0 R /XYZ 84.039 817.907 null ] /Rect [ 489.5 677.925 497.345 690.876 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (http://www.milbo.org/doc/modguide.pdf) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 151.027 733.6 380.641 746.551 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 23 0 R /XYZ 84.039 817.907 null ] /Rect [ 466.431 733.6 480.129 746.551 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (http://www.milbo.org/doc/earth-varmod.pdf) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 108.105 694.745 362.825 707.697 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 53 0 R /XYZ 84.039 817.907 null ] /Rect [ 448.615 694.745 462.313 707.697 ] /Subtype /Link /Type /Annot >> << /BaseEncoding /WinAnsiEncoding /Differences [ 45 /minus ] /Type /Encoding >> << /Differences [ 36 /a36 ] /Type /Encoding >> << /BaseEncoding /WinAnsiEncoding /Differences [ 11 /ff /fi 14 /ffi 34 /quotedblright 39 /quoteright 92 /quotedblleft 123 /endash /emdash ] /Type /Encoding >> << /BaseEncoding /WinAnsiEncoding /Differences [ 12 /fi 34 /quotedblright 39 /quoteright 92 /quotedblleft ] /Type /Encoding >> << /BaseEncoding /WinAnsiEncoding /Differences [ 108 /a71 ] /Type /Encoding >> << /BaseEncoding /WinAnsiEncoding /Differences [ 2 /multiply 14 /openbullet /bullet ] /Type /Encoding >> << /BaseEncoding /WinAnsiEncoding /Differences [ 11 /ff /fi 34 /quotedblright 39 /quoteright 92 /quotedblleft ] /Type /Encoding >> << /BaseEncoding /WinAnsiEncoding /Differences [ 13 /quotesingle 39 /quoteright ] /Type /Encoding >> << /BaseEncoding /WinAnsiEncoding /Differences [ 12 /fi 34 /quotedblright 39 /quoteright 92 /quotedblleft ] /Type /Encoding >> endstream endobj 78 0 obj << /Subtype /XML /Type /Metadata /Length 1615 >> stream GPL Ghostscript 9.19 2019-10-25T16:54:21-07:00 2019-10-25T16:54:21-07:00 LaTeX with hyperref package Plotting model surfaces with plotmoStephen Milborrowplotmo endstream endobj 79 0 obj << /Type /ObjStm /Length 11860 /N 76 /First 665 >> stream 80 0 81 205 82 407 83 649 84 851 85 1000 86 1149 87 1298 88 1446 89 1594 90 1740 91 2143 92 2467 93 2483 94 2548 95 2676 96 2826 97 3012 98 3028 99 3048 100 3137 101 3286 102 3434 103 3583 104 3731 105 3962 106 3978 107 4029 108 4178 109 4327 110 4476 111 4623 112 4770 113 4982 114 5135 115 5349 116 5365 117 5445 118 5593 119 5741 120 5890 121 6039 122 6188 123 6337 124 6486 125 6635 126 6783 127 6930 128 7140 129 7156 130 7222 131 7371 132 7541 133 7557 134 7586 135 7774 136 7922 137 8071 138 8298 139 8525 140 8674 141 8863 142 9053 143 9202 144 9386 145 9569 146 9717 147 9907 148 10056 149 10206 150 10390 151 10573 152 10721 153 10910 154 11099 155 11148 << /Annots [ 94 0 R 95 0 R 96 0 R ] /Contents 336 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 97 0 R /Font 99 0 R /ProcSet [ /PDF /ImageC /Text ] /XObject 98 0 R >> /Type /Page >> << /Annots [ 107 0 R 108 0 R 109 0 R 110 0 R 111 0 R ] /Contents 337 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 115 0 R /Font 116 0 R /ProcSet [ /PDF /Text ] >> /Type /Page >> << /Annots [ 117 0 R 118 0 R 119 0 R 120 0 R 121 0 R 122 0 R 123 0 R 124 0 R 125 0 R 126 0 R ] /Contents 338 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 128 0 R /Font 129 0 R /ProcSet [ /PDF /Text ] >> /Type /Page >> << /Annots [ 84 0 R 85 0 R 86 0 R 87 0 R 88 0 R 89 0 R ] /Contents 339 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 92 0 R /Font 93 0 R /ProcSet [ /PDF /Text ] >> /Type /Page >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 30 0 R /XYZ 85.039 354.471 null ] /Rect [ 227.506 498.019 235.352 511.967 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 30 0 R /XYZ 85.039 276.431 null ] /Rect [ 238.133 498.019 251.831 511.967 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 27 0 R /XYZ 85.039 545.306 null ] /Rect [ 254.612 498.019 268.311 511.967 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 27 0 R /XYZ 85.039 506.451 null ] /Rect [ 271.092 498.019 284.79 511.967 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 27 0 R /XYZ 85.039 400.183 null ] /Rect [ 287.571 498.019 301.27 511.967 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 81 0 R /XYZ 85.039 763.654 null ] /Rect [ 429.533 44.631 437.503 57.25 ] /Subtype /Link /Type /Annot >> << /BaseFont /PIXIIO+Helvetica-Bold /Encoding /WinAnsiEncoding /FirstChar 32 /FontDescriptor 91 0 R /LastChar 121 /Subtype /Type1 /Type /Font /Widths [ 278 0 0 0 0 0 0 0 333 333 0 0 0 0 0 0 0 556 556 0 0 0 0 0 0 0 333 0 0 0 0 0 0 0 0 0 0 0 611 0 0 0 0 0 0 0 0 0 667 0 722 0 611 0 0 0 0 0 0 0 0 0 0 0 0 556 611 556 611 556 333 611 611 278 0 0 278 889 611 611 611 611 389 556 333 611 556 778 556 556 ] >> << /Ascent 729 /CapHeight 729 /CharSet (/F/P/R/T/a/b/c/colon/d/e/f/g/h/i/l/m/n/o/one/p/parenleft/parenright/q/r/s/space/t/two/u/v/w/x/y) /Descent -219 /Flags 32 /FontBBox [ 0 -219 824 729 ] /FontFile3 340 0 R /FontName /PIXIIO+Helvetica-Bold /ItalicAngle 0 /MissingWidth 278 /StemV 123 /Type /FontDescriptor /XHeight 549 >> << /R7 6 0 R >> << /R10 9 0 R /R12 11 0 R /R66 24 0 R /R77 28 0 R /R90 90 0 R >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 5 0 R /Fit ] /Rect [ 521.232 593.533 527.957 607.325 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 80 0 R /XYZ 469.257 249.099 null ] /Rect [ 205.241 554.347 213.086 566.966 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (http://www.milbo.org/doc/prp.pdf#page=26) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 233.479 362.167 411.711 377.178 ] /Subtype /Link /Type /Annot >> << /R7 6 0 R >> << /R105 341 0 R >> << /R10 9 0 R /R101 33 0 R /R103 35 0 R /R66 24 0 R /R77 28 0 R /R8 7 0 R /R99 31 0 R >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 80 0 R /XYZ 85.039 657.543 null ] /Rect [ 285.386 284.069 302.336 298.016 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 30 0 R /XYZ 85.039 460.739 null ] /Rect [ 302.928 244.882 310.773 258.83 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 30 0 R /XYZ 85.039 712.462 null ] /Rect [ 362.032 176.804 369.878 190.752 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 30 0 R /XYZ 85.039 673.94 null ] /Rect [ 144.442 162.358 152.288 176.306 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (http://stats.stackexchange.com/questions/21152/obtaining-knowledge-from-a-random-forest) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 111.357 63.662 333.877 78.672 ] /Subtype /Link /Type /Annot >> << /R7 6 0 R >> << /R10 9 0 R /R66 24 0 R /R77 28 0 R /R8 7 0 R >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 30 0 R /XYZ 85.039 276.431 null ] /Rect [ 476.099 711.134 489.797 725.081 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 27 0 R /XYZ 85.039 637.792 null ] /Rect [ 492.252 711.134 505.951 725.081 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 27 0 R /XYZ 85.039 545.306 null ] /Rect [ 508.405 711.134 522.104 725.081 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 27 0 R /XYZ 85.039 453.483 null ] /Rect [ 84.043 696.688 97.742 710.636 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 23 0 R /XYZ 85.039 763.654 null ] /Rect [ 435.288 96.25 448.986 110.198 ] /Subtype /Link /Type /Annot >> << /CharProcs << /a136 342 0 R >> /Encoding 154 0 R /FirstChar 136 /FontBBox [ 5 6 44 44 ] /FontMatrix [ 0.01004 0 0 0.01004 0 0 ] /LastChar 136 /Subtype /Type3 /ToUnicode 343 0 R /Type /Font /Widths [ 48.8 ] >> << /BaseFont /INCFGW+CMMI12 /Encoding /WinAnsiEncoding /FirstChar 60 /FontDescriptor 114 0 R /LastChar 60 /Subtype /Type1 /Type /Font /Widths [ 761 ] >> << /Ascent 527 /CapHeight 527 /CharSet (/less) /Descent -28 /Flags 65568 /FontBBox [ 0 -28 679 527 ] /FontFile3 344 0 R /FontName /INCFGW+CMMI12 /ItalicAngle 0 /MissingWidth 500 /StemV 101 /Type /FontDescriptor >> << /R7 6 0 R >> << /R10 9 0 R /R151 112 0 R /R152 43 0 R /R154 113 0 R /R66 24 0 R /R8 7 0 R >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 30 0 R /XYZ 85.039 606.526 null ] /Rect [ 126.705 696.688 134.55 710.636 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 30 0 R /XYZ 85.039 514.04 null ] /Rect [ 137.331 696.688 145.177 710.636 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 30 0 R /XYZ 85.039 315.285 null ] /Rect [ 147.958 696.688 161.656 710.636 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 30 0 R /XYZ 85.039 209.017 null ] /Rect [ 164.437 696.688 178.136 710.636 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 30 0 R /XYZ 85.039 155.717 null ] /Rect [ 180.917 696.688 194.615 710.636 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 27 0 R /XYZ 85.039 584.492 null ] /Rect [ 197.396 696.688 211.095 710.636 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 27 0 R /XYZ 85.039 453.483 null ] /Rect [ 214.955 696.688 228.654 710.636 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 27 0 R /XYZ 85.039 254.397 null ] /Rect [ 231.435 696.688 245.133 710.636 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 30 0 R /XYZ 85.039 87.639 null ] /Rect [ 391.985 487.899 405.684 501.847 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 81 0 R /XYZ 85.039 763.654 null ] /Rect [ 115.909 60.997 123.755 74.945 ] /Subtype /Link /Type /Annot >> << /CharProcs << /a36 334 0 R >> /Encoding 155 0 R /FirstChar 36 /FontBBox [ 6 -8 45 69 ] /FontMatrix [ 0.01004 0 0 0.01004 0 0 ] /LastChar 36 /Subtype /Type3 /ToUnicode 345 0 R /Type /Font /Widths [ 51.2 ] >> << /R7 6 0 R >> << /R10 9 0 R /R139 41 0 R /R170 127 0 R /R66 24 0 R /R8 7 0 R >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 30 0 R /XYZ 85.039 421.885 null ] /Rect [ 221.649 704.376 229.495 718.324 ] /Subtype /Link /Type /Annot >> << /Annots [ 130 0 R ] /Contents 346 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 132 0 R /Font 133 0 R /ProcSet [ /PDF /Text ] >> /Type /Page >> << /R7 6 0 R >> << /R10 9 0 R /R66 24 0 R >> << /A << /S /URI /Type /Action /URI (https://CRAN.R-project.org/package=effects) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 263.833 624.625 524.705 637.576 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 21 0 R /XYZ 84.039 817.907 null ] /Rect [ 183.544 610.511 191.389 623.13 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 82 0 R /XYZ 84.039 817.907 null ] /Rect [ 511.007 571.657 524.705 584.276 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (https://statistics.stanford.edu/research/multivariate-adaptive-regression-splines) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 329.103 532.138 527.957 546.086 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (https://statistics.stanford.edu/research/multivariate-adaptive-regression-splines) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 108.105 518.025 413.037 530.976 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 21 0 R /XYZ 84.039 817.907 null ] /Rect [ 498.826 518.025 506.672 530.976 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (https://CRAN.R-project.org/package=neuralnet) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 433.187 479.17 527.957 492.122 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (https://CRAN.R-project.org/package=neuralnet) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 108.105 464.725 288.504 477.676 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 82 0 R /XYZ 84.039 817.907 null ] /Rect [ 374.293 464.725 387.992 477.676 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (https://CRAN.R-project.org/package=pdp) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 489.053 439.984 527.957 453.932 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (https://CRAN.R-project.org/package=pdp) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 108.105 425.87 307.458 438.822 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 21 0 R /XYZ 84.039 817.907 null ] /Rect [ 393.247 425.87 401.093 438.822 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (http://web.stanford.edu/~hastie/ElemStatLearn) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 184.968 372.57 463.797 385.522 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 21 0 R /XYZ 84.039 817.907 null ] /Rect [ 140.037 358.456 147.882 371.076 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 131 0 R /XYZ 84.039 817.907 null ] /Rect [ 172.553 358.456 186.252 371.076 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (https://CRAN.R-project.org/package=gam) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 476.749 333.384 527.957 347.331 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (https://CRAN.R-project.org/package=gam) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 108.105 319.27 295.154 332.221 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 83 0 R /XYZ 84.039 817.907 null ] /Rect [ 380.943 319.27 388.789 332.221 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (https://CRAN.R-project.org/package=quantreg) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 445.989 294.529 527.957 308.477 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (https://CRAN.R-project.org/package=quantreg) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 108.105 280.416 295.154 293.367 ] /Subtype /Link /Type /Annot >> << /Differences [ 136 /a136 ] /Type /Encoding >> << /Differences [ 36 /a36 ] /Type /Encoding >> endstream endobj 156 0 obj << /Type /ObjStm /Length 11630 /N 76 /First 682 >> stream 157 0 158 147 159 295 160 444 161 594 162 772 163 974 164 1152 165 1301 166 1450 167 1466 168 1517 169 1666 170 1816 171 1964 172 2113 173 2262 174 2411 175 2560 176 2576 177 2640 178 2827 179 2976 180 3124 181 3140 182 3227 183 3376 184 3523 185 3539 186 3688 187 3837 188 4030 189 4179 190 4328 191 4523 192 4672 193 4822 194 5008 195 5193 196 5340 197 5513 198 5660 199 5676 200 5727 201 5914 202 6063 203 6247 204 6431 205 6580 206 6729 207 6921 208 7113 209 7262 210 7446 211 7595 212 7744 213 7893 214 8079 215 8228 216 8377 217 8525 218 8706 219 8887 220 9035 221 9184 222 9369 223 9554 224 9702 225 9851 226 10036 227 10221 228 10370 229 10556 230 10742 231 10891 232 10907 << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 19 0 R /XYZ 85.039 391.838 null ] /Rect [ 84.043 695.941 159.917 708.56 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 80 0 R /XYZ 85.039 751.698 null ] /Rect [ 84.043 672.114 170.592 682.408 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 80 0 R /XYZ 85.039 657.543 null ] /Rect [ 101.602 657.668 232.031 667.963 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 161 0 R /XYZ 85.039 763.654 null ] /Rect [ 101.602 643.222 234.797 653.517 ] /Subtype /Link /Type /Annot >> << /Annots [ 168 0 R 169 0 R ] /Contents 347 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 266 0 R /Font 267 0 R /ProcSet [ /PDF /Text ] >> /Type /Page >> << /Annots [ 170 0 R 171 0 R 172 0 R 173 0 R 174 0 R ] /Contents 348 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 175 0 R /Font 176 0 R /ProcSet [ /PDF /Text ] >> /Type /Page >> << /Annots [ 182 0 R 183 0 R ] /Contents 349 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 184 0 R /Font 303 0 R /ProcSet [ /PDF /Text ] >> /Type /Page >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 22 0 R /XYZ 85.039 751.698 null ] /Rect [ 372.183 414.081 380.028 428.029 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 83 0 R /XYZ 136.251 105.735 null ] /Rect [ 467.058 322.05 474.903 334.669 ] /Subtype /Link /Type /Annot >> << /R7 6 0 R >> << /R10 9 0 R /R66 24 0 R /R77 28 0 R /R8 7 0 R >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 23 0 R /XYZ 85.039 763.654 null ] /Rect [ 454.873 662.284 468.571 674.903 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 163 0 R /XYZ 85.039 763.654 null ] /Rect [ 514.258 579.096 527.957 593.043 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 53 0 R /XYZ 137.972 73.736 null ] /Rect [ 471.714 685.57 479.559 699.517 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 30 0 R /XYZ 85.039 315.285 null ] /Rect [ 299.758 183.396 313.457 197.344 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 30 0 R /XYZ 85.039 209.017 null ] /Rect [ 316.238 183.396 329.936 197.344 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 27 0 R /XYZ 85.039 637.792 null ] /Rect [ 332.717 183.396 346.416 197.344 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 27 0 R /XYZ 85.039 308.029 null ] /Rect [ 349.197 183.396 362.895 197.344 ] /Subtype /Link /Type /Annot >> << /R7 6 0 R >> << /R10 9 0 R /R139 41 0 R /R66 24 0 R /R77 28 0 R /R8 7 0 R >> << /A << /S /URI /Type /Action /URI (http://www.milbo.org/doc/earth-varmod.pdf) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 149.401 708.527 283.341 722.475 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 27 0 R /XYZ 85.039 729.615 null ] /Rect [ 288.502 708.527 302.201 722.475 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 27 0 R /XYZ 85.039 346.551 null ] /Rect [ 486.875 459.71 500.573 473.657 ] /Subtype /Link /Type /Annot >> << /R7 6 0 R >> << /R10 9 0 R /R12 11 0 R /R14 13 0 R /R66 24 0 R /R77 28 0 R /R8 7 0 R /R90 90 0 R >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 23 0 R /XYZ 85.039 763.654 null ] /Rect [ 164.359 554.388 178.058 568.336 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 23 0 R /XYZ 85.039 763.654 null ] /Rect [ 456.944 43.001 470.642 56.949 ] /Subtype /Link /Type /Annot >> << /R7 6 0 R >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 82 0 R /XYZ 84.039 817.907 null ] /Rect [ 385.561 280.416 399.259 293.367 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 162 0 R /XYZ 84.039 817.907 null ] /Rect [ 423.93 280.416 437.629 293.367 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (https://CRAN.R-project.org/package=randomForest) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 233.074 227.116 524.705 240.067 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 83 0 R /XYZ 84.039 817.907 null ] /Rect [ 188.161 213.002 196.007 225.621 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 81 0 R /XYZ 84.039 817.907 null ] /Rect [ 220.678 213.002 228.523 225.621 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (https://CRAN.R-project.org/package=quantregForest) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 157.443 173.815 461.378 186.767 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 82 0 R /XYZ 84.039 817.907 null ] /Rect [ 140.037 159.702 153.735 172.321 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 162 0 R /XYZ 84.039 817.907 null ] /Rect [ 178.406 159.702 192.105 172.321 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (https://CRAN.R-project.org/package=e1071) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 489.053 105.737 527.957 119.685 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (https://CRAN.R-project.org/package=e1071) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 108.105 91.624 319.762 104.575 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 82 0 R /XYZ 84.039 817.907 null ] /Rect [ 405.551 91.624 419.25 104.575 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (http://www.milbo.org/rpart-plot) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 199.299 52.769 392.5 65.721 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 82 0 R /XYZ 84.039 817.907 null ] /Rect [ 478.289 52.769 491.988 65.721 ] /Subtype /Link /Type /Annot >> << /R7 6 0 R >> << /R10 9 0 R /R66 24 0 R /R77 28 0 R /R8 7 0 R >> << /A << /S /URI /Type /Action /URI (https://CRAN.R-project.org/package=plotmo) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 232.583 655.891 487.303 668.842 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 19 0 R /XYZ 84.039 817.907 null ] /Rect [ 151.678 641.777 159.523 653.799 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (http://www.milbo.users.sonic.net/earth) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 421.382 602.591 527.957 615.542 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (http://www.milbo.users.sonic.net/earth) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 108.105 588.477 239.289 601.096 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 81 0 R /XYZ 84.039 817.907 null ] /Rect [ 329.695 588.477 337.541 601.096 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 162 0 R /XYZ 84.039 817.907 null ] /Rect [ 362.212 588.477 375.91 601.096 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (https://CRAN.R-project.org/package=glmnetUtils) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 433.187 563.404 527.957 577.352 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (https://CRAN.R-project.org/package=glmnetUtils) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 108.105 549.291 300.808 562.242 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 82 0 R /XYZ 84.039 817.907 null ] /Rect [ 386.597 549.291 400.296 562.242 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (https://CRAN.R-project.org/package=gbm) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 132.168 510.436 368.432 523.388 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 83 0 R /XYZ 84.039 817.907 null ] /Rect [ 458.838 510.436 466.684 523.388 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 81 0 R /XYZ 84.039 817.907 null ] /Rect [ 471.845 510.436 479.691 523.388 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 82 0 R /XYZ 84.039 817.907 null ] /Rect [ 507.613 510.436 521.312 523.388 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (https://CRAN.R-project.org/package=rpart) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 236.844 471.582 485.412 484.534 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 83 0 R /XYZ 84.039 817.907 null ] /Rect [ 156.295 457.468 164.141 470.088 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 81 0 R /XYZ 84.039 817.907 null ] /Rect [ 169.302 457.468 177.147 470.088 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 82 0 R /XYZ 84.039 817.907 null ] /Rect [ 205.07 457.468 218.768 470.088 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (http://www.stats.ox.ac.uk/pub/MASS4) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 341.406 418.282 527.957 431.233 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (http://www.stats.ox.ac.uk/pub/MASS4) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 108.105 404.168 140.858 416.788 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 81 0 R /XYZ 84.039 817.907 null ] /Rect [ 231.264 404.168 239.11 416.788 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 82 0 R /XYZ 84.039 817.907 null ] /Rect [ 263.781 404.168 277.479 416.788 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (https://CRAN.R-project.org/package=MASS) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 359.364 364.982 527.957 377.933 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (https://CRAN.R-project.org/package=MASS) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 108.105 350.536 183.921 363.487 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 83 0 R /XYZ 84.039 817.907 null ] /Rect [ 269.71 350.536 277.556 363.487 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 53 0 R /XYZ 84.039 817.907 null ] /Rect [ 151.678 312.014 165.376 324.035 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (https://CRAN.R-project.org/package=mgcv) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 359.364 272.827 527.957 285.779 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (https://CRAN.R-project.org/package=mgcv) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 108.105 258.382 183.921 271.333 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 162 0 R /XYZ 84.039 817.907 null ] /Rect [ 269.71 258.382 283.409 271.333 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (https://CRAN.R-project.org/package=cosso) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 433.187 219.527 527.957 232.479 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (https://CRAN.R-project.org/package=cosso) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 108.105 205.082 263.896 218.033 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 82 0 R /XYZ 84.039 817.907 null ] /Rect [ 349.686 205.082 363.384 218.033 ] /Subtype /Link /Type /Annot >> << /R7 6 0 R >> << /R10 9 0 R /R66 24 0 R /R77 28 0 R >> endstream endobj 233 0 obj << /Type /ObjStm /Length 9572 /N 76 /First 675 >> stream 234 0 235 148 236 297 237 483 238 633 239 782 240 928 241 1077 242 1227 243 1375 244 1523 245 1668 246 1838 247 1987 248 2165 249 2315 250 2465 251 2613 252 2762 253 2911 254 3081 255 3231 256 3379 257 3527 258 3721 259 3870 260 4018 261 4164 262 4312 263 4462 264 4478 265 4517 266 4727 267 4743 268 4796 269 4943 270 5093 271 5281 272 5297 273 5348 274 5364 275 5416 276 5567 277 5583 278 5684 279 5832 280 5982 281 6132 282 6148 283 6200 284 6216 285 6294 286 6310 287 6349 288 6477 289 6655 290 6881 291 6897 292 7000 293 7147 294 7297 295 7447 296 7707 297 7723 298 7775 299 7925 300 8095 301 8111 302 8175 303 8385 304 8464 305 8674 306 8690 307 8756 308 8803 309 8850 << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 21 0 R /XYZ 85.039 763.654 null ] /Rect [ 84.043 614.746 237.508 627.365 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 236 0 R /XYZ 85.039 763.654 null ] /Rect [ 84.043 590.918 177.773 601.213 ] /Subtype /Link /Type /Annot >> << /Annots [ 268 0 R 269 0 R 270 0 R ] /Contents 350 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 271 0 R /Font 272 0 R /ProcSet [ /PDF /Text ] >> /Type /Page >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 236 0 R /XYZ 85.039 696.065 null ] /Rect [ 101.602 574.148 190.509 586.767 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 236 0 R /XYZ 85.039 507.232 null ] /Rect [ 101.602 559.37 318.189 572.321 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 236 0 R /XYZ 85.039 136.514 null ] /Rect [ 101.602 545.256 240 557.876 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 241 0 R /XYZ 85.039 616.206 null ] /Rect [ 101.602 530.478 287.429 543.43 ] /Subtype /Link /Type /Annot >> << /Contents 351 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 273 0 R /Font 274 0 R /ProcSet [ /PDF /Text ] >> /Type /Page >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 81 0 R /XYZ 85.039 763.654 null ] /Rect [ 84.043 504.659 272.972 517.278 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 82 0 R /XYZ 85.039 763.654 null ] /Rect [ 84.043 478.507 295.308 491.126 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 245 0 R /XYZ 85.039 751.698 null ] /Rect [ 101.602 463.729 313 476.68 ] /Subtype /Link /Type /Annot >> << /Annots [ 275 0 R ] /Contents 352 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 276 0 R /Font 277 0 R /ProcSet [ /PDF /Text ] >> /Type /Page >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 247 0 R /XYZ 85.039 751.698 null ] /Rect [ 84.043 440.234 226.518 450.529 ] /Subtype /Link /Type /Annot >> << /Annots [ 278 0 R 279 0 R ] /Contents 353 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 281 0 R /Font 282 0 R /ProcSet [ /PDF /Text ] >> /Type /Page >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 249 0 R /XYZ 85.039 763.654 null ] /Rect [ 101.602 425.788 232.681 436.083 ] /Subtype /Link /Type /Annot >> << /Contents 354 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 285 0 R /Font 286 0 R /ProcSet [ /PDF /Text ] >> /Type /Page >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 22 0 R /XYZ 85.039 751.698 null ] /Rect [ 84.043 396.647 391.087 410.595 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 22 0 R /XYZ 85.039 636.905 null ] /Rect [ 101.602 382.866 191.645 395.485 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 253 0 R /XYZ 85.039 635.011 null ] /Rect [ 101.602 368.42 326.329 381.039 ] /Subtype /Link /Type /Annot >> << /Annots [ 287 0 R ] /Contents 355 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 290 0 R /Font 291 0 R /ProcSet [ /PDF /Text ] >> /Type /Page >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 253 0 R /XYZ 85.039 194.787 null ] /Rect [ 101.602 353.974 392.537 366.593 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 162 0 R /XYZ 85.039 751.698 null ] /Rect [ 84.043 327.158 348.28 341.106 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 257 0 R /XYZ 85.039 763.654 null ] /Rect [ 84.043 301.671 130.438 314.19 ] /Subtype /Link /Type /Annot >> << /Annots [ 292 0 R 293 0 R 294 0 R 295 0 R ] /Contents 356 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 296 0 R /Font 297 0 R /ProcSet [ /PDF /Text ] >> /Type /Page >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 163 0 R /XYZ 85.039 763.654 null ] /Rect [ 84.043 275.519 247.613 288.038 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 23 0 R /XYZ 85.039 763.654 null ] /Rect [ 84.043 249.367 254.104 261.986 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 23 0 R /XYZ 85.039 421.63 null ] /Rect [ 101.602 237.246 220.65 247.54 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 262 0 R /XYZ 85.039 644.642 null ] /Rect [ 101.602 222.8 296.188 233.095 ] /Subtype /Link /Type /Annot >> << /Contents 357 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 305 0 R /Font 306 0 R /ProcSet [ /PDF /Text ] >> /Type /Page >> << /R7 6 0 R >> << /R10 9 0 R /R66 24 0 R /R8 7 0 R >> << /CharProcs << /a36 334 0 R >> /Encoding 307 0 R /FirstChar 36 /FontBBox [ 6 -8 45 69 ] /FontMatrix [ 0.01004 0 0 0.01004 0 0 ] /LastChar 36 /Subtype /Type3 /ToUnicode 358 0 R /Type /Font /Widths [ 51.2 ] >> << /R7 6 0 R >> << /R10 9 0 R /R114 265 0 R /R66 24 0 R /R8 7 0 R >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 81 0 R /XYZ 85.039 763.654 null ] /Rect [ 429.661 537.41 437.506 550.03 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 247 0 R /XYZ 85.039 751.698 null ] /Rect [ 125.515 251.275 133.361 264.226 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (http://www.milbo.org/doc/plotres-notes.pdf) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 108.105 152.246 189.829 167.257 ] /Subtype /Link /Type /Annot >> << /R7 6 0 R >> << /R10 9 0 R /R66 24 0 R /R77 28 0 R /R8 7 0 R >> << /R7 6 0 R >> << /R10 9 0 R /R139 41 0 R /R66 24 0 R /R8 7 0 R >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 245 0 R /XYZ 491.364 350.218 null ] /Rect [ 401.206 649.996 409.052 663.944 ] /Subtype /Link /Type /Annot >> << /R7 6 0 R >> << /R10 9 0 R /R12 11 0 R /R139 41 0 R /R176 45 0 R /R66 24 0 R /R77 28 0 R /R8 7 0 R /R90 90 0 R >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 236 0 R /XYZ 85.039 507.232 null ] /Rect [ 259.47 616.655 276.42 630.602 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 280 0 R /XYZ 393.688 759.39 null ] /Rect [ 486.206 369.415 494.051 382.367 ] /Subtype /Link /Type /Annot >> << /Contents 359 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 283 0 R /Font 284 0 R /ProcSet [ /PDF /Text ] >> /Type /Page >> << /R7 6 0 R >> << /R10 9 0 R /R139 41 0 R /R66 24 0 R /R8 7 0 R >> << /R7 6 0 R >> << /R10 9 0 R /R12 11 0 R /R139 41 0 R /R66 24 0 R /R77 28 0 R /R90 90 0 R >> << /R7 6 0 R >> << /R10 9 0 R /R66 24 0 R /R8 7 0 R >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 5 0 R /Fit ] /Rect [ 393.097 476.356 399.821 490.812 ] /Subtype /Link /Type /Annot >> << /BaseFont /NCOAXI+CMTI10 /Encoding /WinAnsiEncoding /FirstChar 97 /FontDescriptor 289 0 R /LastChar 108 /Subtype /Type1 /Type /Font /Widths [ 511 0 0 0 0 0 0 0 0 0 0 255 ] >> << /Ascent 694 /CapHeight 694 /CharSet (/a/l) /Descent -11 /Flags 131104 /FontBBox [ 0 -11 535 694 ] /FontFile3 360 0 R /FontName /NCOAXI+CMTI10 /ItalicAngle 0 /MissingWidth 500 /StemV 80 /Type /FontDescriptor /XHeight 442 >> << /R7 6 0 R >> << /R10 9 0 R /R101 33 0 R /R103 35 0 R /R206 288 0 R /R66 24 0 R /R77 28 0 R /R8 7 0 R /R99 31 0 R >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 81 0 R /XYZ 85.039 763.654 null ] /Rect [ 311.955 660.739 319.8 674.687 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 241 0 R /XYZ 85.039 616.206 null ] /Rect [ 234.557 425.528 251.507 438.147 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 236 0 R /XYZ 85.039 507.232 null ] /Rect [ 481.092 425.528 498.042 438.147 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (https://stats.stackexchange.com/questions/329133/interpreting-partial-dependence-plots-marginal-effects-using-plotmo) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 84.043 368.84 440.007 385.179 ] /Subtype /Link /Type /Annot >> << /R7 6 0 R >> << /R10 9 0 R /R139 41 0 R /R66 24 0 R /R8 7 0 R >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 241 0 R /XYZ 85.039 616.206 null ] /Rect [ 194.988 626.958 211.938 640.905 ] /Subtype /Link /Type /Annot >> << /Annots [ 298 0 R ] /Contents 361 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 300 0 R /Font 301 0 R /ProcSet [ /PDF /Text ] >> /Type /Page >> << /R7 6 0 R >> << /R10 9 0 R /R139 41 0 R /R66 24 0 R /R77 28 0 R /R8 7 0 R >> << /CharProcs << /a36 334 0 R >> /Encoding 309 0 R /FirstChar 36 /FontBBox [ 6 -8 45 69 ] /FontMatrix [ 0.01004 0 0 0.01004 0 0 ] /LastChar 36 /Subtype /Type3 /ToUnicode 362 0 R /Type /Font /Widths [ 51.2 ] >> << /R10 9 0 R /R139 41 0 R /R152 43 0 R /R253 302 0 R /R66 24 0 R /R8 7 0 R >> << /CharProcs << /a36 334 0 R >> /Encoding 308 0 R /FirstChar 36 /FontBBox [ 6 -8 45 69 ] /FontMatrix [ 0.01004 0 0 0.01004 0 0 ] /LastChar 36 /Subtype /Type3 /ToUnicode 363 0 R /Type /Font /Widths [ 51.2 ] >> << /R7 6 0 R >> << /R10 9 0 R /R152 43 0 R /R266 304 0 R /R66 24 0 R /R8 7 0 R >> << /Differences [ 36 /a36 ] /Type /Encoding >> << /Differences [ 36 /a36 ] /Type /Encoding >> << /Differences [ 36 /a36 ] /Type /Encoding >> endstream endobj 310 0 obj << /Filter /FlateDecode /Length 15528 >> stream x}َ,q{}E>|_^ fH^`>hzc]\ZM;<2#=)m$,ōmn盻~Uo}7_v ^Jȷ/߾/zy'[it鳻ޛ?~柳sOݧϱfostO?w\{_~V~_porxjX~?vO Dk! ŹwG9tc}?/˗_ݡ[>\?~xK-|燷߽DH%~/~/oftKѕ{bȭ{y<כOB)Vp1C9u<9v~xr~ki_pK /J%]>}1tPn˯Qǃ,rt])˽ǓKE$K%=KǓKcN{Q 2%BDB[6xЦ [jRu'*wz0p$TǓ\j)Cbw&HV77H/%>~/?>}:I>[jA?O> ) b  4k5QUR'+C]!*`&5¢m,ytu&zIS$^xT{V:42?}"graŸjsG, eA3mڜκ&6+΂vh6Ȁ6ް%nU̸Ն,^ϱ0Ψsգ \3-je@bx:H#Wd G]&G ZrWoS]x V6}Ц 7}ylgyJAjhxqSDwi 0ԛ@㠍ުM>nu `;$LI&Hj!bh>h6Dua7iGZ0)a- ["G\ؤiW P GJU2zv-xEt`t_9>؂'h5\la IޣOV3ɪB/X6óݶg)hעE;U܄g{]?"TVa@c\BHKFc R8wJVh1:]VyIЪsʻL,ލPWv^B1zlt Ѥ^іHi 킼.TcWDa 98.myYsVN3c\i7>N$$9 'po t%];@Iw jNǐO||"^eñ|o c<`a' UFO;Oj.- 5a @/YBk|‹5>*xH L“ʓp0AD#jDO O H.dxPZawJ$ Qwffr.&1#bC 'S"u*Ũ*cZb) 9ez?uW@y?',: ɬ,Q7dy<)cB-a97SA򉬇(1:g lj:QgM"ny:`Č=Кz<$ y(PeRǨ[Qγ]LJFVf3,I3ܽx<0Va(Z[scϚ0jE+Z d7-ǂ&97fjl?ͦaK4q>EŶJv >hLrp;&4(n|` nJ>/f5>0fm4"6@n|`*CfyljTW8U5LBQROvEbDv5 Hiv; n`N8sFXF.E'`D Fqٛ{/#NhRE ͝ZdžBJo7@UfkKl (X]롇(\հ OpjAzp yR&] 4]vBun`d>o7@0AVqye vƱbA>DT%Y\]b1\#ٍdiX.޲_Y8yƆj{\E3h1;|l7APsx9aB1 H7g0i|&"tjY ,8D}">VpNn s ~Y7a5A0Hڙ!nS)CF"!V#Q{6 n7B0qq!K;sV#_%Wd7B gZ򜷚! kf2 `[uGl7D6{5"s9Gon`̆`-p}̴AL~"쓋cMDnr`mz͆)+=[ |VC&n7D2] &e)O"؍D FZ(n `6A*\r |0 H z \$ ,)M&Dn`&hc2ANIVRc5A&bfof8@b7@B)V!, s X1Feo8@&& r3AC&j AHo4AP Kr H V\|Q!j nmKٙMAG )v^ 9Kwo6>7q-gfXXVb6>t뙍dL /n~ }Jb5>0eH_4('n7?PoV"nfd7? 2 j D ޢWxl6fah7@0q H0-$OvA:Ș-g5@Rva!9%1 m7 s;&t$vʹ fXMɇ l6=*3a8=΢@ 9' |ᬆ@Mnx h7<OpE]MdzWrvqF%LvA2lv#> _<@pk6<09THIlx < mpLr"hjx c5=fkOcf҃7pvRwmp| 0IoaɆifQg6?s@6ku&)sn~ d\ .X ۃH&7Xn KX C+VVjDc Gx'2uġf#\pF"YCv3v3aָf>v~($C`d7D;  AV9jAדAV9l7EG|vp6b{hng, n ^p nT,]ͦVA޲"]pೝ%gu=h 8@^:n~ /XX@la0{ |1d~ вd5?;c2?qgj~ ajv M.VEd,5ف@2Bفfi/ᙢ@Z4i5<0MHv3|dC_@vK& Vql]RGvY0pD MT` vw..eCpyagX{d,/7HKnl6>C4Y.X$GQqm&j| >v]>{O>V7k@;C?ojC㠯YXOU"> OpjYT6K( ''QDo=Dg'sjv>x\OFB%nIQn(rxc:gwS$ȇ+Eyٺ}_FJ:ZC~yaJS Eo7=[dsppE"FecكNZdC[(.uE}ݛײiuƂ/R|BQU@L<1!>Fk &Wn?=M9A&lNZc*7?p@=1q:[RQLhZ9mMw~{5.\0#~ƴgSO'0G.Lۘ [ j'99t QM:(g H1sʗA>@~ m BC䟆&:b"Nb2*yl3?XLE T%cXےʓ['s'r(-8. }S=R|…}@~rt6W xeh<a\'}QX{P#ozfV/d;z9:9J\]'N۪B,RB3ؚ*zR舢nEv"ҏGδ_D.b|+թHXRj(0#hGqS C㳏q d@GB Xw,A:NFB %(ϽsPwO BϨaP,;[Hǭ7wA<"KA^g \s'z+ SƦCoҦ<(M%eV͝m )l NiNCT"}TMjO9$ OɓK_ԋ! (NWpyxFj+" HI6ҽn]{EUX4`'+x2Qޓ/7l4p/v^A)ibR;^Po" - .zg;><23;TN兮{9dHk)_4`#+kH'So Ǣ;^ysvT#…9 `()NyViʫЭV "^cx~tGv l0a:(C/;0ina~!IvʳF8 LJjSƴ[WFjkүQ cBBh2]k: kh+s@u$$Xk;+oK^5q~mtgɱA.Y]^٤`;YQˇHe/MlOmpmb)O5=|mNCW I}wrG妝Ԁfp"!s:}XؑNAm2 d3T[W0Wmx- :֓s彞~pgV>ysp#fz ܏E72g9#sVǤ;\4S.:Sϕ; ѫ_Erh;\!av;\Cd28]fAUw깲G]8G-`yim(N }=ؙS㪬n4R<"NWsyL&hDpB?iva}NqGEm @#6!~`,.ytrj]b+d-ȏxy"*=Ԩ¢.aM J,.|h!Kz6{v]~X돠salOг-|? `ee9iP ՘zv`׽gf=T\{'١8&q=6-WaBW7?,JAW~WaE.r6tАwv0^㶌u0,?r F$faMjENʔ0eL*Sf҂9W)'k.u$A p@mXL3W]tv R# E XbbvI y1?Bkh|D@e bͨA@Jc8d#Q1aVZ .F!cI:j) _SzxЅ>E+j+zb!'* mWTqzO};_"^ vh Ջh&@ہ"Sg3lᄓO5pWc w$U/k<0z .wXF6txZ83 WzhF.xUz7<˪k5;@\ b>Q)(+bp+?œH~f)4\86&وByZ vxr)W]ƕ+ka&j`Z2V0ƽ+mjK_OK>+mkfD8۽*jmGH`|?˟d@2&WH|LקnϒED* vh)p<%m5\'Dۡ*Sp$;U]HD̈CU 4|T,ˠnW1#VRiO]pA^ZquEZRMK+7H:k/AE^P%pQ3AѴ HչlF[;,\\G7{UwB~rҘrH<& We_rH8p B&a"TMZ)+:^r+mcaUo|]!mW+ GF34uϐIM|#Qh6vpr˟i $~dMϐë%_`Q=<ë'\0Yн#p dM?ty#90{ kWU , 2PmX`)0yHG\i;ZJKiq> Ӂ1ip´ `22#QIlzuX8"6xHԋ @C)QS#p'MqHsF`; \EZ)bQ̢'!"N#[':+p+nw)2j(fXCX6PD^r@ 7gw GHJҤfNU~&N؅KUv0EQK; 3j 1TpvP򝇝^@t#@-78'<`W\^ڨiƳ X'q A D^'MU^19J&T!*Z9r;/U33m0k,*zwk[=OH"R0J*OU!$ZGJ]%ewW@ہ*Qj0#7EE&(:!jʼnxn3lu9'}*4^r8npQ+aTOhB"Kt5 &٪u1ayzV npNPUx",H@v58AWwǀh]D Sۄ; \61+jỦxW]SVzWHhQB-lT+6SIR1VSב*r CKODyf3z:M@^ mW+jW=KY2>Zv\͇Qp\$K`gSk%[AfƄ;$\\V}:;@Y9+\+le bSNAcG . eaߎhact fe&i &(&pELxڋr>8:-OC:-9D6s ldF`NaZJV iYqE 7;,YyB}[hÒ\|l1!NW/\u5qmԉa+c)G6 ?1Yz/QG 5iBQSj-3T}>qفmIdG_3T}ɡ@M_/\] 6rΔXOhSZBMW g Ȅ;U9j֯XS/h]Ĝ\#5NWƼ yل/`ž\uv c(k90_v+g^O(4q5梵;\Y(QgLQ\vU _$#C⭌\YBZ(HP#uQڝB\QW65Љ_vn'i5[6PP#Ȥ;\xJѦqeRڍB|9莣!_mTJ\v+c^%Cb3=>f(h̬;\yC5YIiwsăONkR欼9jzIxխެ{Q$JvB8MʵQxxש#n_‡nmftG_8)ʓIkSIvJrEeęUB\K}bfʋ28%bjGZ;)zsVҬyU0ɥ7NeVΐ:1G=)>DMzәrU0aAk &کJ1( cSwP|cBiz,;^(7Ǵ$<ǭIwb4fn: XG/C18.&s.lyB"*OĽ> ~'+Wt9qmwT\~'+^dГIK?߉JAV^*,Is1,ozy8wORjCѳd.RN'J8FQYT=<&j!}ΝJ}ht`KP;*$s' J=.[uB$ܭ;NU}:j:qΝ䭤;4P$8ecϝ;gF8tP2 NVQ9wܡdt'+T$w^Qq|/se4R"z׮\,hy|wM7W :1h*B;X)k{dé%h'NY&u"c٬!YrvRRMܥ5{ErvR~عtBwx<;"c>Etv~kt#7qM w[>Uc=EO ^~ܫ O,=sxǽI-6v1Uta%k+w[l\"// 1o6udj E8F w7[m9_ZO;ꌯqo\ w‡-cΑ@Ӛ4xaBI^]y+6aGev ]sćof \\԰Ą׿O=HЃ!gJn~"ƴ 6Tⷜg/ȿEMeJݲTwȪ0&b(nAc!DD%6:O߳LэH޴Spe✾gu '\H/Ƚ\non+?/~nLzq 2|5@DǍݢ-V1t"߯˷?Vn__}?Tt쐯 Tm7:7Y\޽?gQ79v;;w1?|PsﭶN?O4O?qQ^̍|_~V ,$w߾|-_Nwb{K?xpz;x+Y~> 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 5173 >> stream xX TS׺>1prPӂ=[}*U:[gZEPq( a@ IC 0QԊXlUҢڪ굶Zx7}$ծzkg?~76s{y79㓵`pj~JW} 4G|O%SB==^[p4Y3g.X& EK!c(4"L"8\"}} T%_9C! 'X%xGyجE&H~a ƭ$$Je!~I{۰?< bps䖨Kxs^3f6kvڜ_Y8uxXOl &bLl&[m[7!;7/b'A"f׈75lb-1%yO`0b8A$.(b41p%M@|b宅cg=9㶌K>Ѿt >/^ty1/ܦ5ow/J]R`Nfnd5Ï[H@Pd"F7Ę@9YnMM mNpـ|[,ʄK30=]JK$@s l4~>7v?v-\;L25Kl;Po' XAHeC~oi^">~k-ЈQ43"1s \?]-}w.\tT>,0sf1 '7}h NiE34nR?* Z8cDԉVySUfj_DopLfyvP");Q Št(hBva} 8NZZJfU[kugc磸4&AѼ}Y8φk o|ӈ/N?0=5Hhj >Hx?X"hrꄠp ד3>}jfd>4'f^-cxFCi'1s\F\'H(@K#j@p55(V,?InGfg ՐsUn A$R}U1rJCnfޮunAxEv-pU/n83aզ勌K8 *A5(Y3E6N[ʮ %1D djÞ֎s#Y{eC1 psdaO\smܱT #eMIJ,Z|Rf >a}jŕllbP1,0sJ"aj,|MvB6#llv]Pic39ldp'5__*Z`dd0yA[69@r椈ĻvkuPJ&WH)I.1$%ko bd)S3;s&MM1[ՀL]HP5UI`7ZyG.w'p| v0l=:-$yZQvρZ) uh`8C_8jQt(-WY,jp,*:or//* O u+8jZ`M֗偃T[1)T*l`ka]D*ҳ]m=eoV^#pĄ8䊐C*63n}6^SoE 群 Pk񀞚>eMk=0ر\^w-ٷMPzQ+vc5}2 ] ?5@gKzag|nL8t͏)> }򻆂(Zff)즥 0N lg,Єix"ф֠505p;LPޕv gbgˮUQU ,,MߒVBDz5>v7ҡGvW.V&h_[E2lўY̖) 0Rߟ60R!祜aIK$.]ɢp{bINsր7 GCzxY> VU":-0pV%m(QM-EU)mAY`VXQ$̕s2Qv4PJQQhZp˱?'@$=Ĺs]'30 `OV ==OtۏԲpP0;{'tgwlS9p`sew-/MwYLkipƠUGng22z`DLi-:g93|waω<6C7NRXbw;T2F'Mktؙdfbys=_:PB$H{DbE ڤ<+ ]k[%xq6Xx t:qOZ{+xStmbIኇÜe=_$o6};):a=A^L#n.>v.̻li|w&a$ݲmH0IJNH(?z MvR>%rq8r;=ivxDXFmH8e5mW ZX+L}u?8XAJAS/Ɲ5ryg)}:.),-QOar4JMHWhBJ w /UeoP[aVPz^]^Ȣ-p*.kmB`q R@,|ц6,L6>X ^Ж.A*/1"pkUV3 45eɩ y Pj5V$MSg,N)JEyaQߜ$66hd%B^^ҫ3 XasSjO XUOF? oRʈdD8@oz>. 4|,ki> ^@+R4ME/h"1apts|ؤ3a;2rR2J3$Uw [ 96䓿Cy<޶9Պ ҳv?' լ@̇mu1bqdtC\s[DYn"d+BʘOIT&d7Ve=Ra0U{Pk@7S[p KvW,ZJ@v#[ݗ9i 1JkR 8w Ôb bjyJ*3Ch4{BUE-2},¸JLTJy0j;;@(,T&GJ̘6bF\}? UtF^RTxY9hza/pei9'٦*`$d<(dZ71WgԷpwp۳pTFZ y%ELsu7x}۶֟yyp<)#2so}8;VK_0:-bmð6 E#%XKZokZC@Ғ<+3[aUR./f c5TE("nܹq_g B5(M3FmЖQpC )A8P*EnTm\#0Y(-Up9؅;|H@LdzH'/cURd퇷?p(VŅ:@13=4QM/]qNL19x:WԔNX+?Bk;k&© !d&ˁd%#WϽ\MunA&v@א[V]1> 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 xU{PSg`)u]hMlժE.n8(ZEDH%&ay{OB 3&(DKA Ўhcںݮ:պ|^dtk盹s;琄 A48lWIavg3|Kݵu۶jRޝJHH@`&]7^'_P|_|JMU)tJB'^.]`yNY뛖P%{W.%[Jm2N>oRg<UR+S)`5Z]ڞ0ex|BdNDHb&>DG"xFL'fWY"+E&䰋Kd$7zKޙT'Q#4M;&< 8|ԇ$o7k|ϦL$n9;eR 7IT 9 \j.C[F/_- m!Dل+4G$B0Ǡ>1I7L<[Dh:q ڵg :MgkO6ķDA($B٩W-ֆ;Rg# DTSGCs}I)Ѹv¦epj-ƀUgjspqب&|IH|9CW0R5l=hClTLFL}GSW-> sSظH xHm*^ʪc7tC͏árGh츉RG%RˤKse !K[_rKFn/]/k.,?Vz%pVAXac 2Lҡqu݊WԒwP$n1冎pz{2(]!ܓ ~}N <ЅtuJR?ek)x~ج%Ks7|gҤ2~Obv&Ȟ%wQ%TtY~F0Xn.]: jhRg %~(4MGԄ]/Z_So>'Yx3P$^LW':(6صx<2**1)[5]>ZWA 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 4967 >> stream x\Yoɑ~' 4rއ?؋6`Kܧ(#!J2YyTw쬡#o1ɍۓ_򛷏'bo'~.n79a#5NRG v:ʍrr1lnOӝL!ƭ>Id D^\\_*F衽Tq{:ܽ=i޿Jﵔ<{x+F447a{SF s|ڥ>oعs)h­k7Yw'g?~{F6 $cQnpŞ/Y4!M6Ѥ X~m/Ñ oqNo?,c"f Nԋ i<׬cڥ6{~}w o䁽,p1V(1 X,mCɐ=`,H%UKn`|:G%l5p~hX nO?њV)-JZ]% ]N'ʐBD"|YFEcWU~rRfAPj`m-\8yi L|>vAG֝t3<4lk-]P.O K**beFEgTr1g0h IgrC2t# NIiKneF(ڊT(;ҾiyGcc.{܁/e]XF^^4<|"89T(m X[poҠ1vHǕqyr,jH&_-~[qob@AV>EŲx_ we1JJ?;e<jm%<^(ni.@;CurWwscDS 1&$Cǎ~iL'ᰨhm瀚t㒰K^i]pQlP >jul%e#@apψN:'-bl8a(0\!zKlX(qeC𱷬% x0r3AϷܴ-$O(~:k3dݾJrZ}ɵ(헬HY;b:om>x  ܞd  s>0ְQ8) [O?/9 ,Az xxBv=}2>R幆A6xܓc&Ч=+0\2:RUm"3&Jh05>@!uu]qpim06 ^;؆p8ofZ"`8V `d`oߞܧkal@m|hφ'вE,W#Llc09_ ˗>% /, 0qqQ0HHA((ٸ:0k``vdU6 {oT<|0}~6YSp#fæ(S$!VE /l-.эk$xtu|s) r;irCky . mƧ4)[ǵ)|%j|ͳ](e198MS/-%iƈd:qPf?Z'W煇iD\/ܰ&0?Ŵ1hq\A.YI9_6 R_ܕǸhݟJH1p~iZ\=Ƒd)E=T2K;Y24V\D, EdXsp/U]PΩ('Ǒ-m_ܴ!'DW/3 Hg!u?N sW57o[r>|hYqٽf}/ƴ&I9y3_OS6Ԥ~Ee0]FQ15 `ZgʏIUiKc2=q04zT%3zF a@2ȊΪOj| RὝ7#DWLͱ'њk/Kb 呎 ^~ITVǙ<({eqi % )!a)(3jcJaPtFX2CWNi]7rvJEC;Q9w+g14?ΎA(5;{0KG\r$5T}Gx?; Hy-$[aF JVeyi{czSN12T3b}ql2@ie=Jn3;):ECAow]GϿfA1mFs`P5|kQrno1})ROH?ZG٭1<ƒɀ%f }ͅgWC$5YZČB2r:U80!) 7TB82.<])[T-78`u/_K+3l@s. r@BrȒ{TǠn8nƣ^zqGEjJ ]VsSƈRR9 a zQ+^9r{[uQ ෧Aa_W6jV󨼶!$1 .o͌izimdVQ>..Xdg\G3^dXʼ$66y1+K$(RvI'_֡)ٿǺnU1Ov* | _(y\h@i+($@Hk0#rΫ]Q\ۺ*3 *#F_ fvkh,S"{ekrus~l^OaAM>k0e,ĒNY+&܏y֙Qv >!$nYWJ\kjCy Ik E #nd|ޞe^MF/t!6P"5H,\IŪpBtfg]ԅ_vCWi@ !%W{Ƿ.P 1uu G +L|uH MRXEjlMsxW =_䯑'eSTa^X&8ԹeZ -w$vS[&d D8pߝ2qNoOL1M/ǀ X2)~un EMS `fPh|`K|K[\vt(}R`}a!Co9!F:Qޕ*s3&Hn'4$rط\qQn81~1ud Tlo/ni I8ý>}h͟܄.>huJ-qk62#hRKTd Ga>/q,v?.QF7Ȗ>}BĥarPwb åC6XZ?T2endstream 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 2858 >> stream xZo'Gyɱyh&A[ā#3CEɐm!]q€۝͜~/FϮ8bѯ#_?fiƜNk1|luͤcy8;=~^l'zLeOdjltuµeLs]=90jg9>n6);B>>q*C׸|ǁ\KOa`2rmigu@͖{"YSIz$Rr(X3*Qc<^7sr1K}V3eu[$q7*56&cQ`YZF7=DidC*#L JdKQtgyT)WR xHkN>}faKUml" /Ţ7}~7Le;gI ~hcIkц:V"K$二`JdȳKi@ 5辑kns,Y3j?&zoJt նԇ

UMݘ_yKd^RBx(d:u= M(h:kF#N}lju6=!|]Z neB3.{7 XvǾf En\! ?1䄃w{0 ʕ<傮Sqִ.6nÙ8FXȊ^jA(PBs30Q>&xI(uďIԂcع ]t$U)^wҙϢo MS$B,CyKU~.(LJj:9m<%qTMS y>/FLUj`6 On{ 򳬜+3q8t"zZdW.@!ITz?(Ns-G[_糱Sz,/~fj< jyN:C^hK _6`ʽS֜M*ZLWBW!^x)kS7:p0H`>t=pj\:7 1\_+5 C)ћM\mEZ- PQ@kx /J,d9I]E mr$nB1Pq j {HrKh"z6_%"px^nxZ8Tק~vH <)6TK6nwUt{rAvٳ^_VS;=D[$ٚc ܦ>ϼ haïEńSnendstream 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 1825 /W [ 1 3 1 ] /Info 3 0 R /Root 2 0 R /Size 365 /ID [<6df74fdbafee1a4b564c97e7e3975b5e>] >> stream       !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKFLOOOOOOOOOO O O O O OOOOOOOOOOOOOOOOOOO O!O"O#O$O%O&O'O(O)O*O+O,O-O.O/O0O1O2O3O4O5O6O7O8O9O:O;O<O=O>O?O@OAOBOCODOEOFOGOHOIOJOK{f      !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJK)      !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJK "7HBCL]:f> ȼ<*7,/?6XY\bhkKT L ; 'A*\<P@[\     / : ;   e Q = endstream endobj startxref 900157 %%EOF plotmo/inst/doc/index.html0000644000176200001440000000107513300561605015305 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.pdf0000644000176200001440000072203113554705344016636 0ustar liggesusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 17015 /N 80 /First 663 >> stream 2 0 3 51 4 311 5 441 6 588 7 823 8 969 9 1170 10 1351 11 1731 12 1782 13 2215 14 2632 15 3151 16 3653 17 4111 18 4500 19 4971 20 5511 21 5660 22 5841 23 5990 24 6137 25 6540 26 6887 27 7333 28 7749 29 7843 30 8324 31 8752 32 8770 33 8861 34 9010 35 9212 36 9362 37 9511 38 9660 39 9810 40 9957 41 10111 42 10321 43 10475 44 10685 45 11043 46 11324 47 11342 48 11480 49 11627 50 11792 51 11957 52 12103 53 12121 54 12223 55 12372 56 12553 57 12700 58 12847 59 13096 60 13337 61 13355 62 13445 63 13593 64 13783 65 13973 66 14121 67 14270 68 14461 69 14610 70 14796 71 14944 72 15137 73 15285 74 15434 75 15609 76 15758 77 15870 78 15949 79 16029 80 16109 81 16260 << /Metadata 82 0 R /Pages 4 0 R /Type /Catalog >> << /Author (Stephen Milborrow) /CreationDate (D:20191025165309-07'00') /Creator (LaTeX with hyperref package) /Keywords () /ModDate (D:20191025165309-07'00') /Producer (GPL Ghostscript 9.19) /Subject (plotres) /Title (Plotting model residuals with plotres) >> << /Count 13 /Kids [ 6 0 R 21 0 R 34 0 R 8 0 R 9 0 R 55 0 R 88 0 R 110 0 R 90 0 R 92 0 R 138 0 R 10 0 R 106 0 R ] /Type /Pages >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 6 0 R /XYZ 85.039 313.186 null ] /Rect [ 84.043 541.745 177.609 552.039 ] /Subtype /Link /Type /Annot >> << /Annots [ 5 0 R 7 0 R 84 0 R 85 0 R 86 0 R 87 0 R 89 0 R 91 0 R 93 0 R 94 0 R 95 0 R ] /Contents 163 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 98 0 R /Font 99 0 R /ProcSet [ /PDF /Text ] >> /Type /Page >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 8 0 R /XYZ 85.039 763.654 null ] /Rect [ 84.043 513.268 193.25 525.887 ] /Subtype /Link /Type /Annot >> << /Annots [ 48 0 R 102 0 R 103 0 R 104 0 R 105 0 R ] /Contents 164 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 107 0 R /Font 108 0 R /ProcSet [ /PDF /Text ] >> /Type /Page >> << /Annots [ 49 0 R 50 0 R 51 0 R ] /Contents 165 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 52 0 R /Font 53 0 R /ProcSet [ /PDF /Text ] >> /Type /Page >> << /Annots [ 62 0 R 63 0 R 64 0 R 65 0 R 66 0 R 67 0 R 68 0 R 69 0 R 70 0 R 71 0 R 72 0 R 73 0 R 74 0 R 75 0 R 141 0 R 142 0 R 143 0 R 144 0 R 145 0 R 146 0 R 147 0 R 148 0 R 149 0 R 150 0 R 151 0 R 152 0 R 153 0 R 154 0 R 155 0 R ] /Contents 166 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 156 0 R /Font 157 0 R /ProcSet [ /PDF /Text ] >> /Type /Page >> << /BM /Normal /OPM 1 /TK true /Type /ExtGState >> << /BaseFont /TROSDB+CMTT12 /Encoding /WinAnsiEncoding /FirstChar 34 /FontDescriptor 13 0 R /LastChar 126 /Subtype /Type1 /Type /Font /Widths [ 514 0 0 0 0 0 514 514 0 0 514 514 514 514 514 514 514 514 0 0 0 0 0 0 514 0 0 514 0 0 0 514 0 514 0 514 514 0 0 0 0 0 514 514 514 0 0 0 514 514 0 514 514 0 0 0 0 0 0 0 0 0 0 514 514 514 514 514 514 514 514 514 514 514 514 514 514 514 514 0 514 514 514 514 514 514 514 514 0 0 0 0 514 ] >> << /Ascent 694 /AvgWidth 514 /CapHeight 625 /CharSet (/A/C/E/F/L/M/N/R/S/U/V/a/asciitilde/b/c/colon/comma/d/e/equal/f/g/h/hyphen/i/j/k/l/m/n/o/one/p/parenleft/parenright/period/quotedbl/r/s/slash/t/three/two/u/v/w/x/y/zero) /Descent -229 /Flags 33 /FontBBox [ -1 -229 514 694 ] /FontFile3 167 0 R /FontName /TROSDB+CMTT12 /ItalicAngle 0 /MaxWidth 514 /MissingWidth 514 /StemV 77 /Type /FontDescriptor /XHeight 443 >> << /BaseFont /SKNGSW+CMR12 /Encoding 80 0 R /FirstChar 11 /FontDescriptor 15 0 R /LastChar 123 /Subtype /Type1 /Type /Font /Widths [ 571 543 0 815 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 489 0 489 0 0 271 380 380 0 0 271 326 271 0 489 489 489 489 489 489 489 489 489 489 271 271 0 0 0 0 0 734 693 707 747 666 639 768 734 353 503 761 611 897 734 761 666 761 720 543 707 734 734 1006 0 734 0 271 489 271 0 0 0 489 543 435 543 435 299 489 543 271 299 516 271 815 543 489 543 516 380 386 380 543 516 707 516 516 435 489 ] >> << /Ascent 750 /CapHeight 750 /CharSet (/A/B/C/D/E/F/G/H/I/J/K/L/M/N/O/P/Q/R/S/T/U/V/W/Y/a/b/bracketleft/bracketright/c/colon/comma/d/dollar/e/eight/endash/f/ff/ffi/fi/five/four/g/h/hyphen/i/j/k/l/m/n/nine/o/one/p/parenleft/parenright/period/q/quotedblleft/quotedblright/quoteright/r/s/semicolon/seven/six/t/three/two/u/v/w/x/y/z/zero) /Descent -251 /Flags 4 /FontBBox [ -34 -251 988 750 ] /FontFile3 168 0 R /FontName /SKNGSW+CMR12 /ItalicAngle 0 /MissingWidth 500 /StemV 148 /Type /FontDescriptor >> << /BaseFont /VQFHNX+CMBX12 /Encoding 76 0 R /FirstChar 12 /FontDescriptor 17 0 R /LastChar 121 /Subtype /Type1 /Type /Font /Widths [ 625 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 581 0 0 0 0 0 0 0 0 0 0 0 312 0 562 562 562 562 562 562 562 562 562 562 0 0 0 875 0 531 0 849 799 812 0 0 707 884 0 418 0 0 675 0 879 0 0 844 839 625 782 0 0 1162 0 0 0 0 581 0 0 0 0 546 0 500 625 513 343 562 625 312 0 0 312 937 625 562 625 0 459 443 437 625 0 812 593 593 ] >> << /Ascent 700 /CapHeight 700 /CharSet (/A/B/C/F/G/I/L/N/Q/R/S/T/W/a/c/d/e/eight/equal/f/fi/five/four/g/h/i/l/m/n/nine/o/one/p/period/question/quotedblleft/quotedblright/r/s/seven/six/t/three/two/u/w/x/y/zero) /Descent -201 /Flags 6 /FontBBox [ 0 -201 1139 700 ] /FontFile3 169 0 R /FontName /VQFHNX+CMBX12 /ItalicAngle 0 /MissingWidth 500 /StemV 144 /Type /FontDescriptor /XHeight 456 >> << /BaseFont /QKVLVR+CMTT10 /Encoding /WinAnsiEncoding /FirstChar 34 /FontDescriptor 19 0 R /LastChar 126 /Subtype /Type1 /Type /Font /Widths [ 525 525 525 0 0 0 525 525 525 525 525 525 525 0 525 525 525 525 525 525 525 525 525 0 525 525 525 525 0 0 0 525 525 0 0 525 525 525 0 0 0 0 525 525 0 525 0 525 525 525 525 525 525 0 0 0 0 525 0 525 0 0 0 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 0 525 525 ] >> << /Ascent 694 /AvgWidth 525 /CapHeight 623 /CharSet (/A/B/E/F/G/L/M/O/Q/R/S/T/U/V/a/asciitilde/asterisk/b/braceleft/braceright/bracketleft/bracketright/c/colon/comma/d/dollar/e/eight/equal/f/five/four/g/h/hyphen/i/j/k/l/less/m/n/numbersign/o/one/p/parenleft/parenright/period/plus/q/quotedbl/r/s/semicolon/seven/six/t/three/two/u/v/w/x/y/z/zero) /Descent -229 /Flags 33 /FontBBox [ -4 -229 537 694 ] /FontFile3 170 0 R /FontName /QKVLVR+CMTT10 /ItalicAngle 0 /MaxWidth 525 /MissingWidth 525 /StemV 80 /Type /FontDescriptor /XHeight 442 >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 10 0 R /XYZ 85.039 102.084 null ] /Rect [ 247.015 261.948 260.714 275.896 ] /Subtype /Link /Type /Annot >> << /Annots [ 20 0 R 22 0 R 23 0 R ] /Contents 171 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 31 0 R /Font 32 0 R /ProcSet [ /PDF /Text ] >> /Type /Page >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 10 0 R /XYZ 85.039 364.434 null ] /Rect [ 513.608 261.948 521.454 275.896 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 9 0 R /XYZ 85.039 254.496 null ] /Rect [ 491.442 247.503 499.287 261.45 ] /Subtype /Link /Type /Annot >> << /BaseFont /SMFMGF+Helvetica-Bold /Encoding 78 0 R /FirstChar 32 /FontDescriptor 25 0 R /LastChar 121 /Subtype /Type1 /Type /Font /Widths [ 278 0 0 0 0 0 0 0 0 0 0 0 0 584 278 0 556 556 556 556 556 556 556 556 556 556 0 0 584 584 584 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 556 611 556 611 556 333 611 611 278 0 0 278 889 611 611 611 0 389 556 333 611 556 778 556 556 ] >> << /Ascent 729 /CapHeight 729 /CharSet (/a/b/c/d/e/eight/equal/f/five/four/g/greater/h/i/l/less/m/minus/n/nine/o/one/p/period/r/s/seven/six/space/t/three/two/u/v/w/x/y/zero) /Descent -219 /Flags 4 /FontBBox [ 0 -219 824 729 ] /FontFile3 172 0 R /FontName /SMFMGF+Helvetica-Bold /ItalicAngle 0 /MissingWidth 278 /StemV 123 /Type /FontDescriptor >> << /BaseFont /DUJWCD+Helvetica /Encoding 79 0 R /FirstChar 32 /FontDescriptor 27 0 R /LastChar 122 /Subtype /Type1 /Type /Font /Widths [ 278 0 0 0 0 889 0 191 333 333 0 0 278 584 278 0 556 556 556 556 556 556 556 556 556 556 0 0 0 584 0 0 0 667 667 722 722 667 611 778 0 0 0 0 556 0 722 778 667 778 722 667 611 722 667 0 0 667 0 0 0 0 0 0 0 556 556 500 556 556 278 556 556 222 0 500 222 833 556 556 556 556 333 500 278 556 500 0 500 500 500 ] >> << /Ascent 741 /CapHeight 741 /CharSet (/A/B/C/D/E/F/G/L/N/O/P/Q/R/S/T/U/V/Y/a/b/c/comma/d/e/eight/equal/f/five/four/g/h/i/k/l/m/minus/n/nine/o/one/p/parenleft/parenright/percent/period/q/quotesingle/r/s/seven/six/space/t/three/two/u/v/x/y/z/zero) /Descent -218 /Flags 4 /FontBBox [ 0 -218 859 741 ] /FontFile3 173 0 R /FontName /DUJWCD+Helvetica /ItalicAngle 0 /MissingWidth 278 /StemV 128 /Type /FontDescriptor >> << /BaseFont /ZapfDingbats /Encoding 77 0 R /Subtype /Type1 /ToUnicode 174 0 R /Type /Font >> << /BaseFont /RFTQFB+CMTI12 /Encoding 81 0 R /FirstChar 12 /FontDescriptor 30 0 R /LastChar 122 /Subtype /Type1 /Type /Font /Widths [ 550 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 300 400 400 0 0 300 350 300 0 500 500 500 500 0 500 0 500 0 0 300 0 0 0 0 0 0 726 688 700 738 663 638 756 726 376 513 0 613 876 726 0 663 0 713 550 700 726 726 0 0 0 0 300 0 300 0 0 0 500 450 450 500 450 300 450 500 300 0 450 250 800 550 500 500 450 412 400 325 525 450 650 450 475 400 ] >> << /Ascent 750 /CapHeight 714 /CharSet (/A/B/C/D/E/F/G/H/I/J/L/M/N/P/R/S/T/U/V/a/b/bracketleft/bracketright/c/colon/comma/d/e/f/fi/five/g/h/hyphen/i/k/l/m/n/o/one/p/parenleft/parenright/period/q/quoteright/r/s/seven/t/three/two/u/v/w/x/y/z/zero) /Descent -251 /Flags 70 /FontBBox [ -27 -251 977 750 ] /FontFile3 175 0 R /FontName /RFTQFB+CMTI12 /ItalicAngle -15 /MissingWidth 500 /StemV 99 /Type /FontDescriptor /XHeight 441 >> << /R24 11 0 R >> << /R27 12 0 R /R29 14 0 R /R43 24 0 R /R45 26 0 R /R47 100 0 R /R49 28 0 R /R50 29 0 R >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 10 0 R /XYZ 85.039 645.048 null ] /Rect [ 514.364 480.436 522.209 494.383 ] /Subtype /Link /Type /Annot >> << /Annots [ 33 0 R 35 0 R 36 0 R 37 0 R 38 0 R 39 0 R ] /Contents 176 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 46 0 R /Font 47 0 R /ProcSet [ /PDF /Text ] >> /Type /Page >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 34 0 R /XYZ 136.251 591.934 null ] /Rect [ 286.512 443.707 294.358 456.326 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 34 0 R /XYZ 102.972 54.478 null ] /Rect [ 437.484 294.253 444.209 308.045 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 34 0 R /XYZ 136.251 591.934 null ] /Rect [ 489.835 279.143 497.68 293.091 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 34 0 R /XYZ 136.251 591.934 null ] /Rect [ 177.201 212.858 185.047 226.806 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 10 0 R /XYZ 85.039 592.08 null ] /Rect [ 181.43 105.366 189.276 119.314 ] /Subtype /Link /Type /Annot >> << /BaseFont /HNWIPU+CMR8 /Encoding /WinAnsiEncoding /FirstChar 49 /FontDescriptor 41 0 R /LastChar 50 /Subtype /Type1 /Type /Font /Widths [ 531 531 ] >> << /Ascent 665 /CapHeight 665 /CharSet (/one/two) /Descent 0 /Flags 65568 /FontBBox [ 0 0 477 665 ] /FontFile3 177 0 R /FontName /HNWIPU+CMR8 /ItalicAngle 0 /MissingWidth 500 /StemV 71 /Type /FontDescriptor >> << /BaseFont /TWFZMB+CMR7 /Encoding /WinAnsiEncoding /FirstChar 49 /FontDescriptor 43 0 R /LastChar 50 /Subtype /Type1 /Type /Font /Widths [ 569 569 ] >> << /Ascent 664 /CapHeight 664 /CharSet (/one/two) /Descent 0 /Flags 65568 /FontBBox [ 0 0 505 664 ] /FontFile3 178 0 R /FontName /TWFZMB+CMR7 /ItalicAngle 0 /MissingWidth 500 /StemV 75 /Type /FontDescriptor >> << /BaseFont /ZKIXSS+CMR10 /Encoding /WinAnsiEncoding /FirstChar 44 /FontDescriptor 45 0 R /LastChar 122 /Subtype /Type1 /Type /Font /Widths [ 277 0 277 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 555 722 0 0 0 0 0 0 0 0 0 0 0 0 500 555 444 555 444 305 0 555 277 0 527 277 833 555 500 555 527 391 394 388 555 527 0 0 527 444 ] >> << /Ascent 705 /CapHeight 705 /CharSet (/S/T/a/b/c/comma/d/e/f/h/i/k/l/m/n/o/p/period/q/r/s/t/u/v/y/z) /Descent -205 /Flags 32 /FontBBox [ 0 -205 813 705 ] /FontFile3 179 0 R /FontName /ZKIXSS+CMR10 /ItalicAngle 0 /MissingWidth 500 /StemV 121 /Type /FontDescriptor /XHeight 448 >> << /R24 11 0 R >> << /R27 12 0 R /R29 14 0 R /R31 16 0 R /R33 18 0 R /R43 24 0 R /R45 26 0 R /R49 28 0 R /R50 29 0 R /R63 40 0 R /R65 42 0 R /R67 44 0 R >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 10 0 R /XYZ 85.039 698.681 null ] /Rect [ 227.506 65.678 235.352 79.626 ] /Subtype /Link /Type /Annot >> << /A << /D [ 0 /Fit ] /F (plotmo-notes.pdf) /S /GoToR >> /Border [ 0 0 0 ] /C [ 0 0.5 0.5 ] /Rect [ 326.912 643.72 456.026 656.339 ] /Subtype /Link /Type /Annot >> << /A << /D [ 0 /Fit ] /F (plotmo-notes.pdf) /S /GoToR >> /Border [ 0 0 0 ] /C [ 0 0.5 0.5 ] /Rect [ 490.861 643.72 527.957 656.339 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 9 0 R /XYZ 102.972 71.599 null ] /Rect [ 292.49 185.04 299.214 198.832 ] /Subtype /Link /Type /Annot >> << /R24 11 0 R >> << /R27 12 0 R /R29 14 0 R /R31 16 0 R /R33 18 0 R /R50 29 0 R /R63 40 0 R /R65 42 0 R /R67 44 0 R >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 55 0 R /XYZ 135.533 88.281 null ] /Rect [ 460.835 519.205 468.681 533.153 ] /Subtype /Link /Type /Annot >> << /Annots [ 54 0 R 56 0 R 57 0 R ] /Contents 180 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 60 0 R /Font 61 0 R /ProcSet [ /PDF /Text ] >> /Type /Page >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 10 0 R /XYZ 85.039 739.859 null ] /Rect [ 191.214 69.851 199.184 83.798 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 10 0 R /XYZ 85.039 403.288 null ] /Rect [ 346.706 69.851 354.676 83.798 ] /Subtype /Link /Type /Annot >> << /BaseFont /DIFYGE+CMBXTI10 /Encoding /WinAnsiEncoding /FirstChar 76 /FontDescriptor 59 0 R /LastChar 116 /Subtype /Type1 /Type /Font /Widths [ 697 0 0 0 0 0 859 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 532 400 532 591 355 0 0 0 0 0 0 0 0 0 0 385 ] >> << /Ascent 702 /CapHeight 686 /CharSet (/L/R/e/f/g/h/i/t) /Descent -202 /Flags 32 /FontBBox [ -19 -202 850 702 ] /FontFile3 181 0 R /FontName /DIFYGE+CMBXTI10 /ItalicAngle 0 /MissingWidth 500 /StemV 127 /Type /FontDescriptor /XHeight 452 >> << /R24 11 0 R >> << /R27 12 0 R /R29 14 0 R /R31 16 0 R /R33 18 0 R /R45 26 0 R /R50 29 0 R /R94 58 0 R >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 55 0 R /XYZ 84.039 801.515 null ] /Rect [ 516.86 702.666 524.705 715.285 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (https://CRAN.R-project.org/package=neuralnet) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 383.972 663.479 527.957 676.431 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (https://CRAN.R-project.org/package=neuralnet) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 108.105 649.033 239.289 661.985 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 8 0 R /XYZ 84.039 801.515 null ] /Rect [ 325.078 649.033 332.923 661.985 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 34 0 R /XYZ 84.039 801.515 null ] /Rect [ 151.678 596.065 159.523 608.087 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (http://web.stanford.edu/~hastie/ElemStatLearn) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 184.968 542.433 463.797 555.385 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 34 0 R /XYZ 84.039 801.515 null ] /Rect [ 135.419 528.319 143.265 540.341 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (https://CRAN.R-project.org/package=caret) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 167.446 474.687 416.014 487.639 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 8 0 R /XYZ 84.039 801.515 null ] /Rect [ 501.803 474.687 509.649 487.639 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (https://CRAN.R-project.org/package=randomForest) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 233.074 421.387 524.705 434.338 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 8 0 R /XYZ 84.039 801.515 null ] /Rect [ 183.544 407.273 191.389 419.893 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 55 0 R /XYZ 84.039 801.515 null ] /Rect [ 442.224 368.419 450.069 381.038 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (http://www.milbo.org/rpart-plot) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 199.299 329.233 392.5 342.184 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 21 0 R /XYZ 84.039 801.515 null ] /Rect [ 478.289 329.233 486.135 342.184 ] /Subtype /Link /Type /Annot >> << /BaseEncoding /WinAnsiEncoding /Differences [ 12 /fi 34 /quotedblright 92 /quotedblleft ] /Type /Encoding >> << /BaseEncoding /WinAnsiEncoding /Differences [ 108 /a71 ] /Type /Encoding >> << /BaseEncoding /WinAnsiEncoding /Differences [ 45 /minus ] /Type /Encoding >> << /BaseEncoding /WinAnsiEncoding /Differences [ 45 /minus ] /Type /Encoding >> << /BaseEncoding /WinAnsiEncoding /Differences [ 11 /ff /fi 14 /ffi 34 /quotedblright 39 /quoteright 92 /quotedblleft 123 /endash ] /Type /Encoding >> << /BaseEncoding /WinAnsiEncoding /Differences [ 12 /fi 39 /quoteright ] /Type /Encoding >> endstream endobj 82 0 obj << /Subtype /XML /Type /Metadata /Length 1618 >> stream GPL Ghostscript 9.19 2019-10-25T16:53:09-07:00 2019-10-25T16:53:09-07:00 LaTeX with hyperref package Plotting model residuals with plotresStephen Milborrowplotres endstream endobj 83 0 obj << /Type /ObjStm /Length 11836 /N 79 /First 696 >> stream 84 0 85 147 86 294 87 441 88 588 89 790 90 938 91 1132 92 1280 93 1514 94 1662 95 1811 96 1959 97 2219 98 2471 99 2489 100 2555 101 2769 102 3014 103 3161 104 3308 105 3455 106 3603 107 3789 108 3807 109 3849 110 4000 111 4150 112 4301 113 4449 114 4597 115 4745 116 4763 117 4817 118 4835 119 4901 120 5051 121 5199 122 5347 123 5495 124 5826 125 6114 126 6132 127 6224 128 6371 129 6537 130 6703 131 6869 132 7035 133 7201 134 7363 135 7512 136 7659 137 7677 138 7743 139 7893 140 7911 141 7989 142 8171 143 8319 144 8506 145 8653 146 8837 147 9020 148 9167 149 9351 150 9499 151 9684 152 9868 153 10016 154 10200 155 10347 156 10493 157 10511 158 10565 159 10748 160 10933 161 11080 162 11098 << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 9 0 R /XYZ 85.039 763.654 null ] /Rect [ 84.043 489.441 170.592 499.736 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 9 0 R /XYZ 85.039 612.255 null ] /Rect [ 84.043 460.632 364.208 473.584 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 9 0 R /XYZ 85.039 254.496 null ] /Rect [ 84.043 434.813 335.638 447.432 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 88 0 R /XYZ 85.039 751.698 null ] /Rect [ 84.043 408.329 341.141 421.28 ] /Subtype /Link /Type /Annot >> << /Annots [ 109 0 R 111 0 R 112 0 R 113 0 R 114 0 R ] /Contents 182 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 115 0 R /Font 116 0 R /ProcSet [ /PDF /Text ] >> /Type /Page >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 90 0 R /XYZ 85.039 751.698 null ] /Rect [ 84.043 382.177 224.566 395.128 ] /Subtype /Link /Type /Annot >> << /Annots [ 119 0 R 120 0 R 121 0 R 122 0 R ] /Contents 183 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 125 0 R /Font 126 0 R /ProcSet [ /PDF /Text ] >> /Type /Page >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 92 0 R /XYZ 85.039 739.743 null ] /Rect [ 84.043 356.357 236.747 368.977 ] /Subtype /Link /Type /Annot >> << /Annots [ 127 0 R 128 0 R 129 0 R 130 0 R 131 0 R 132 0 R 133 0 R 134 0 R 135 0 R ] /Contents 184 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 136 0 R /Font 137 0 R /ProcSet [ /PDF /Text ] >> /Type /Page >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 92 0 R /XYZ 85.039 313.807 null ] /Rect [ 84.043 330.205 301.169 342.825 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 10 0 R /XYZ 85.039 286.393 null ] /Rect [ 334.339 189.998 348.038 203.946 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 6 0 R /XYZ 85.039 313.186 null ] /Rect [ 276.116 177.113 283.961 189.732 ] /Subtype /Link /Type /Annot >> << /BaseFont /TKHJCR+CMR17 /Encoding /WinAnsiEncoding /FirstChar 80 /FontDescriptor 97 0 R /LastChar 119 /Subtype /Type1 /Type /Font /Widths [ 628 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 458 0 0 510 406 0 458 510 249 0 0 249 772 510 458 0 0 354 359 354 510 0 667 ] >> << /Ascent 694 /CapHeight 683 /CharSet (/P/a/d/e/g/h/i/l/m/n/o/r/s/t/u/w) /Descent -204 /Flags 32 /FontBBox [ 0 -204 744 694 ] /FontFile3 185 0 R /FontName /TKHJCR+CMR17 /ItalicAngle 0 /MissingWidth 500 /StemV 111 /Type /FontDescriptor /XHeight 446 >> << /R24 11 0 R >> << /R25 96 0 R /R27 12 0 R /R29 14 0 R /R31 16 0 R /R33 18 0 R >> << /BaseFont /KJBVLQ+Helvetica-Oblique /Encoding /WinAnsiEncoding /FirstChar 101 /FontDescriptor 101 0 R /LastChar 121 /Subtype /Type1 /Type /Font /Widths [ 556 0 0 0 0 0 0 0 0 556 556 0 0 0 500 0 0 0 0 0 500 ] >> << /Ascent 539 /CapHeight 539 /CharSet (/e/n/o/s/y) /Descent -218 /Flags 131104 /FontBBox [ 0 -218 590 539 ] /FontFile3 186 0 R /FontName /KJBVLQ+Helvetica-Oblique /ItalicAngle 0 /MissingWidth 278 /StemV 88 /Type /FontDescriptor /XHeight 539 >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 10 0 R /XYZ 85.039 524.334 null ] /Rect [ 238.133 65.678 245.978 79.626 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 10 0 R /XYZ 85.039 470.702 null ] /Rect [ 248.759 65.678 256.605 79.626 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 10 0 R /XYZ 85.039 233.425 null ] /Rect [ 259.386 65.678 273.084 79.626 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 106 0 R /XYZ 85.039 763.654 null ] /Rect [ 276.945 65.678 290.643 79.626 ] /Subtype /Link /Type /Annot >> << /Annots [ 158 0 R 159 0 R 160 0 R ] /Contents 187 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 161 0 R /Font 162 0 R /ProcSet [ /PDF /Text ] >> /Type /Page >> << /R24 11 0 R >> << /R29 14 0 R /R31 16 0 R /R33 18 0 R >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 110 0 R /XYZ 136.251 202.162 null ] /Rect [ 390.341 700.075 398.186 714.023 ] /Subtype /Link /Type /Annot >> << /Contents 188 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 117 0 R /Font 118 0 R /ProcSet [ /PDF /Text ] >> /Type /Page >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 110 0 R /XYZ 136.251 202.162 null ] /Rect [ 235.706 558.774 243.552 572.722 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 9 0 R /XYZ 85.039 612.255 null ] /Rect [ 291.495 447.359 299.341 461.306 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 9 0 R /XYZ 85.039 612.255 null ] /Rect [ 336.943 404.021 344.788 417.969 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 9 0 R /XYZ 85.039 254.496 null ] /Rect [ 275.375 365.167 283.221 378.118 ] /Subtype /Link /Type /Annot >> << /R24 11 0 R >> << /R27 12 0 R /R29 14 0 R /R31 16 0 R /R33 18 0 R >> << /R24 11 0 R >> << /R27 12 0 R /R29 14 0 R /R45 26 0 R /R49 28 0 R /R50 29 0 R >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 90 0 R /XYZ 371.591 220.203 null ] /Rect [ 122.242 686.526 130.088 700.474 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 9 0 R /XYZ 85.039 612.255 null ] /Rect [ 495.597 412.765 503.443 426.713 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 9 0 R /XYZ 85.039 612.255 null ] /Rect [ 284.591 301.349 292.436 315.297 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 9 0 R /XYZ 85.039 254.496 null ] /Rect [ 233.693 262.495 241.539 275.446 ] /Subtype /Link /Type /Annot >> << /BaseFont /CGGZVU+CMITT10 /Encoding /WinAnsiEncoding /FirstChar 46 /FontDescriptor 124 0 R /LastChar 118 /Subtype /Type1 /Type /Font /Widths [ 525 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 525 525 525 525 0 525 525 0 525 0 0 525 525 525 525 525 0 525 525 525 0 525 ] >> << /Ascent 617 /AvgWidth 525 /CapHeight 617 /CharSet (/a/b/c/d/f/g/i/l/m/n/o/p/period/r/s/t/v) /Descent -228 /Flags 33 /FontBBox [ 0 -228 579 617 ] /FontFile3 189 0 R /FontName /CGGZVU+CMITT10 /ItalicAngle 0 /MaxWidth 525 /MissingWidth 525 /StemV 86 /Type /FontDescriptor /XHeight 437 >> << /R24 11 0 R >> << /R118 123 0 R /R27 12 0 R /R29 14 0 R /R31 16 0 R /R33 18 0 R /R45 26 0 R /R50 29 0 R >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 92 0 R /XYZ 85.039 142.043 null ] /Rect [ 125.5 567.306 133.345 581.254 ] /Subtype /Link /Type /Annot >> << /A << /D [ 0 /Fit ] /F (plotmo-notes.pdf) /S /GoToR >> /Border [ 0 0 0 ] /C [ 0 0.5 0.5 ] /Rect [ 159.122 243.786 185.008 256.738 ] /Subtype /Link /Type /Annot >> << /A << /D [ 0 /Fit ] /F (plotmo-notes.pdf) /S /GoToR >> /Border [ 0 0 0 ] /C [ 0 0.5 0.5 ] /Rect [ 209.679 243.786 338.638 256.738 ] /Subtype /Link /Type /Annot >> << /A << /D [ 0 /Fit ] /F (plotmo-notes.pdf) /S /GoToR >> /Border [ 0 0 0 ] /C [ 0 0.5 0.5 ] /Rect [ 374.365 243.786 458.467 256.738 ] /Subtype /Link /Type /Annot >> << /A << /D [ 0 /Fit ] /F (plotmo-notes.pdf) /S /GoToR >> /Border [ 0 0 0 ] /C [ 0 0.5 0.5 ] /Rect [ 148.491 219.378 274.633 231.997 ] /Subtype /Link /Type /Annot >> << /A << /D [ 0 /Fit ] /F (plotmo-notes.pdf) /S /GoToR >> /Border [ 0 0 0 ] /C [ 0 0.5 0.5 ] /Rect [ 315.562 219.378 358.851 231.997 ] /Subtype /Link /Type /Annot >> << /A << /D [ 0 /Fit ] /F (modguide.pdf) /S /GoToR >> /Border [ 0 0 0 ] /C [ 0 0.5 0.5 ] /Rect [ 321.821 165.081 508.922 179.029 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 0 1 0 ] /Dest [ 10 0 R /XYZ 85.039 325.248 null ] /Rect [ 513.608 165.081 521.454 179.029 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 9 0 R /XYZ 85.039 254.496 null ] /Rect [ 145.407 88.327 153.253 100.947 ] /Subtype /Link /Type /Annot >> << /R24 11 0 R >> << /R27 12 0 R /R29 14 0 R /R31 16 0 R /R33 18 0 R /R50 29 0 R >> << /Contents 190 0 R /MediaBox [ 0 0 612 792 ] /Parent 4 0 R /Resources << /ExtGState 139 0 R /Font 140 0 R /ProcSet [ /PDF /Text ] >> /Type /Page >> << /R24 11 0 R >> << /R27 12 0 R /R29 14 0 R /R43 24 0 R /R45 26 0 R /R49 28 0 R /R50 29 0 R >> << /A << /S /URI /Type /Action /URI (http://www.milbo.org/doc/modguide.pdf) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 151.027 290.378 380.641 303.33 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 92 0 R /XYZ 84.039 801.515 null ] /Rect [ 466.431 290.378 480.129 303.33 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (https://CRAN.R-project.org/package=plotmo) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 232.583 251.524 487.303 264.475 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 6 0 R /XYZ 84.039 801.515 null ] /Rect [ 151.678 237.41 159.523 249.432 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (http://www.milbo.users.sonic.net/earth) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 421.382 198.224 527.957 211.175 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (http://www.milbo.users.sonic.net/earth) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 108.105 184.11 239.289 196.729 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 8 0 R /XYZ 84.039 801.515 null ] /Rect [ 325.078 184.11 332.923 196.729 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (https://CRAN.R-project.org/package=gbm) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 132.168 144.924 368.432 157.875 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 8 0 R /XYZ 84.039 801.515 null ] /Rect [ 454.221 144.924 462.067 157.875 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (https://CRAN.R-project.org/package=tree) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 489.053 120.183 527.957 134.131 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (https://CRAN.R-project.org/package=tree) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 108.105 106.069 313.61 119.021 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 8 0 R /XYZ 84.039 801.515 null ] /Rect [ 399.399 106.069 407.245 119.021 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (https://CRAN.R-project.org/package=rpart) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 236.844 67.215 485.412 80.167 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 21 0 R /XYZ 84.039 801.515 null ] /Rect [ 156.295 53.101 164.141 65.721 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 8 0 R /XYZ 84.039 801.515 null ] /Rect [ 188.812 53.101 196.657 65.721 ] /Subtype /Link /Type /Annot >> << /R24 11 0 R >> << /R27 12 0 R /R29 14 0 R /R31 16 0 R /R50 29 0 R >> << /A << /S /URI /Type /Action /URI (https://CRAN.R-project.org/package=MASS) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 359.364 733.6 527.957 746.551 ] /Subtype /Link /Type /Annot >> << /A << /S /URI /Type /Action /URI (https://CRAN.R-project.org/package=MASS) >> /Border [ 0 0 0 ] /C [ 0 1 1 ] /Rect [ 108.105 719.154 183.921 732.105 ] /Subtype /Link /Type /Annot >> << /Border [ 0 0 0 ] /C [ 1 0 0 ] /Dest [ 8 0 R /XYZ 84.039 801.515 null ] /Rect [ 269.71 719.154 277.556 732.105 ] /Subtype /Link /Type /Annot >> << /R24 11 0 R >> << /R27 12 0 R /R29 14 0 R /R50 29 0 R >> endstream endobj 163 0 obj << /Filter /FlateDecode /Length 2593 >> stream xZKs#I+ 8"V~{ Xba94ȒWǘzteul/@L]|U4e-2~_Lj>Nt=iiu}3%SZcI\ʧ\V15LM/o&o - j8N ^!+v8v[Ûl.ǜ1%%  ,gLjѬpA\hod!qġ^%ޑ񂨸%q'\sOP'"˿ ĖB,4kQP%R&wQzz~ []\|:@,*{4g,!M L;KS`9VFXd-ߤ"X/#>xz@šWlk4,Y@n?u.@}eEˉy\) 5쒆^t}55 7Q ';o }7nc, z<e)iY+(3}kl g~UR<)h Q3UUOI?sq[m_R3pB\cD|HS73.TjC͕nDU!X/T[;S]dΫ ouv&gJ'K厁M.HY}H4% S`9 ٓ @̽zm]bb ͝5tuIo]4z#9Ӽ'g ̾^ p<$XEs閔d[sZg&͘2p`p.@5٥S:6TQj) -"JT|BetĐvQ! '6Rr!1.<M=]Gͧ!AƧڝF=>9l8ґ8 ʵRteN-b0rgg4lb*̣I'Mqg& c2#z(~pdu`;ߎ \ !JS2k?묊T&>* DG\csR(i6I|h4BST>YT߻CBQ_̘l$<ې{Q#D/,h)Grcmw.|ڻwADX揕LәyAb8.uM" _8Əc 29Tomh@iLmhd9@yv[Ir!^p9-AyY} )BkDA̅r 7pGI+.=oyz!)k9[# `%0<^^L!lS-lCѢbF~n& e)#<,p>@):#i?xCkLqyV׏9DFX|C .qG!m9oWj /p BD7P5bl࢟19i j?/ >;zC7ߣcӦsA?$DkNŕge>PtU8Giя|ȹa֢7- zh!ícQa\1m*Z@ sLJaqxjj;'nl67.N!$@~_.L ]\\WhN*\W_݊vNǣJT64˲" f}y˄T,wٲ"?QjRW7_IEimj:,N"~Ap AնMg-W,a3Xt,n=-PX:_ ?endstream endobj 164 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 165 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 166 0 obj << /Filter /FlateDecode /Length 5276 >> 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>$Ѳ?k{1endstream endobj 167 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 4096 >> stream xW TS>1pr@Şuz.EmZ'2BB CBCALDbƢjmZk羾$[o- go0B |n<{܋n0BVqqQB26"h} !,bcj M3kea``yxXt$ <. c^9SPxGyIe{NPD=d a{=VJ%ruay~|10Z0 $RߘqE2_vﺰ}"6#Dm^4s fV*AD'6db1Ll!ۈ7v—A ^'Lb%xXMxkOky:!#•M!n8b!$^$NDqW0EP:yzXp":g¹t'+I,]P ?1uD#MVuYruk9f˜1cxlqniFa\+W fd\jM\}њ# CfeD1rH,o8b3!sTܟ_AL.l9CI|`gf"|PS`ׂU{”L'2ɔXb#o8 ?)dy# R|{LO?}m- Eh쬇Ĭx,v~ړ'ϧ}޸KW|kڥ,o UoYй^!'ᾢ+N5/=mժחґhFO[^AiN ꫘ۢ*2( U okj撨U[&Sbhԯ?q/mF╌y(,E4y3 ;\M1n%Sis!5#Y؂&ZN󱽆Zh4MD6~'{4-hzojWhrOPS (x̋bVm̯2na3/"/&_*fi`V p>qħ6=:q$'0irAi S$hr H+Lgߗ3?~цf *K!ZYPυ m&za44c]wnxF҈:P!FN)M :d4udVcROZʒ]&HJU)VeHU܆Χ|&| "ܢ M|Eԫ󥵋kM? P WͿ=Q:1u' ePpeG ɆYk*k=Fܝs(Ɇl" ]s|B2tˌ" ɳ /Wrm3Ewz~4|iy˸n= at{FP[5JTif*f ZV,8UZJϛ̺Ҵ&/s&y4xȉ,զv PJ'Ueɉ']d`gk9zdBZu@U.O=xf1ޛF +!z{Pu1:$iV鞋9y7hd5X@@7lq zQA@8=WS,m\YTToڡQP{A 0|IzadREu@i rX]5 \ wzS}coU Թۃbx sѩ2Y6৮_oFg{v9%? (zyw/+P-e,W\'z^; :24Quf NEHKBn.LVC'^qyш>mcAN]Reed*a><}#j}SG/Xcy|K-\TM޼mLNѾC@ׂ0[[ϸwCG.?*kA+{=(GkA,.Qtj 65)#@ݽrAۚ6 F}ATNTYCQKur&,q0+(5kWghHJiQhKq.F 3Io}N{d`@@PV?=2wtֳ 7hx.<5580øYƩ=t>rQ_/G0x_ ؇3_=ڤ | mL構K5ԤΉKU PSjR)Lˑ;vY?saNbznPd LVhhi`R< ŤCchG=!"94x_rMp*d@a8%K7t-в'+%X /~+d2:2z`ө6Ds>rq~rocC+&{5!FqM~3>2W}aRWq?7EHH 龘p)Ca>1*ν*Zu8fJJvR4Mft"A#[:َi}3:5l=9rpCNv16Bryfu RfCл lٶ<"I~!3>Кy@Oph;ްf䥔`~z64 y<(/)̃TIfEl5̦ER/X׉ ]~R1W;li| k',̪T>t aO/OUk2AM$7|ft1o l-}!j6ЙQ9əĊ"Ğ} I!P[`ejsSv#}'ʝOHu$A+5VہY>cLH,21 t$m(4B!UXILd΀ ڢ|{U붠Nݽ<hTί0O<u-@P\F/G.y^ڵS'] d1GmFI6]eA[u 9K%%=B1ty٣>@B 3nYNjswdTՕ7Ugd1g:@ݹc bq t =;R[}01YWH, q ڊ *v+󗨐wXѿv-߲zZ)ϕsz6PTmRu\B5rEnwFz(Ѧ=R pe↴ *4ŠgZ^έ{.rK쾜,Pd!k'. <߭ 'L0:]PHh@QӪ,ǦidJy"cia~qן> 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 TW֮DĵTS qQIDc{7,oݷdE@hӲ5 &1qMęh41cn#3̟93]޽1H$y9'Jıפ@v5 q1K)X5pqj֡T" Hu  1fmͷY qVx(  _h |Ãߚ5+**j2 lfP;SDج q Y 鿽#½Bmüμnjc\:ƕl`&3MTƍYlaf0[2f,gV0s\fcϼ83ky26L3 gF0#D115 31cGu̲.O2YT8V~ǭN4bŽAUC--\=GVR1bh0aS rߎqnܑͼ-`H1Ӫ(;{U TD˘XPeff@p !YZ U,¬|jp>%v3FchF jB#GZ>U9E ((ux$󮯠20\O9`WwB_] BXzXec=KxǶ э?~dp݆Mb/3p%Lp2OG2PNox8av}r+LA|E/i@K,BKXA<: MǑQd8>ђu<8v|PnW;h| 66nUOW7W*%VԴI{z*Ȋut=z1X2L ;N!SPNȢZH%%AZL~lXs~ (W;N\w\-=f zsBq ΥYާpxhkQG ɾ/kfZ"oJْ]ӄ Xd8j\J|/M/4}K"rT'dd&g.L2uѐ.MקeCKrK((w mM !B.2eBji*C|>`ݍÊD>oƂՅ }С4gYVʨ* hQޏ98cFY`-ZzdN`!Fkljl@dw1E]/^0J*ML9%yMUeӲ?33ԙr2'#y!Bγ;!=a_`zuN?e .&N ޮ<{k4(m7QQZREV' {WN?vFqtUZV噙q)蚊;n6g#qZF5%cpvr/;=n'{OMv>OKlȸ'ouwGYEMd\Oi U&y39U ] o:hyO*TkBh. BɈVE WȪ7뗮 5e?,+0[JNԳbJ_ 4b*xJPAm 6zG[ ZάШ!} ̀NH~(0ʁéwtȕmmڽ9 '6pN;@iŪ3!VFniyUӬ37_i_ XjpVi0(42ė2#LgeBZ#%%@$}PݶԎH'LXF^FgȎFz#4ư98 W'BNC){Ky}Yumf:5\dCJuэJ{dt^F#lxg{En]lXs8\.5֝[WZ$l^ sEnB>먋}PJ}˷dڶycc35R8ׁ-8!N$$F&o6[C8D|ܳ8\>ūS4 )AI+Weg +1\ Xж,k6GLW.vlJӦqi&ϘD}i}}ő=9dS[Iui W$LG F`ڎ'¿Pk_!By?Q3]#N Y 4&T ZA{)J~*zPr %+~:5^-O!bCnD\ZW5)Ud !k=y[n(q R {<}|[ YJVR9/ :vÚ'{ɹxs5+Pu<~|w;"A]< k2sdA5Ty*56&%6ץ4HUY_n"r1Kqb>YQ:~C55ov=WDRCPEpoǓhNE$6Y>JG)d7|_~1Mwydɞ'>O]@*?as&. eF+B)b6qrX!奫alvMrԧG+#<j:Y3(y =͹cR-6յS*#YN'E2?L:ԗawVzDjP2rbLfܜ2\"*Ǡc2'r؟[Yͻѡ[r'YSwCPW _!8e$/I 8v bjoHpI}@{).Cx 4 Mp +N q))&Vb:<&-N0MxUXý_?+>V 9E7yGyBяeCB|t|L^M*7dS3BD ]vD_WԽDFߵ0/p[85u;8^{1wwsP5LЋOv*L} ^D$u4 {"7;y?+҅Ė&%8wɕJhsq%TߢIԂ͖el߇R|*&R󗽊rЕRVm :zmMIy4JN5HE?j]3#S]RRBY,-D7w#-l.S4z&c\UAw_-]Džr@}癶LhiFG$7p:K( m \udܘ_zwe`rӍ8ӓߓY½OuOwykKsˏW%ٞ+~9~*APeB*dp19`r4mW&\ƩbY:;4Zq yR Il #j9Q1' 2Ѽ^9ApXI> 姎Qg?%U$ݚJi[Lm&p #'T+ <-2XȐkJ>wTBjwn™Pw-O:\L!(拗x=ή;Sj䢤g{]w?Xg"?ڗ$Ѣ @qy$\݇mU3dVzeA0]xH'adBRH)&n LFE7=j0#onB>CNyoO o^G{”|W,ԂS-Kj64[U*=P^:P ?9\)Ӌm| gVnE'Ք et nQf^N+ާgo:}npf ^hy |^'L碧8'߽IXnuY* xmշ'vtV#o(,5o:Nv'j]z)#ţ}~5;,R頑3Wٵ ^,&D6uGe"O[?<(9_>1[^u=ܲUB蒏* ddG.k@ ̡r|KKTYXZ1?k;endstream endobj 170 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 171 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 172 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 173 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 174 0 obj << /Filter /FlateDecode /Length 162 >> stream x]O10 DJ. EUAp$@g|wYvgA>E0uŭ F,m1,O+x@f烚I>kWBi )(H4E6ƴXIG`4mFU?M%Λk17MR{;RA|qSendstream endobj 175 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 176 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 177 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 178 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 179 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 180 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 181 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 182 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 183 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 184 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 185 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 186 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 187 0 obj << /Filter /FlateDecode /Length 709 >> 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 191 0 obj << /Type /XRef /Length 960 /W [ 1 3 1 ] /Info 3 0 R /Root 2 0 R /Size 192 /ID [<93c0a2aaae0ece7574df5eb009e0960f>] >> stream       !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOBI}SSSSSSSSSS S S S S SSSSSSSSSSSSSSSSSSS S!S"S#S$S%S&S'S(S)S*S+S,S-S.S/S0S1S2S3S4S5S6S7S8S9S:S;S<S=S>S?S@SASBSCSDSESFSGSHSISJSKSLSMSNx x% fz >JZ[v$6b5 (7o>B,E:pRxx endstream endobj startxref 237447 %%EOF