plotmo/0000755000176200001440000000000014664504612011574 5ustar liggesusersplotmo/tests/0000755000176200001440000000000014563612461012736 5ustar liggesusersplotmo/tests/test.plotmo.R0000644000176200001440000000037512764100512015344 0ustar liggesusers# test.plotmo.R # This does a basic sanity test of plotmo. # For more comprehensive tests, see plotmo/inst/slowtests. library(plotmo) library(rpart) data(kyphosis) rpart.model <- rpart(Kyphosis~., data=kyphosis) plotmo(rpart.model, type="vec", trace=1) plotmo/tests/test.plotmo.Rout.save0000644000176200001440000000125214563612461017036 0ustar liggesusers > # test.plotmo.R > # This does a basic sanity test of plotmo. > # For more comprehensive tests, see plotmo/inst/slowtests. > library(plotmo) Loading required package: plotrix > library(rpart) > data(kyphosis) > rpart.model <- rpart(Kyphosis~., data=kyphosis) > plotmo(rpart.model, type="vec", trace=1) stats::predict(rpart.object, data.frame[3,3], type="vec") stats::fitted(object=rpart.object) fitted() was unsuccessful, will use predict() instead got model response from model.frame(Kyphosis~Age+Number+Start, data=call$data, na.action="na.pass") plotmo grid: Age Number Start 87 4 13 > plotmo/.Rinstignore0000644000176200001440000000001313275315113014063 0ustar liggesusersslowtests plotmo/MD50000644000176200001440000002135714664504612012114 0ustar liggesusers06e454ea598fc9d8b44d1335a246d6d6 *DESCRIPTION 66578e5f21418e045c00eba90d47469e *NAMESPACE 51f1297c8dd24ef2eb0eb7d89fa0b8a2 *NEWS.md 1467cd99f814516a11538ec00e136c45 *R/as.char.R d6a7da076d299dcaa2edbe35fb81a026 *R/bx.R 9589326d4f3a274b329d915352034a1b *R/c50.R 4dcc6a18a5be035a1e4497dae7b7cedd *R/call.dots.R f0439166fbc6b21e9d4e640e1a75989e *R/caret.R 8313e46b929e7315b0f6ab1b29aa3675 *R/check.index.R a121377a2962c8a2b3b5ea2f9952a34c *R/do.par.R 3c28173aa59055555bf5ed7079e0f51b *R/dot.R 5a08d54148030b9ae3a10edad3ec4691 *R/dotlib.R 861fba8a34b68a1dd39a3e0f62ab7f14 *R/elegend.R fc659fa5f851f0df094c0bb5534ac32d *R/fitted.R bd52a69a45afb78dbb223c21fb71178d *R/gbm.R 272513f4ff639e72b385cad93ab315f6 *R/gbm.backcompat.R 5172a61a9d181a16591b6a93942b1aca *R/glmnet.R 50d71591ca9a7c399438fb94642b32b1 *R/grid.R 0c68215c3f8b5dc1372e1c3b42972d32 *R/grid.func.R eb6a759ff9a07765a6e53b54809f702e *R/lib.R 48179c86ac55d52efdb85ae534844741 *R/meta.R 18b191e6548aab28f7a4075d407862f1 *R/methods.R 004839b1e52cb50638840b2635bba62b *R/mlr.R d69ebbe9df32a922e8886d735e779092 *R/naken.R eabfd1a547ed2884045cec7779e2dc7c *R/partdep.R 964b5ce6e0729493ed20c043970ab59d *R/partykit.R 439430215813d81e87b00a974a19a0df *R/pint.R 0d312be618b142b4dc3708d9318e4881 *R/plot_gbm.R f2774ccdbdbb11d4b57d22f795826900 *R/plot_glmnet.R 9d562e0797425ec09fe2bdda6600cba2 *R/plotcum.R fdae81bfd8a98ed9298551fe3c56571e *R/plotmo.R df1786a88b8cd00b6b956c8258ca906c *R/plotqq.R 86f491633c494f22d6c65cd00d0bb170 *R/plotres.R 7fa451303357b01ce9207cd3df49e867 *R/plotresids.R 08885181eaa44b48330f54c2e77b898e *R/pre.R fe85abd429fee44f6d609c9309ed0aff *R/predict.R bdf8896a82a46f9c2097e337c0f4a217 *R/predict.nn.R a7cfa01bdb6be6069eeed7f427df35ee *R/printcall.R e19ea08aed52cfd4a2caf0bb11c749c9 *R/prolog.R 54dfa8ee78967bfd14bfe08adcef43cb *R/quantreg.R 11c642968a5174f4a2978df23753ec74 *R/residuals.R 3ce40ca65e3f40673602c7d4fac0fcb7 *R/response.R 9dd8f0a7e56fda7f21bb776f7486bb07 *R/rpart.R 4eb1463adfa036aa03bc9a20e69710b6 *R/singles.R 52a0a2ea4b38645148ca48de84a0567b *R/spread.labs.R 10b221ee9b9f19e92623e133b629efe1 *R/stop.if.dots.R d185816800d45ffd92def6c50d05ec43 *R/type.R ab47d88809f7314f4f82e2e6aef5f448 *R/w1.R 56f3cb29e97b0e21d67feaea1bdfb896 *R/xgboost.R 8239ac7e684324b49c66f3cb1d13ba2f *R/xy.R c10762bf6beb8ae594fe98e62f03566a *README.md 28ee4ac45e2d25b80da2885692fc764c *inst/README-figures/plotmo-randomForest.png bc9547d06efe15fe844a910dc1726dc9 *inst/README-figures/plotres-glmnet-gbm.png 48c0bceb3c05b9c442a6767c92d87dcb *inst/README-figures/plotres-randomForest.png 8ab9f7e2da731b548e17ec146cba9ba0 *inst/doc/index.html f1e2ca8695a781ac16685d701b164ea9 *inst/doc/modguide.pdf 13bd6f0c538869f6815252d360337467 *inst/doc/plotmo-notes.pdf 24df72393a9b3092c79bf0e80a2e14d4 *inst/doc/plotres-notes.pdf 9e35189fa10d4674f2284552fcbbfe64 *inst/slowtests/README.txt e64833b093ebe9ceed33758e0944d362 *inst/slowtests/linmod.R 42c25d22bd1996d34193935c602afef7 *inst/slowtests/linmod.methods.R 72d2ea19f32d670c448703471b187346 *inst/slowtests/make.README.R f2c754673178354bbb349d1e7b7151d7 *inst/slowtests/make.README.bat 07d625248e3a7c2bcd017771e0b84eb4 *inst/slowtests/make.README.figs.R af4e7fcf61ad20030a33ba2a3a26ccc4 *inst/slowtests/make.bat 153b4a6a14d4b0dd4424e722577babd6 *inst/slowtests/makeclean.bat c5bf9446a0eeb97275ad7a7e61ed86b4 *inst/slowtests/modguide.model1.R 08fe3d6be516a61bf72da88502c184c2 *inst/slowtests/modguide.model2.R c2ddbbb20a0c65ef2ccd60de7523d92d *inst/slowtests/test.c50.R 69af490113c14840727e4f59bcb5ff30 *inst/slowtests/test.c50.Rout.save 3bbd8e28d1f8735593cdc9f994b9682d *inst/slowtests/test.c50.bat 9deb8fde036cc52a51d15bedbc26fbb9 *inst/slowtests/test.caret.R ef3779e3c312cddc44174887bfa29a91 *inst/slowtests/test.caret.Rout.save 0601d4f674538ed55845fe394eaec4d1 *inst/slowtests/test.caret.bat 08890c43763882c3f9c60f1e4db81d23 *inst/slowtests/test.center.R 3e699701331939677dffc36627b59a74 *inst/slowtests/test.center.Rout.save ab04703b027b7166c8a07f1198152022 *inst/slowtests/test.center.bat edd4aa48ab07211045b03469d1feda3c *inst/slowtests/test.degree.R df0bc255b5f61d1a3ec4c6ce0367c38b *inst/slowtests/test.degree.Rout.save d058ec2621032a49554df8b89dfade09 *inst/slowtests/test.degree.bat 9bb9c0c749fa373398fde8d760651904 *inst/slowtests/test.dots.R cc1b24d974a892398459c4a74e924f74 *inst/slowtests/test.dots.Rout.save 9aabee3535e6e6b106976085f1060a61 *inst/slowtests/test.dots.bat 7306baea0c61d656121cd743183c8172 *inst/slowtests/test.epilog.R d8dd1aa1fdfd8a908d1d568d5646da4f *inst/slowtests/test.fac.R 4dbadc709933462c35a8d58497a74f08 *inst/slowtests/test.fac.Rout.save 8661f44a48482e2792b3ac68b244a180 *inst/slowtests/test.fac.bat f699dac6d1f2e78dcc6f922ae4f7de42 *inst/slowtests/test.gbm.R 9909243a3417eeef74e3e09f013897a6 *inst/slowtests/test.gbm.Rout.save adf7c90a9db1dfb2c56defcd7c7bbd1b *inst/slowtests/test.gbm.bat 51b3736ee000e97783d80713a0a29b67 *inst/slowtests/test.glmnet.R b85188622205243e6b97b377b8698ad7 *inst/slowtests/test.glmnet.Rout.save 01648a1e68f6d93c5e07210983caf776 *inst/slowtests/test.glmnet.bat 8496d462371e78d7e4d2f7999ab645d7 *inst/slowtests/test.glmnetUtils.R 2ae3176073faaf1856ee95027104e7b5 *inst/slowtests/test.glmnetUtils.Rout.save 2aa87827a7951eea97f873f0702502c6 *inst/slowtests/test.glmnetUtils.bat 07a08d4c8cf37da28c0764ce116642ad *inst/slowtests/test.linmod.R d969b43841305639600194d577003e85 *inst/slowtests/test.linmod.Rout.save 38ea6134f9172300007f909fff0307a1 *inst/slowtests/test.linmod.bat c69bc15b4c2e8e30e3b01f7f0d78d850 *inst/slowtests/test.mlr.R 5ddf307f48f3283088bb3a2f207297cd *inst/slowtests/test.mlr.Rout.save 882fdfec858986a9deb2fbab0835a343 *inst/slowtests/test.mlr.bat da121b113f85eabc4b1b044d15c1f5e9 *inst/slowtests/test.modguide.R f8a90b64cca57032357382747319d752 *inst/slowtests/test.modguide.Rout.save ad4bcbbb2b7849c3814d7c1382e1d903 *inst/slowtests/test.modguide.bat d665c3792390c0a1a96cbc8c2949111c *inst/slowtests/test.non.earth.R b2bde5b7fc853e25f40289dcc2900caf *inst/slowtests/test.non.earth.Rout.save 7e5a3d12922464e5276e02fddb857e88 *inst/slowtests/test.non.earth.bat 664cae41f5a42939cd7c51c32b576ca4 *inst/slowtests/test.parsnip.R a8a2dd287dd0411573cd9159b77dfe3c *inst/slowtests/test.parsnip.Rout.save f256f1b4246b0f7c39a65189c9a62e62 *inst/slowtests/test.parsnip.bat cc523ea72083c545c0c27f1b0d999076 *inst/slowtests/test.partdep.R 55523406ab53d6dd93ca9e540348edbe *inst/slowtests/test.partdep.Rout.save 0563f9559c7e37c99fee9dc2efd88763 *inst/slowtests/test.partdep.bat e7b4ddac909472912a9e8328be7f94b4 *inst/slowtests/test.partykit.R 8d8a1aeac4f0d598a68896f932bdcb50 *inst/slowtests/test.partykit.Rout.save 1347619bfd12a9890e2f468b217bd261 *inst/slowtests/test.partykit.bat cb7d93b2b463bc75a6329ab2eed2ca7a *inst/slowtests/test.plotmo.R 4ab8418640e6ca0fcd12dc42787c1ebd *inst/slowtests/test.plotmo.Rout.save 666466cb642df4dede54601e130d3830 *inst/slowtests/test.plotmo.args.R 16280d6d059b012633a5e186ca94a1dd *inst/slowtests/test.plotmo.args.Rout.save cf1f837b35572f1e98ad244a79b5cfb4 *inst/slowtests/test.plotmo.args.bat 1131174d0c8ee14cc262c654a3c51b19 *inst/slowtests/test.plotmo.bat 20d163931383b7ef67b6dffa9b4ff142 *inst/slowtests/test.plotmo.dots.R 9813c5977ad4893417e6521342f8ebb6 *inst/slowtests/test.plotmo.dots.Rout.save cfbb59edec44ec2199c84752f97b5194 *inst/slowtests/test.plotmo.dots.bat a2a01720e39bc85f95048c6a7190b8c1 *inst/slowtests/test.plotmo.x.R 2aa66c56e6ac567739e3f0a383c500de *inst/slowtests/test.plotmo.x.Rout.save b580cb43e33ba57154af0e502895f767 *inst/slowtests/test.plotmo.x.bat d5396dcceb11821662abcd9b270d804e *inst/slowtests/test.plotmo3.R 5c7795dd32f455ef43f57af286e16a2c *inst/slowtests/test.plotmo3.Rout.save 0f1e10e7f902d1bb1a12a200996ddd21 *inst/slowtests/test.plotmo3.bat 28c18027816c319271d47340b26fe665 *inst/slowtests/test.plotres.R accc3fd3c7af6e9492831e65c69c4f69 *inst/slowtests/test.plotres.Rout.save 1ebd593ebe03882e4181d6350e4e69c3 *inst/slowtests/test.plotres.bat c1db5aad2002cf85a950ffc2fb5d68f1 *inst/slowtests/test.pre.R eb9f2cdf9b513ccc675f0d4546263c70 *inst/slowtests/test.pre.Rout.save b023e0547f8954d45024c2baec0f1e35 *inst/slowtests/test.pre.bat 6e1bdddcf2d7ae571462722b81db918e *inst/slowtests/test.printcall.R 26d77e59a4b728dc3620a37bd3e53377 *inst/slowtests/test.printcall.Rout.save 62f1623402f540a4a0e36123c52941cd *inst/slowtests/test.printcall.bat e152b8519f616894608c34ee2b5c27a9 *inst/slowtests/test.prolog.R f9acb0955d92b42144d713bd758f1b76 *inst/slowtests/test.unusual.vars.R a5401a929d1526a0f0a82217773fdc2b *inst/slowtests/test.unusual.vars.Rout.save 548e6f5db402384792e577af57586c1f *inst/slowtests/test.unusual.vars.bat 97f4b1936b2d0a85e0d0e4c6e8717dfa *man/plot_gbm.Rd a6f6ed5990f2f359b77bed2e67b99b24 *man/plot_glmnet.Rd c89eb75643f8e92dbdb2bb25325db678 *man/plotmo.Rd 751ab8af1d939886b1a97fb7381b6991 *man/plotmo.misc.Rd 7015c263000f0c68c97afca760fced54 *man/plotres.Rd 3ac7804a66f1f72eabc7d38afc3d4565 *tests/test.plotmo.R 04765eb169cdade58d3e4fb3a67893da *tests/test.plotmo.Rout.save plotmo/R/0000755000176200001440000000000014664450254011777 5ustar liggesusersplotmo/R/predict.nn.R0000644000176200001440000000725214663771205014175 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/c50.R0000644000176200001440000000323714663771205012517 0ustar liggesusers# c50.R: plotmo functions for model objects from the C50 package plotmo.prolog.C5.0 <- function(object, object.name, trace, ...) # invoked when plotmo starts { # "imp" is a vector of variable indices (column numbers in x), most # important vars first, no variables with relative.influence < 1%. imp <- order.C5.0.vars.on.importance(object) attr(object, "plotmo.importance") <- imp if(trace > 0) cat0("importance: ", paste.trunc(object$predictors[imp], maxlen=120), "\n") object } order.C5.0.vars.on.importance <- function(object) { imp <- C50::C5imp(object) stopifnot(is.data.frame(imp) && all(dim(imp) == c(object$dims[2], 1))) imp <- imp[imp >= 1, , drop=FALSE] stopifnot(length(imp) > 0) imp <- match(rownames(imp), object$predictors) stopifnot(!anyNA(imp)) imp } plotmo.singles.C5.0 <- function(object, x, nresponse, trace, all1, ...) { if(all1) return(1:length(object$predictors)) importance <- attr(object, "plotmo.importance") stopifnot(!is.null(importance)) # uninitialized? # indices of vars with importance >= 1%, max of 10 variables # (10 becauses plotmo.pairs returns 6, total is 16, therefore 4x4 grid) importance[1: min(10, length(importance))] } plotmo.pairs.C5.0 <- function(object, ...) { importance <- attr(object, "plotmo.importance") stopifnot(!is.null(importance)) # uninitialized? # choose npairs so a total of no more than 16 plots # npairs=5 gives 10 pairplots, npairs=4 gives 6 pairplots npairs <- if(length(importance) <= 6) 5 else 4 form.pairs(importance[1: min(npairs, length(importance))]) } plotmo/R/partykit.R0000644000176200001440000002075214663771205014000 0ustar liggesusers# partykit.R: hackery for plotmo to support the partykit package plotmo.prolog.party <- function(object, object.name, trace, ...) # called when plotmo starts { check.mob.object(object) # Attach plotmo.importance (a character vector) to the model. object <- attach.party.plotmo.importance(object, trace) # Following is necessary because we will shortly change the class of the object # (and therefore getCall.party won't work, we must rely on getCall.default). # We need the call to get the data used to build the model. (We can't use # object$data because that may contain "variable names" like "log(lstat)".) object$call <- getCall(object) # The meaning of "[[" is redefined for party objects i.e. the partykit # package defines "[[.party". Since in the plotmo code we need [[ to do # things like object[["x"]], we change the class of the object here, so # [[ has its standard meaning for the object while we are in plotmo. trace2(trace, "changing class of %s from %s to \"party_plotmo\" for standard \"[[\"\n", object.name, quote.with.c(class(object))) original.class <- class(object) # save for plotmo.predict.party_plotmo class(object) <- "party_plotmo" object$original.class <- original.class object } plotmo.predict.party_plotmo <- function(object, newdata, type, ..., TRACE) { stopifnot(is.character(object$original.class)) class(object) <- object$original.class # suppress warnings: # Warning: 'newdata' had 2 rows but variables found have 297 rows # Warning in rval[ix[[i]]] <- preds[[i]] : number of items to replace is not a multiple of replacement length on.exit(options(warn=old.warn)) options(warn=-1) old.warn <- getOption("warn") predict <- plotmo.predict(object, newdata, type=type, ..., TRACE=TRACE) predict } # attach plotmo.importance (a character vector) to the model attach.party.plotmo.importance <- function(object, trace) { varimp <- try(varimp(object), silent=TRUE) if(is.try.err(varimp)) { # only some party objects support varimp # the variable(s) before the | in the formula varnames <- colnames(attr(object$info$terms$response, "factors")) # append variables actually used in the tree, in order of importance varnames <- c(varnames, names(varimp_party(object))) } else varnames <- names(sort(varimp, decreasing=TRUE)) varnames.original <- varnames for(i in seq_along(varnames)) varnames[i] <- naken.collapse(varnames[i]) # e.g. log(lstat) becomes lstat if(trace >= 1) cat("variable importance:", varnames, "\n") attr(object, "plotmo.importance") <- varnames object } # Like varimp.constparty but works for all party trees, including mob trees. # Splits that affect more observations get more weight. # Splits near the root get slightly more weight (lower depth). # (This is to disambiguate vars that have equal importance otherwise.) varimp_party <- function(object) { init.varimp <- function(node, varimp, depth) { # update varimp for tree starting at node by walking the tree varid <- node$split$varid if(!is.null(varid)) { check.index(varid, "varid", varimp) # paranoia nobs <- if(!is.null(node$info$nobs)) node$info$nobs else 1 varimp[varid] <- varimp[varid] + nobs - .0001 * depth } knodes <- partykit::kids_node(node) for(node in knodes) if(!is.null(node)) varimp <- init.varimp(node, varimp, depth+1) # recurse varimp } #--- varimp_party starts here varnames <- colnames(object$data) varimp <- repl(0, length(varnames)) names(varimp) <- varnames varimp <- init.varimp(object$node, varimp, depth=0) sort(varimp[varimp != 0], decreasing=TRUE) # discard vars not in tree, sort } plotmo.singles.party_plotmo <- function(object, x, nresponse, trace, all1, ...) { all <- seq_along(colnames(x)) if(all1) return(all) varnames <- attr(object, "plotmo.importance") stopifnot(!is.null(varnames)) i <- match(varnames, colnames(x)) ina <- which(is.na(i)) # sanity check if(length(ina)) { warnf( "could not find \"%s\" in %s\nWorkaround: use all1=TRUE to plot all variables", varnames[ina[1]], quote.with.c(colnames(x))) i <- i[!is.na(i)] } if(length(i) == 0) { warnf("could not estimate variable importance") i <- seq_along(length(colnames(x))) # something went wrong, use all vars } # indices of important variables, max of 10 variables # (10 becauses plotmo.pairs returns 6, total is 16, therefore 4x4 grid) i[1: min(10, length(i))] } plotmo.pairs.party_plotmo <- function(object, x, nresponse, trace, all2, ...) { singles <- plotmo.singles(object, x, nresponse, trace, all1=FALSE, ...) # choose npairs so a total of no more than 16 plots # npairs=5 gives 10 pairplots, npairs=4 gives 6 pairplots npairs <- if(length(singles) <= 6) 5 else 4 form.pairs(singles[1: min(npairs, length(singles))]) } # Check the mob object formula and issue a work-around message when # the formula won't work for predictions with new data. # This prevents err msg: 'newdata' had 1 row but variables found have 167 rows check.mob.object <- function(object) { call.fit <- getCall(object)$fit # was a fit func passed to the model building func? if(is.null(call.fit)) return() # it's a mob object func <- eval(call.fit) stopifnot(inherits(func, "function")) func <- deparse(func, width.cutoff=500) # Is there a "(" followed by "~" followed by a lone "x," in the function body? # Or a "(" followed by "~" followed by "x - 1,". regex1 <- "\\(.*\\~.*[^a-zA-Z0-9_\\.]x," regex2 <- "\\(.*\\~.*x \\- 1," regex <- paste0(regex1, "|", regex2) grepl <- grepl(regex, func) if(any(grepl)) { # Issue the following message (details will vary depending on the fit func): # # The following formula in the mob fit function is not supported by plotmo: # # glm(y ~ 0 + x, family = binomial, start = start, ...) # # Possible workaround: Replace the fit function with: # # function (y, x, start = NULL, weights = NULL, offset = NULL, ...) # { # glm(as.formula(paste("y ~ ", paste(colnames(x)[-1], collapse="+"))), # family = binomial, start = start, ...) # } # # Error: The formula in the mob fit function is not supported by plotmo (see above) printf("\nThe following formula in the mob fit function is not supported by plotmo:\n\n") ifunc <- which(grepl)[1] cat(func[ifunc]) regex <- "\\([^,]+," func[ifunc] <- sub(regex, "(as.formula(paste(\"y ~ \", paste(colnames(x)[-1], collapse=\"+\"))),\n data=x,", func[ifunc]) printf("\n\nPossible workaround: Replace the fit function with:\n\n") printf(" %s <- ", as.character(call.fit)) for(i in 1:length(func)) printf("%s\n ", func[i]) printf("\n") stop0("The formula in the mob fit function is not supported by plotmo (see above)\n", " This is because predict.mob often fails with newdata and type=\"response\"\n", " e.g. example(mob); predict(pid_tree, newdata=PimaIndiansDiabetes[1:3,], type=\"response\")") } } # cforest objects plotmo.prolog.parties <- function(object, object.name, trace, ...) # called when plotmo starts { attr(object, "plotmo.importance") <- order.parties.vars.on.importance(object, trace) # a char vector object } order.parties.vars.on.importance <- function(object, trace) # a char vector { varimp <- try(varimp(object), silent=TRUE) varnames <- if(is.try.err(varimp)) colnames(object$data)[-1] # -1 to drop response TODO is this reliable? else names(sort(varimp, decreasing=TRUE)) if(trace >= 1) cat("variable importance:", varnames, "\n") varnames } plotmo.singles.parties <- function(object, x, nresponse, trace, all1, ...) { plotmo.singles.party_plotmo(object, x, nresponse, trace, all1, ...) } plotmo.pairs.parties <- function(object, x, nresponse, trace, all2, ...) { plotmo.pairs.party_plotmo(object, x, nresponse, trace, all2, ...) } plotmo/R/partdep.R0000644000176200001440000001133514663771205013565 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/lib.R0000644000176200001440000012676214663771205012707 0ustar liggesusers# lib.R: miscellaneous functions for plotmo and related packages # functions in this file are in alphabetical order any1 <- function(x) { any(x != 0) # like any but no warning if x not logical } cat0 <- function(...) # cat with no added spaces { cat(..., sep="") } check <- function(object, object.name, check.name, check.func, na.ok=FALSE) { any <- check.func(object) if(na.ok) any <- any[!is.na(any)] else { which.na <- which(is.na(any)) if(length(which.na)) { stopf("NA in %s\n %s[%d] is %g", object.name, object.name, which.na[1], object[which.na[1]]) } } if(any(any)) { which <- which(check.func(object)) stopifnot(length(which) > 0) stopf("%s in %s\n %s[%d] is %g", check.name, object.name, object.name, which[1], object[which[1]]) } } # TODO commented out the following because it is too slow for big data # (the as.character is very slow) # # # The args argument is assumed to be a list of arguments for do.call. # # An argument in args will be an unforced promise if it couldn't be # # evaluated earlier e.g. if call.plot was invoked with arg=nonesuch. # # If an argument is such an unforced promise, issue an error message now # # to prevent very confusing error messages later. To do this, we have to # # determine if the arg is a promise, which we do with the if statement # # below. # # This makes me nervous, because the R language manual says "There is # # generally no way in R code to check whether an object is a promise or not". # # check.do.call.args <- function(func, args, fname) # { # stopifnot(is.list(args)) # for(i in seq_along(args)) { # if(length(args[i]) == 1 && !is.na(args[i]) && # substr(as.character(args[i]), 1, 2) == "..") { # printf("\n") # s <- paste0(strwrap(list.as.char(args), # width=getOption("width"), exdent=7), collapse="\n") # stop0("cannot evaluate ", quotify(names(args)[i], "'"), # " in\n ", fname, "(", s, ")") # } # } # } # mostly for checking user arguments (so error wording is for that) # but also occasionally used for other sanity checking check.boolean <- function(b) # b==0 or b==1 is also ok { if(length(b) != 1) stop0("the ", short.deparse(substitute(b), "given"), " argument is not FALSE, TRUE, 0, or 1") if(!(is.logical(b) || is.numeric(b)) || is.na(b) || !(b == 0 || b == 1)) stop0(short.deparse(substitute(b), "the argument"), "=", as.char(b), " but it should be FALSE, TRUE, 0, or 1") b != 0 # convert to logical } is.boolean <- function(b) # b==NA or b==0 or b==1 { length(b) == 1 && (is.logical(b) || is.numeric(b)) && (is.na(b) || b == 0 || b == 1) } check.classname <- function(object, substituted.object, allowed.classnames) { expected.classname <- quotify(allowed.classnames) if(length(allowed.classnames) > 1) expected.classname <- sprint("one of\n%s", expected.classname) if(is.null(object)) stopf("object is NULL but expected an object of class of %s", expected.classname) if(!inherits(object, allowed.classnames)) { stopf("the class of %s is \"%s\" but expected the class to be %s", quotify(paste.trunc(substituted.object, maxlen=30)), class(object)[1], expected.classname) } } # adjust name so e.g. error message is "argument is NULL" not "NULL is NULL" tweak.name <- function(name, quote=TRUE) { quoted.name <- quotify(name, quote="'") if(name %in% c("NULL", "NA") || (substr(name[1], 1, 1) %in% c("+", "-")) || grepl("[0-9]", substr(name[1], 1, 1))) { quoted.name <- name <- "argument" } if(quote) quoted.name else name } check.integer.scalar <- function(object, min=NA, max=NA, null.ok=FALSE, na.ok=FALSE, logical.ok=TRUE, char.ok=FALSE, object.name=short.deparse(substitute(object))) { stop.msg <- function(s) { s.null <- if(null.ok) ", or NULL" else "" s.na <- if(na.ok) ", or NA" else "" s.logical <- if(logical.ok) ", or TRUE or FALSE" else "" s.char <- if(char.ok) ", or a string" else "" stop0(s, " but it should be an integer", s.null, s.na, s.logical, s.char) } if(is.character(object)) { if(!char.ok || length(object) != 1) stop.msg(paste0(tweak.name(object.name), " is a string")) } else { check.numeric.scalar(object, min, max, null.ok, na.ok, logical.ok, char.ok.msg=char.ok, object.name=object.name) if(!is.null(object) && !is.na(object) && object != floor(object)) stop.msg(paste0(tweak.name(object.name, quote=FALSE), "=", object[1])) } object } check.level.arg <- function(level, zero.ok) { if(anyNA(level) || is.null(level)) # treat NA and NULL as 0 level <- 0 check.numeric.scalar(level) if(!((zero.ok && level == 0) || level >= .5 || level < 1)) { stop0("level=", level, " but it should be ", if(zero.ok) "zero or " else "", "between 0.5 and 1") } level } check.no.na.in.mat <- function(object) { if(anyNA(object)) { # quick initial check # detailed check for detailed error message for(icol in seq_along(ncol(object))) { check.name <- if(!is.null(colnames(object))) colnames(object)[icol] else sprint("%s[,%d]", short.deparse(substitute(object), "matrix"), icol) check(object[,icol], check.name, "NA", is.na, na.ok=FALSE) } } } # x can be a data.frame or matrix check.df.numeric.or.logical <- function(x, xname=trunc.deparse(substitute(x))) { stopifnot(!is.null(x), length(dim(x)) == 2) for(icol in seq_len(NCOL(x))) { if(!is.numeric(x[,icol]) && !is.logical(x[,icol])) stopf("the class of %s is \"%s\" (expected numeric or logical)", colname(x, icol, xname), class(x[,icol])) is.na <- is.na(x[,icol]) if(any(is.na)) stopf("%s[%g] is NA", colname(x, icol, xname), which(is.na)[1]) is.infinite <- !is.finite(x[,icol]) if(any(is.infinite)) stopf("%s[%g] is Inf", colname(x, icol, xname), which(is.infinite)[1]) } } check.numeric.scalar <- function(object, min=NA, max=NA, null.ok=FALSE, na.ok=FALSE, logical.ok=FALSE, char.ok.msg=FALSE, # only affects error msg object.name=short.deparse(substitute(object))) { s.logical <- if(logical.ok) ", or TRUE or FALSE" else "" if(na.ok) logical.ok <- TRUE # needed because NA is a logical any.na <- !is.null(object) && # following needed because anyNA gives error on some objects (is.numeric(object) || is.logical(object) || is.list(object) || is.character(object)) && anyNA(object) if(is.null(object)) { if(!null.ok) stop0(tweak.name(object.name), " is NULL") } else if(any.na && !na.ok) stop0(tweak.name(object.name), " is NA") else if(!is.numeric(object) && !(is.logical(object) && logical.ok)) { s.na <- if(na.ok) ", or NA" else "" s.null <- if(null.ok) ", or NULL" else "" s.char <- if(char.ok.msg) ", or a string" else "" stopf("%s must be numeric%s%s%s%s (whereas its current class is %s)", tweak.name(object.name), s.null, s.na, s.char, s.logical, class.as.char(object, quotify=TRUE)) } else if(length(object) != 1) stopf("the length of %s must be 1 (whereas its current length is %d)", tweak.name(object.name), length(object)) if(!is.null(object) && !any.na) { if(!is.na(min) && !is.na(max) && (object < min || object > max)) { stop0(tweak.name(object.name, quote=FALSE), "=", object, " but it should be between ", min, " and ", max) } if(!is.na(min) && object < min) { stop0(tweak.name(object.name, quote=FALSE), "=", object, " but it should be at least ", min) } if(!is.na(max) && object > max) { stop0(tweak.name(object.name, quote=FALSE), "=", object, " but it should not be greater than ", max) } } object } # We allow 20% of x to be nonpositive, useful if the response is essentially # positive, but the predicted response has a few nonpositive values at the extremes. # Needed for example if we will later take log(x) or sqrt(x). check.that.most.are.positive <- function(x, xname, user.arg, non.positive.msg, frac.allowed=.2) { check.numeric.scalar(frac.allowed) stopifnot(frac.allowed >= 0, frac.allowed <= 1) nonpos <- x <= 0 if(sum(nonpos, na.rm=TRUE) > frac.allowed * length(x)) { # more than frac.allowed nonpos? ifirst <- which(nonpos)[1] stop0(sprint( "%s is not allowed because too many %ss are %s\n", user.arg, unquote(xname), non.positive.msg), sprint( " %.2g%% are %s (%g%% is allowed)\n", 100 * sum(nonpos) / length(x), non.positive.msg, 100 * frac.allowed), sprint(" e.g. %s[%d] is %g", unquote(xname), ifirst, x[ifirst])) } } check.vec <- function(object, object.name, expected.len=NA, logical.ok=TRUE, na.ok=FALSE) { if(!(NROW(object) == 1 || NCOL(object) == 1)) stop0(tweak.name(object.name), " is not a vector\n ", "It has dimensions ", NROW(object), " by ", NCOL(object)) if(!((logical.ok && is.logical(object)) || is.numeric(object))) stop0(tweak.name(object.name), " is not numeric") if(!is.na(expected.len) && length(object) != expected.len) stop0(tweak.name(object.name), " has the wrong length ", length(object), ", expected ", expected.len) if(na.ok) object[is.na(object)] <- 1 # prevent check is.finite from complaining else check(object, object.name, "NA", is.na) check(object, object.name, "non-finite value", function(object) {!is.finite(object)}) } cleantry <- function(err) # clean up a try.err (remove "Error: " etc.) { stopifnot(is.try.err(err)) attributes(err) <- NULL err <- gsub("^[^:]*: *", "", err) # remove "Error: " (actually everything up to the first colon) err <- gsub("\n", " ", err, fixed=TRUE) # remove newlines err <- gsub(" +", " ", err) # multiple spaces to single spaces gsub(" $", "", err) # remove trailing space } # returns the column name, if that is not possible then something like x[,1] colname <- function(object, i, object.name=trunc.deparse(substitute(object))) { check.numeric.scalar(i) check.index(i, object.name, object, is.col.index=TRUE, allow.negatives=FALSE) colnames <- safe.colnames(object) if(!is.null(colnames)) colnames[i] else if(NCOL(object) > 1) sprint("%s[,%g]", object.name, i) else sprint(object.name) } # if trace>0 or the func fails, then print the call to func do.call.trace <- function(func, args, fname=short.deparse(deparse(func), "FUNC"), trace=0) { stopifnot(is.logical(trace) || is.numeric(trace), length(trace) == 1) # TODO commented out the following because it is too slow for big data # check.do.call.args(func, args, fname) trace <- as.numeric(trace) if(trace > 0) printf.wrap("%s(%s)\n", fname, list.as.char(args)) try <- try(do.call(what=func, args=args), silent=TRUE) if(is.try.err(try)) { if(trace == 0) # didn't print call above? then print it now printf.wrap("\n%s(%s)\n\n", fname, list.as.char(args)) else if(trace >= 2) # TODO is this best? printf("\n") # Re-call func so user can do a traceback within the function. Note that # if do.call.trace was called with try, this will be caught by that try. # TODO is there a better way to achieve this, perhaps using tryCatch # this could be confusing if func has side effects (unlikely) do.call(what=func, args=args) # should never get here stop0("second do.call(", fname, ", ...) did not give the expected error: ", try[1]) } invisible(try) # TODO is invisible necessary? } # identical to base::eval() but has trace and expr.name arguments eval.trace <- function( expr, envir = parent.frame(), enclos = if(is.list(envir) || is.pairlist(envir)) parent.frame() else baseenv(), trace = 0, expr.name = NULL) { stopifnot(is.environment(envir)) stopifnot(is.environment(enclos)) if(trace >= 2) printf("eval(%s, %s)\n", if(is.null(expr.name)) trunc.deparse(substitute(expr)) else expr.name, environment.as.char(envir)) eval(expr, envir, enclos) } exp10 <- function(x) # e.g. exp10(-3) = 1e-3 { exp(x * log(10)) } # This function is used for checking both xlim and ylim. # This checks that lim is is a 2 element numeric vector. # Also, if xlim[1] == xlim[2], then plot() issues a confusing message. # We don't want that, so use this function to make sure xlim[2] # is different to xlim[1]. fix.lim <- function(lim) { if(!is.null(lim) && !inherits(lim, "Date")) { stopifnot(is.numeric(lim), length(lim) == 2) # constants below are arbitrary small <- max(1e-6, .01 * abs(lim[1] - lim[2])) if(abs(lim[2] - lim[1]) < small) # illegal lim? lim <- c(lim[1] - small, lim[2] + small) } lim } # Ensure all columns of x have column names. Won't overwrite existing column names. gen.colnames <- function(x, prefix="x", alt.prefix=prefix, trace=0) { if(NCOL(x) == 0) return(NULL) # If prefix is long and has characters like ( or [ then use the # alternate prefix. This is sometimes necessary when prefix is # generated using deparse and the arg is something like # "cbind(trees$Volume,trees$Volume+100)" if(any(nchar(prefix) > 30) && grepany("[([,]", prefix)) { trace2(trace, "using alt.prefix \"%s\" instead of prefix \"%s\"\n", alt.prefix, prefix) prefix <- alt.prefix } stopifnot(length(prefix) <= NCOL(x)) prefix <- substr(prefix, 1, 60) new.colnames <- if(NCOL(x) == length(prefix)) prefix else if(grepany("\\[", prefix)) new.colnames <- paste0(prefix, "[", seq_len(NCOL(x)), "]") else new.colnames <- paste0(prefix, seq_len(NCOL(x))) colnames <- org.colnames <- colnames(x) if(is.null(colnames)) colnames <- new.colnames else { missing <- !nzchar(colnames) if(any(missing)) colnames[missing] <- new.colnames[missing] } if(length(unique(colnames)) != length(colnames)) stop0("Duplicate colname in ", paste.trunc(prefix), " (colnames are ", paste.with.quotes(colnames, maxlen=60), ")") if(trace >= 2 && !identical(org.colnames, colnames)) trace2(trace, "colname%s %s now %s\n", if(length(colnames) > 1) "s were" else " was", if(is.null(org.colnames)) "NULL" else paste.trunc(quotify(org.colnames)), paste.trunc(quotify(colnames))) colnames } get.mean.rsq <- function(rss, tss, wp) { if(is.null(wp)) wp <- repl(1, length(rss)) stopifnot(length(rss) == length(tss), length(wp) == length(tss)) total.rsq <- 0 for(iresp in seq_along(rss)) total.rsq <- total.rsq + wp[iresp] * get.rsq(rss[iresp], tss[iresp]) sum(total.rsq) / sum(wp) } # Get the environment for evaluating the model data: # 1. Return the environment in which the model function # was originally called. # 2. Else if the model already has an attribute .Environment, use that. # 3. Else return the environment in which the caller of this function # was called (e.g. return the environment of plotmo's caller). get.model.env <- function(object, object.name="object", trace=0, use.submodel=FALSE) { # check args, because this func is called very early in plotmo (and friends) check.numeric.scalar(trace, logical.ok=TRUE) if(trace >= 2) { callers.name <- callers.name() my.call <- call.as.char(n=2) printf.wrap("%s trace %g: %s\n", callers.name, trace, my.call) printf("--get.model.env for object with class %s\n", class.as.char(object)) } stopifnot.string(object.name) if(is.null(object)) stopf("argument %s is NULL", object.name) if(!is.list(object)) stopf("%s is not an S3 model", object.name) if(class(object)[1] == "list") # some packages build models without a specific class stopf("%s is a plain list, not an S3 model", object.name) obj <- object # Special handling for parsnip models. Their class is like c("_earth", "model_fit"). # For these models, use the env if any saved with the submod (e.g. earth) # (We don't do this for caret models because caret models have a terms field.) # # TODO this code is preliminary (works with parsnip 0.1.3) # and only works if model saves the data (e.g. lm, earth(keepxy=TRUE), not rpart if(use.submodel && inherits(object, "model_fit")) { # parsnip trace2(trace, "plotmo parsnip model: will plot %s$fit, not %s itself\n", gsub("'", "", object.name), object.name) obj <- object[["fit"]] if(!is.list(obj)) # sanity check stopf("plotmo parsnip model: %s$fit is not an S3 model", gsub("'", "", object.name)) # TODO following is temporary, hopefully if(inherits(obj, "rpart") && is.null(obj$model)) stop0( "Cannot plot parsnip rpart model: need model=TRUE in call to rpart\n", " Do it like this: set_engine(\"rpart\", model=TRUE)") } if(trace >= 2) { call <- getCall(obj) if(is.null(call)) printf("object has no call field (it's class is %s)\n", class.as.char(object)) else printf.wrap("object call is %s\n", strip.deparse(call), maxlen=120) } terms <- try(terms(obj), silent=trace < 3) # Following will fail (correctly) for non-formula models because they have no terms. # # TODO Also, if use.submodel, don't use terms (because the term env was # inside the parsnip func that created the submodel) # But that also fails later when we eval the formula because # eval will use GlobalEnv instead of the data passed to the model if(!is.null(terms) && !is.try.err(terms)) { model.env <- attr(terms, ".Environment") if(is.null(model.env)) { if(inherits(obj, "glmnet.formula") || # glmnetUtils package inherits(obj, "cv.glmnet.formula")) if(inherits(obj, "glmnet.formula")) stop0( "for this plot, glmnet.formula must be called with use.model.frame=TRUE") if(inherits(obj, "cv.glmnet.formula")) stop0( "for this plot, cv.glmnet.formula must be called with use.model.frame=TRUE") stop0("attr(terms, \".Environment\") is NULL") } if(!is.environment(model.env)) stop0("attr(terms, \".Environment\") is not an environment") else { trace2(trace, "using the environment saved in $terms of the %s model: %s\n", class.as.char(obj), environment.as.char(model.env)) return(model.env) } } model.env <- attr(obj, ".Environment") if(is.environment(model.env)) { trace2(trace, "using attr(obj,\".Environment\") saved with %s model: %s\n", class.as.char(obj), environment.as.char(model.env)) return(model.env) } if(!is.null(model.env)) stop0("attr(obj, \".Environment\") is not an environment") # n=2 is the caller of the function that called get.model.env # for plotmo it will be the caller of plotmo, typically R_GlobalEnv model.env <- parent.frame(n=2) trace2(trace, "assuming the environment of the %s model is that of %s's caller: %s\n", class.as.char(obj), callers.name, environment.as.char(model.env)) model.env } get.rsq <- function(rss, tss) { rsq <- 1 - rss / tss # following makes testing easier across machines in presence of numerical error rsq[rsq > -1e-5 & rsq < 1e-5] <- 0 rsq } get.weighted.rsq <- function(y, yhat, w=NULL) # NAs will be dropped before calc { stopifnot(length(y) > 0, length(y) == length(yhat)) if(is.null(w)) { is.na <- is.na(y) | is.na(yhat) y <- y[!is.na] yhat <- yhat[!is.na] if(length(y) == 0) stop0("length(y) == 0 after deleting NAs in y or yhat") rss <- sos(y - yhat) tss <- sos(y - mean(y)) } else { stopifnot(length(w) == length(yhat)) is.na <- is.na(y) | is.na(yhat) | is.na(w) y <- y[!is.na] yhat <- yhat[!is.na] w <- w[!is.na] if(length(y) == 0) stop0("length(y) == 0 after deleting NAs in y or yhat or w") rss <- sos(y - yhat, w) tss <- sos(y - weighted.mean(y, w), w) } get.rsq(rss, tss) } # TRUE if pattern is in any of the strings in x grepany <- function(pattern, x, ignore.case=FALSE, ...) { any(grepl(pattern, x, ignore.case=ignore.case, ...)) } # scalar form of ifelse, with short name :-) # only evaluates the "no" argument if necessary ife <- function(ife.test, ife.yes, ife.no) { ife.test <- check.boolean(ife.test) stopifnot(!missing(ife.yes)) stopifnot(!missing(ife.no)) if(ife.test) ife.yes else ife.no } # returns an index, choices is a vector of strings imatch.choices <- function(arg, choices, argname=short.deparse(substitute(arg), "function"), errmsg.has.index=FALSE, # TRUE if integer "arg" is legal elsewhere errmsg="", # error message, "" for automatic errmsg.ext="") # extension to error message { errmsg.ext <- paste0( if(errmsg.has.index) " an integer index or" else "", if(nchar(errmsg.ext)) paste0(" ", errmsg.ext, " or") else "") if(nchar(errmsg) == 0) errmsg <- sprint("Choose%s one of: %s", errmsg.ext, quotify(choices)) if(!is.character(arg) || length(arg) != 1 || !nzchar(arg)) stopf("illegal %s argument\n%s", quotify(argname, "'"), errmsg) if(argname %in% c("NULL", "NA")) argname <- "argument" imatch <- pmatch(arg, choices) if(anyNA(imatch)) { imatch <- NULL for(i in seq_along(choices)) if(pmatch(arg, choices[i], nomatch=0)) imatch <- c(i, imatch) if(length(imatch) == 0) { if(length(choices) == 1) stopf("%s=\"%s\" is not allowed\n Only%s %s is allowed", argname, paste(arg), errmsg.ext, quotify(choices)) else stopf("%s=\"%s\" is not allowed\n%s", argname, paste(arg), errmsg) } if(length(imatch) > 1) stopf("%s=\"%s\" is ambiguous\n%s", argname, paste(arg), errmsg) } imatch } # TRUE if all values in object are integers, ignoring NAs # assumes object is numeric or logical (check this before call this function) is.integral <- function(object) { object <- object[!is.na(object)] length(object) > 0 && is.null(dim(object)) && # prevent error in floor for e.g. survival objects all(floor(object) == object) } # is.specified's main purpose is to see if a plot component should be # drawn, i.e., to see if the component "has a color" is.specified <- function(object) { try <- try(!is.null(object) && !anyNA(object) && !is.zero(object) && # following needed for e.g. col=c("red", 0) because 0 is converted to string !identical(object, "0") && !identical(object, "0L") && !identical(object, "NA"), silent=FALSE) if(is.try.err(try)) { # this occurs if object is say a closure and anyNA fails # anyNA was introduced in R 3.1.0 printf("\n") # separate from any message printed by try() above stop0(deparse(substitute(object)), ": illegal value") } try } is.try.err <- function(object) { class(object)[1] == "try-error" } is.zero <- function(object) # needed because identical(object, 0) fails if object is 0L { identical(object, 0) || identical(object, 0L) } # Lighten color by amount 0 ... 1 where 1 is white. # If amount is negative, then darken the color, -1 is black. lighten <- function(col, lighten.amount, alpha=1) { # stopifnot.scalar(lighten.amount) # stopifnot(lighten.amount >= -1 && lighten.amount <= 1) rgb <- col2rgb(col) / 255 # empirically, sqrt makes visual effect of lighten.amount more linear lighten.amount2 <- sqrt(abs(lighten.amount)) rgb <- if(lighten.amount > 0) rgb + lighten.amount2 * (c(1,1,1) - rgb) # move each r,g,b towards 1 else # darken rgb - lighten.amount2 * rgb # move each r,g,b towards 0 rgb[rgb < 0] <- 0 # clamp rgb[rgb > 1] <- 1 if(alpha == 1) rgb(rgb[1,], rgb[2,], rgb[3,]) else rgb(rgb[1,], rgb[2,], rgb[3,], alpha) } # returns the expanded arg (error msg if arg is not an allowed choice in calling func) match.arg1 <- function(arg, argname=deparse(substitute(arg))) { formal.args <- formals(sys.function(sys.parent())) formal.argnames <- eval(formal.args[[argname]]) formal.argnames[imatch.choices(arg[1], formal.argnames, argname)] } # returns a string, choices is a vector of strings # error msg if arg is not an allowed choice match.choices <- function(arg, choices, argname=deparse(substitute(arg)), errmsg="", # error message ("" for automatic) errmsg.ext="") # extension to error message { choices[imatch.choices(arg, choices, argname, errmsg=errmsg, errmsg.ext=errmsg.ext)] } # This uses the object's .Environment attribute, which was # pre-assigned to the object via get.model.env # If this gives an error saying that class(model.env) is "NULL" # then that pre-assignment wasn't done. model.env <- function(object) { model.env <- attr(object, ".Environment") if(!is.environment(model.env)) stopf("class(model.env) is \"%s\"", class(model.env)[1]) model.env } # Like as.data.frame() but retains the original colnames, if any, and can # handle matrices from the Matrix etc. packages, if as.matrix() works for # them. Also it has a stringsAsFactors argument which works even if x is # already a data.frame. my.data.frame <- function(x, trace, stringsAsFactors=TRUE) { if(is.data.frame(x)) { if(stringsAsFactors) { # Convert any character columns to factors. Note as.data.frame # won't do this for us when x is already a data.frame. # We don't have a levels argument to pass to factor() # but I believe that this will not be a problem in the # context in which we use my.data.frame (plotmo_x). for(i in seq_len(length(x))) if(is.character(x[[i]])) x[[i]] <- factor(x[[i]]) } return(x) } df <- try(as.data.frame(x, stringsAsFactors=stringsAsFactors), silent=TRUE) if(is.try.err(df)) { # come here for sparse matrices from the Matrix package df <- try(as.matrix(x)) if(is.try.err(df)) stopf("Cannot convert %s object to a data.frame or matrix", quotify(class(x)[1])) df <- as.data.frame(df, stringsAsFactors=stringsAsFactors) trace2(trace, "converted %s object to data.frame\n", class(x)[1]) } colnames(df) <- safe.colnames(x) # restore original column names df } # default min.nrow=3 to use fixed point only if more than intercept and one other term my.fixed.point <- function(x, digits, min.nrow=3) { if(is.null(dim(x))) x <- as.matrix(x) if(NROW(x) >= min.nrow) x <- apply(x, 2, zapsmall, digits+1) x } # If s is a string vector s, return the number of lines in # the element that has the most lines # Examples: nlines(c(" ", " \n ") is 2 # nlines(c(" ", " \n") is 2 # nlines(" ") is 1 # nlines("") is 0 (special case) nlines <- function(s) { if(!nzchar(s[1])) # special case, caption="" is not printed 0 else if(anyNA(s)) 0 else length(strsplit(s, "\n")[[1]]) } paste.c <- function(object, maxlen=16) # return 'x1' or 'c(x1, x2)' { if(length(object) == 1) paste.trunc(object) else paste0("c(", paste.trunc(object, collapse=",", maxlen=maxlen), ")") } paste.with.quotes <- function(object, maxlen=16) # return '"x1"' or '"x1", "x2"' { if(is.null(object[1])) "NULL" else if(length(object) == 0) "EMPTY" else paste0(paste.trunc("\"", object, "\"", collapse=", ", sep="", maxlen=maxlen)) } paste.collapse <- function(...) { paste(..., collapse=" ") } # collapse, and truncate if strings in ... are too long paste.trunc <- function(..., sep=" ", collapse=" ", maxlen=60) { s <- paste(..., sep=sep, collapse=collapse) if(nchar(s) > maxlen) { stopifnot(maxlen > 3) s <- paste0(substr(s, 1, maxlen-3), if(substr(s, maxlen-3, maxlen-3) == ".") ".." # avoid 4 dots else "...") } s } pastef <- function(s, fmt, ...) # paste the printf style args to s { paste0(s, sprint(fmt, ...)) } print_first_few_elements_of_vector <- function(x, trace, name=NULL) { try(cat(" min", min(x), "max", max(x)), silent=TRUE) spaces <- " " if(!is.null(name)) spaces <- sprint("%*s", nchar(name), " ") # nchar spaces cat0("\n", spaces, " value") len <- if(trace >= 4) length(x) else min(if(is.logical(x)) 20 else 10, length(x)) if(is.logical(x)) for(i in 1:len) cat0(if(x[i]) " T" else " F") else for(i in 1:len) cat0(" ", x[i]) if(length(x) > len) cat(" ...") cat("\n") if(trace >= 4) { cat("\n") print(summary(x)) } } # A safe version of sprintf. # Like sprintf except that %s on NULL prints "NULL" rather than # preventing the entire string from being printed # # e.g. sprintf("abc %s def", NULL) returns an empty string -- a silent failure! # but sprint("abc %s def", NULL) returns "abc NULL def" # # e.g. sprintf("abc %d def", NULL) returns an empty string! # but sprint("abc %d def", NULL) causes an error msg (not a silent failure) sprint <- function(fmt, ...) { dots <- list(...) dots <- lapply(dots, function(e) if(is.null(e)) "NULL" else e) do.call(sprintf, c(fmt, dots)) } printf <- function(fmt, ...) # like c printf { cat(sprint(fmt, ...), sep="") } # like printf but wrap at terminal width # exdent=NULL for automatic determination of xdent (line up to func opening paren) # TODO maxlen seems to be ignored, strwrap truncates before that? printf.wrap <- function(fmt, ..., exdent=NULL, maxlen=2000) { s <- paste.trunc(paste.collapse(sprint(fmt, ...)), maxlen=maxlen) if(is.null(exdent)) { # align to opening paren of func call e.g. "graphics::par(xxx)" or "foo$method(" # TODO this doesn't account for leading newlines if any exdent <- 4 igrep <- gregexpr("[ ._$:[:alnum:]]+\\(", s)[[1]] if(igrep[1] == 1) { len <- attr(igrep, "match.length")[1] exdent <- min(25, len) } } # strwrap doesn't preserve newlines in the input string, so do it manually :( for(i in seq_len(nchar(s))) # print leading newlines if(substr(s, i, i) == "\n") cat0("\n") else break cat(paste0(strwrap(s, width=getOption("width"), exdent=exdent), collapse="\n")) if(nchar(s) > i) for(j in nchar(s):i) # print trailing newlines if(substr(s, j, j) == "\n") cat0("\n") else break } pt.cex <- function(ncases, npoints=ncases) { n <- if(npoints > 0) min(npoints, ncases) else ncases if (n >= 20000) .2 else if(n >= 5000) .3 else if(n >= 3000) .4 else if(n >= 1000) .6 else if(n >= 300) .8 else if(n >= 30) 1 else 1.2 } # like short.deparse but quotify the deparsed obj (unless the alternative is used) quote.deparse <- function(object, alternative="object") { s <- strip.deparse(object) if(nchar(s) > 60) alternative else quotify(s, quote="'") } quote.with.c <- function(names) # return "x" or c("x1", "x2") { if(length(names) == 1) sprint("\"%s\"", names) else sprint("c(%s)", paste0("\"", paste(names, collapse="\", \""), "\"")) } quotify <- function(s, quote="\"") # add quotes and collapse to a single string { # called quotify because quote is taken if(is.null(s)) "NULL" else if(length(s) == 0) paste0(quote, quote) else if(substr(s[1], 1, 1) == "'" || substr(s[1], 1, 1) == "\"") paste.collapse(s) # already has quotes else paste0(quote, paste(s, collapse=paste0(quote, " ", quote)), quote) } # like quotify, but use the alternative name if s is too long quotify.short <- function(s, alternative="object", quote="\"") { stopifnot(is.character(s)) s <- paste0(s, collapse="") if(nchar(s) > 60) # 60 is arb but seems ok for plot titles etc alternative else quotify(s, quote) } quotify.trunc <- function(s, quote="\"", maxlen=60) { stopifnot(is.character(s)) s <- quotify(s, quote) if(nchar(s) > maxlen) { stopifnot(maxlen > 3) paste0(substr(s, 1, maxlen-3), "...") } else s } range1 <- function(object, ...) { stopifnot(length(dim(object)) <= 2) if(!is.null(dim(object))) object <- object[,1] if(is.factor(object)) c(1, nlevels(object)) else if(inherits(object, "Date")) # Sep 2020, R 4.0.2: range no longer works with Date objects c(min(object), max(object)) else range(object, finite=TRUE, ...) } recycle <- function(object, ref.object) { repl(object, length.out=length(ref.object)) } repl <- function(object, length.out) { # following "if" added for R-2.15.3 otherwise # get warning: 'x' is NULL so the result will be NULL if(is.null(object)) return(NULL) check.numeric.scalar(length.out) stopifnot(floor(length.out) == length.out) stopifnot(length.out > 0) rep(object, length.out=length.out) } # the standard colnames() can crash for certain objects # TODO figure out when and why safe.colnames <- function(object) { colnames <- try(colnames(object), silent=TRUE) if(is.try.err(colnames)) NULL else colnames } # if deparse(object) is too long, return the alternative short.deparse <- function(object, alternative="object") { s <- strip.deparse(object) if(nchar(s) > 60) alternative else s } # Remove duplicates in x, then sort (smallest first). # Also works for Dates. sort_unique <- function(x) { sort(unique(x), na.last=NA) # na.last=NA drops NAs } sos <- function(x, weights=NULL) # sum of squares { if(is.null(weights)) sum(as.vector(x^2)) else { stopifnot(length(weights) == length(x)) sum(weights * as.vector(x^2)) } } stop0 <- function(...) { stop(..., call.=FALSE) } stopf <- function(fmt, ...) # args like printf { stop(sprint(fmt, ...), call.=FALSE) } # stop if s is not a one element character vector stopifnot.string <- function(s, name=short.deparse(substitute(s)), null.ok=FALSE, allow.empty=FALSE) { if(name %in% c("NULL", "NA")) name <- "argument" if(is.null(s)) { if(null.ok) return() else stop0(quotify(name, "'"), " is NULL (it should be a string)") } if(!is.character(s)) stop0(quotify(name, "'"), " is not a character variable (class(", name, ") is \"", class(s), "\")") if(length(s) == 0) stop0(quotify(name, "'"), " is empty (it has no elements)") if(length(s) != 1) stop0(quotify(name, "'"), " has more than one element\n ", name, " = c(", paste.trunc("\"", s, "\"", sep=""), ")") if(!allow.empty && !nzchar(s)) stop0(quotify(name, "'"), " is an empty string") } strip.deparse <- function(object) # deparse, collapse, remove most white space { s <- strip.space.collapse(deparse(object)) gsub(",", ", ", s) # put back space after commas } strip.space <- function(s) { gsub("[ \t\n]", "", s) } strip.space.collapse <- function(s) # returns a single string { gsub("[ \t\n]", "", paste(s, collapse="")) # paste converts vec to single } # like text, but with a white background # TODO sign of adj is backwards? text.on.white <- function(x, y, label, cex=1, adj=.5, font=1, xmar=.3, srt=0, white="white", ...) { stopifnot(length(label) == 1) if(length(adj) == 1) adj <- c(adj, .5) width <- strwidth(label, cex=cex, font=font) char.width <- strwidth("X", cex=cex, font=font) height <- strheight(label, cex=cex, font=font) char.height <- strheight("X", cex=cex, font=font) if(srt == 0) { if(is.specified(label)) rect(x - adj[1] * width - xmar * char.width, y - adj[2] * height - .3 * char.height, # .3 for extra space at bottom x + (1-adj[1]) * width + xmar * char.width, y + (1-adj[2]) * height + .1 * char.height, col=white, border=NA) text(x=x, y=y, labels=label, cex=cex, adj=adj, font=font, ...) } else if(srt == 90 || srt == -90) { # width and height are in usr coords, adjust these for flip of coords usr <- par("usr") # xmin, xmax, ymin, ymax xrange <- abs(usr[2] - usr[1]) yrange <- abs(usr[4] - usr[3]) height <- xrange / yrange * height width <- yrange / xrange * width char.height <- xrange / yrange * char.height char.width <- yrange / xrange * char.width if(is.specified(label)) rect(x + (1-adj[1]) * height, # left y + (1-adj[2]) * width + xmar * char.width, # bottom x - adj[1] * height, # right y - adj[2] * width - xmar * char.width, # top col=white, border=NA) text(x=x, y=y, labels=label, cex=cex, adj=adj, font=font, srt=srt, ...) } else stop0("srt=", srt, " is not allowed (only 0, 90, and -90 are supported)") } to.logical <- function(object, len) # object can be a boolean or numeric vector { xlogical <- repl(FALSE, len) xlogical[object] <- TRUE xlogical } trace0 <- function(trace, fmt, ...) { stopifnot(!(is.numeric(trace) && is.logical(trace))) if(trace >= 0) cat(sprint(fmt, ...), sep="") } trace1 <- function(trace, fmt, ...) { stopifnot(!(is.numeric(trace) && is.logical(trace))) if(trace >= 1) cat(sprint(fmt, ...), sep="") } trace2 <- function(trace, fmt, ...) { stopifnot(is.numeric(trace)) if(trace >= 2) cat(sprint(fmt, ...), sep="") } # Truncate deparse(object) if it is too long. # Necessary because deparse(substitute(x)) might return something very # long, like c(1000, 1001, 1002, 1003, 1004, 1005, 1006, 1008, 1009, etc.) # Return a one element character vector. trunc.deparse <- function(object, maxlen=60) { s <- strip.deparse(object) if(nchar(s) > maxlen) { stopifnot(maxlen > 3) paste0(substr(s, 1, maxlen-3), "...") } else s } # Return the number of lines in s (where lines are separated by \n). try.eval <- function( expr, envir = parent.frame(), trace = 0, expr.name = NULL, silent = trace < 2) { if(trace && is.null(expr.name)) expr.name <- trunc.deparse(substitute(expr)) try(eval.trace(expr, envir, trace=trace, expr.name=expr.name), silent=silent) } unquote <- function(s) # remove leading and trailing quotes, if any { if(is.character(s)) { s <- gsub("^\"|^'", "", s) # leading quotes s <- gsub("\"$|'$", "", s) # trailing quotes } s } # warn.if.not.all.finite helps preempt confusing message from code later. # Return TRUE if warning issued. warn.if.not.all.finite <- function(object, text="unknown") { is.factors <- sapply(object, is.factor) if(any(is.factors)) { if(NCOL(object) == 1 || all(is.factors)) # TODO suspect return(FALSE) object <- object[, !is.factors] # remove factor columns before is.finite check } if(any(sapply(object, is.na))) { warning0("NA in ", text) return(TRUE) } if(!all(sapply(object, is.finite))) { warning0("non finite value in ", text) return(TRUE) } FALSE } warnf <- function(fmt, ...) # args like printf { warning(sprint(fmt, ...), call.=FALSE) } warning0 <- function(...) { warning(..., call.=FALSE) } # Binomial pairs response: fraction true for each row. # # This function is used by both earth and plotmo. # If you change it here, change it there too. # # The first column of y is considered to be "true", the second "false". # # Example y: # survived died # 1 1 # 0 0 # both values zero # 3 4 # # becomes: # survived # .5 # 1 / (1 + 1) # 0 # special case (both survived and died equal to 0) # .43 # 3 / (3 + 4) bpairs.yfrac <- function(y, trace) { stopifnot(NCOL(y) == 2) both.zero <- (y[,1] == 0) & (y[,2] == 0) y[both.zero, 2] <- 1 # so zero rows will be translated to 0 in next line yfrac <- y[, 1, drop=FALSE] / (y[,1] + y[,2]) # fraction true trace.bpairs.yfrac(yfrac, trace) yfrac } trace.bpairs.yfrac <- function(yfrac, trace) { # based on code in print.earth.fit.args if(trace >= 4) cat("\n") if(trace >= 1 && trace < 7) { # don't print matrices when doing very detailed earth.c tracing tracex <- if(trace >= 5) 4 else 2 # adjust trace for print_summary details <- if(trace >= 4) 2 else if(trace >= 1) -1 else 0 print_summary(yfrac, "yfrac", tracex, details=details) if(details > 1) printf("\n") } } plotmo/R/glmnet.R0000644000176200001440000001651114663771205013415 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/dotlib.R0000644000176200001440000000664214663771205013410 0ustar liggesusers# dotlib.R: miscellaneous functions for the dots routines # Arguments for par() which take a vector value (i.e. length of value is not one). PAR.VEC <- c("fig", "fin", "lab", "mai", "mar", "mfcol", "mfg", "mfrow", "mgp", "oma", "omd", "omi", "pin", "plt", "usr", "xaxp", "yaxp") # Add the elements of the extra list to the original list. Elements of the # original list that have the same names as extra elements get overwritten. # # Like utils::modifyList(keep.null=TRUE) except: # (i) input args can be NULL (NULL is treated as an empty list) # (ii) unnamed elements in extra are added to original (modifyList drops them) merge.list <- function(original, extra) { if(is.null(original)) original <- list() if(is.null(extra)) return(original) stopifnot(is.list(original)) stopifnot(is.list(extra)) # pairlist would probably be ok too for(i in seq_along(extra)) { e <- extra[[i]] name <- names(extra)[i] if(is.null(name) || !nzchar(name)) # extra element is unnamed? original <- c(original, if(is.null(e)) list(NULL) else e) else if(is.null(e)) original[name] <- list(NULL) # avoid "assign deletes elem if rhs is null" else original[[name]] <- e } original } # Evaluate each element of the list dots in the environment specified by n. # (This function can actually be used any list, but the evaluating # environment and enclosure are set up for dot arg lists.) # # TODO "scalar" is ugly, it is for par() alone and prevents # e.g. error: graphical parameter "lty" has the wrong length eval.dotlist <- function(dots, n=1, scalar=FALSE) { stopifnot(is.list(dots) || is.pairlist(dots)) env <- parent.frame(n) dotnames <- names(dots) for(i in seq_along(dots)) { e <- try(eval(dots[[i]], envir=env, enclos=env), silent=TRUE) if(!is.try.err(e)) { if(is.null(e)) dots[i] <- list(NULL) # avoid "assign deletes elem if rhs is null" else if(!scalar || (dotnames[i] %in% PAR.VEC) || length(e) == 1) dots[[i]] <- e else dots[[i]] <- e[[1]] # select first element of e only # TODO it would be better to drop the element entirely } } dots } # Is the string s a valid R lexigraphic identifier? # If allow.specials=TRUE we allow special chars used in DROP and KEEP strings. # The name argument is used only in error messages. stopifnot.identifier <- function(s, name=short.deparse(substitute(s)), allow.empty=FALSE, allow.specials=FALSE) { if(!is.character(s)) stop0(name, " is not a character variable (class(", name, ") is \"", class(s)[1], "\")") if(length(s) != 1) stop0(name, " has more than one element\n ", name, " = c(", paste.trunc("\"", s, "\"", sep=""), ")") if(!allow.empty && !nzchar(s)) stop0(name, " is an empty string") # TODO the following allows integers (no alphabetic characters), it shouldn't start <- if(allow.specials) # include , * $ regexpr("[^._:[:alnum:],*$]", s) else regexpr("[^._:[:alnum:]]", s) if(start > 0) stop0("illegal character \"", substr(s, start, start), "\" in ", name, " = \"", s, "\"") } plotmo/R/type.R0000644000176200001440000000666614663771205013122 0ustar liggesusers# type.R: plotmo functions for getting the default type arg for predict() and residuals() # this is used when plotmo's argument "type" is NULL (the default) # get the default type for predict() plotmo.type <- function(object, ..., TRACE) { UseMethod("plotmo.type") } plotmo.type.default <- function(object, ..., TRACE) { "response" } plotmo.type.nnet <- function(object, ..., TRACE) { "raw" } plotmo.type.knn3 <- function(object, ..., TRACE) { "prob" } plotmo.type.tree <- function(object, ..., TRACE) # tree package { "vector" } plotmo.type.fda <- function(object, ..., TRACE) # mda package { "class" } # get the type for residuals() plotmo.residtype <- function(object, ..., TRACE) { UseMethod("plotmo.residtype") } plotmo.residtype.default <- function(object, ..., TRACE) { plotmo.type(object, ..., TRACE=TRACE) # use the predict type } # TRUE if we are predicting probabilities. # This is used for setting the default ylim to c(0,1). # Not always reliable (but if wrong, the user can override with explicit ylim arg). # It can save a call get.ylim.by.dummy.plots, and also works for objects # for which get.ylim.by.dummy.plots doesn't automatically figure out c(0,1) is.yaxis.a.probability.aux <- function(object, type, trace) { if(inherits(object, "WrappedModel")) { # mlr package # will be we be predicting probabilities? # TODO this will be wrong if use say nresponse="response" in call to plotmo call <- object[["call"]] if(!is.null(call)) { # TODO assumes environment for learner is available and correct learner <- eval(call[["learner"]]) if(!is.null(learner)) { predict.type <- mlr::getLearnerPredictType(learner) if(substr(predict.type[1], 1, 1) == "p") # prob return(TRUE) } } # continue processing, but use the learner.model object <- object$learner.model } type.firstchar <- substr(type[1], 1, 1) # type argument to predict() substr(type[1], 1, 4) == "prob" || # catchall (inherits(object, "rpart") && object$method[1] == "class" && type.firstchar == "p") || # following not strictly necessary for earth models because # get.ylim.by.dummy.plots can also figure this out # The "r" below is for "response" (inherits(object, "earth") && is.nomial(object$glm.list[[1]]) && type.firstchar == "r") || # the "r" below is for "response" (inherits(object, c("glm", "glmnet", "pre")) && is.nomial(object) && type.firstchar == "r") || (inherits(object, "cv.glmnet") && !is.null(object$glmnet.fit$classnames)) || (inherits(object, "randomForest") && is.character(object$type) && object$type[1] == "classification" && type.firstchar == "p") || (inherits(object, "C5.0") && type.firstchar == "p") } is.yaxis.a.probability <- function(object, type, trace) { # This wrapper exists because we don't want plotmo to completely stop # (issue an error) if a package changes the model fields. (This function is # vulnerable to changes because it accessess internal fields in multiple # different models.) is.prob <- try(is.yaxis.a.probability.aux(object, type, trace), silent=trace < 2) if(is.try.err(is.prob)) FALSE else is.prob } plotmo/R/pint.R0000644000176200001440000001241514663771205013100 0ustar liggesusers# pint.R: plotmo functions for confidence and prediction intervals # Handle plotmo's "level" argument. Return a prediction interval dataframe # with either or both of the following sets of columns. What columns get # returned depends on the capabilities of the object's predict method. # For example, predict.lm allows us to return both i and ii, and for # earth models we can return only i. # # (i) lwr, upr intervals for prediction of new data # # (ii) cint.lwr, cint.upr intervals for prediction of mean response plotmo_pint <- function(object, newdata, type, level, trace, ipred, inverse.func) { if(!is.specified(level)) return(NULL) trace2(trace, "plotmo_pint for %s object\n", class.as.char(object)) stopifnot.string(type) # call plotmo.pint.xxx where xxx is object's class intervals <- plotmo.pint(object, newdata, type, level, trace) if(!is.null(intervals$lwr)) { intervals$lwr <- apply.inverse.func(inverse.func, intervals$lwr, object, trace) intervals$upr <- apply.inverse.func(inverse.func, intervals$upr, object, trace) } if(!is.null(intervals$cint.lwr)) { intervals$cint.lwr <- apply.inverse.func(inverse.func, intervals$cint.lwr, object, trace) intervals$cint.upr <- apply.inverse.func(inverse.func, intervals$cint.upr, object, trace) } print_summary(intervals, "prediction intervals", trace) intervals } # Return a data.frame with either or both of the following variables: # (i) lwr, upr intervals for prediction of new data # (ii) cint.lwr, cint.upr intervals for prediction of mean response plotmo.pint <- function(object, newdata, type, level, trace, ...) { UseMethod("plotmo.pint") } plotmo.pint.default <- function(object, ...) { stop0("the level argument is not supported for ", class.as.char(object, quotify=TRUE), " objects") } plotmo.pint.lm <- function(object, newdata, type, level, ...) { # lm objects with weights do not support confidence intervals on new data if(!is.null(object$weights)) stop0("the level argument is not supported on lm objects with weights") pints <- predict(object, newdata, interval="prediction", level=level) cints <- predict(object, newdata, interval="confidence", level=level) data.frame( lwr = pints[,"lwr"], # intervals for prediction of new data upr = pints[,"upr"], cint.lwr = cints[,"lwr"], # intervals for prediction of mean response cint.upr = cints[,"upr"]) } plotmo.pint.glm <- function(object, newdata, type, level, ...) { if(!is.null(object$weights) && !all(object$weights == object$weights[1])) warnf( "the level argument may not work correctly on glm objects built with weights") quant <- 1 - (1 - level) / 2 # .95 becomes .975 predict <- predict(object, newdata, type=type, se.fit=TRUE) data.frame(cint.lwr = predict$fit - quant * predict$se.fit, cint.upr = predict$fit + quant * predict$se.fit) } # package mgcv, or package gam version less than 1.15 plotmo.pint.gam <- function(object, newdata, type, level, ...) { if(!is.null(object$weights) && !all(object$weights == object$weights[1])) warnf( "the level argument may not work correctly on gam objects built with weights") quant <- 1 - (1 - level) / 2 # .95 becomes .975 predict <- predict(object, newdata, type=type, se.fit=TRUE) # special handling for where user used gam::gam instead of mgcv::gam # (applies only package gam version less than 1.15) if(class(predict)[1] == "numeric" && "package:gam" %in% search()) { cat("\n") stop0("gam objects in the 'gam' package do not support ", "confidence intervals on new data") } data.frame(cint.lwr = predict$fit - quant * predict$se.fit, cint.upr = predict$fit + quant * predict$se.fit) } # package gam version 1.15 or higher plotmo.pint.Gam <- function(object, newdata, type, level, ...) { if(!is.null(object$weights) && !all(object$weights == object$weights[1])) warnf( "the level argument may not work correctly on Gam objects built with weights") quant <- 1 - (1 - level) / 2 # .95 becomes .975 predict <- predict(object, newdata, type=type, se.fit=TRUE) if(class(predict)[1] == "numeric") { cat("\n") stop0("Gam objects do not support confidence intervals on new data") } data.frame(cint.lwr = predict$fit - quant * predict$se.fit, cint.upr = predict$fit + quant * predict$se.fit) } plotmo.pint.quantregForest <- function(object, newdata, type, level, ...) { q0 <- (1 - level) / 2 # .95 becomes .025 q1 <- 1 - q0 # .975 predict <- predict(object, newdata, quantiles=c(q0, q1)) data.frame(lwr = predict[,1], upr = predict[,2]) } plotmo.pint.earth <- function(object, newdata, type, level, ...) { pints <- predict(object, newdata=newdata, type=type, interval="pint", level=level) if(is.null(newdata)) { cints <- predict(object, newdata=NULL, type=type, interval="cint", level=level) pints$cint.upr <- cints$upr pints$cint.lwr <- cints$lwr } pints } plotmo/R/naken.R0000644000176200001440000001326514663771205013226 0ustar liggesusers# naken.R: # Like naken.collapse but don't collapse a vector of strings into a single string. # # e.g. c("num","sqrt(num)","ord","offset(off)") # becomes c("num","num" "ord", "off") naken <- function(s) { naked <- character(length(s)) for(i in seq_along(s)) naked[i] <- naken.collapse(s[i]) naked } # Collapse s to s single string and then "naken" it # (i.e. return only the variables in the string, separated by "+"). # # e.g. "x1" becomes "x1" # "sqrt(x1)" becomes "x1" # "s(x1,x4,df=4)" becomes "x1+x4" # "sqrt(x1) as.numeric(x4)" becomes "x1" # c("sqrt(x1)", "as.numeric(x4)") becomes "x1" # `x 3` becomes "`x 3`" (variables in backquotes unchanged) naken.collapse <- function(s, warn.if.minus=FALSE) { s <- paste.collapse(s) s.org <- s untouchable <- get.untouchable.for.naken(s) s <- strip.space(untouchable$s) # strip space from everything except untouchables # for "ident" gsubs below if(grepl("--", s, fixed=TRUE)) # '--'causes problems because '-' gets turned to '+' below warning0("Consecutive '-' in formula may cause problems\n Formula:", s.org) # # check for "- ident" in formula (but -1 is ok) # # # commented out because this is invisible to the user, because # # plotmo does not plot the -ident variable # # if(warn.if.minus && grepl("\\- *[._[:alpha:]]", s)[1]) # warnf("plotmo will include the variable prefixed by \"-\" in the formula\n Formula: %s", s) # TODO we can't ignore "-" below because of the paste0(collapse=" + ") later below s <- gsub("[-*/:]", "+", s) # replace - / * : with + # next two gsubs allow us to retain "x=x1" but drop "df=99" from "bs(x=x1, df=99)" s <- gsub("\\(._$[[:alnum:]]+=", "(", s) # replace "(ident=" with "(" s <- gsub("[._$[:alnum:]]+=[^,)]+", "", s) # delete "ident=any" # replace ",ident" with ")+f(ident", thus "s(x0,x1)" becomes "s(x0)f(x1)" s <- gsub(",([._$[:alpha:]])", ")+f(\\1", s) regex <- "[._$[:alnum:]]*\\(" if(grepl(regex, s)) { s <- gsub(regex, "", s) # replace ident( s <- gsub("[,)][^+-]*", "", s) # remove remaining ",arg1,arg2)" } # s is now something like x1+x2, split it on "+" for further processing s <- strsplit(s, "+", fixed=TRUE)[[1]] s <- unique(s) # remove duplicates # remove numbers e.g. sin(x1*x2/12) is nakened to x1+x1+12, we don't want the 12 is.num <- sapply(s, function(x) grepl("^([0-9]|\\.[0-9])", x)) # but keep the intercept if there is one which1 <- which(s == "1") is.num[which1] <- FALSE s <- paste0(s[!is.num], collapse=" + ") replace.untouchable.for.naken(s, untouchable$replacements) } # In the function naken.collapse(), terms such as [string] and `string` # must remain the same (regardless of the enclosed string). # That is, strings in brackets or backquotes must remain untouched. # # This function searches for such terms, replaces them with dummies, and # remembers where they were in the original string (for re-replacement later). # # For example, if s = "x1 + x[,2] + `x 3`" we return: # # out: "x1 + x!00000! + !00001!" # note the dummies !00000! and !00001! # # replacements: # replacement original # "[00000]" "[,2]" # "[00001]" "`x 3`" get.untouchable.for.naken <- function(s) # utility for naken { # for efficiency, check for most common case (no [ or ` in s) if(!grepl("[\\[\`]", s)[1]) return(list(s=s, replacements=NULL)) # no [ or ` in s stopifnot(length(s) == 1) # out and untouchables will be the returned string and table of untouchables # for simplicity, create untouchables as a vec and convert to a mat at the end out <- "" untouchables <- NULL cs <- strsplit(s, split="")[[1]] # split into individual chars for loop efficiency len <- length(cs) i <- 1 while(i <= len) { c <- cs[i] # i==len below is for malformed strings with extra [ or ` on end if((c != "[" && c != "\`") || i == len) # normal character out <- paste0(out, c) else { # char is [ or `, skip to matching ] or ` istart <- i nestdepth <- 0 endchar <- if(c == "[") "]" else "\`" for(i in (istart+1):len) { if(c == "[" && cs[i] == "[") nestdepth <- nestdepth + 1 # nested brackets if(cs[i] == endchar) { if(nestdepth <= 0) break else nestdepth <- nestdepth - 1 } } replacement <- sprint("!%05.5g!", length(untouchables) / 2) out <- paste0(out, replacement) untouchables <- c(untouchables, replacement, substr(s, istart, i)) } i <- i + 1 } if(length(untouchables)== 0) # malformed s="[" or s="`" return(list(s=s, replacements=NULL)) replacements <- matrix(untouchables, byrow=TRUE, ncol=2, nrow=length(untouchables) / 2) colnames(replacements) <- c("replacement", "original") list(s=out, replacements=replacements) } # undo the effect of get.untouchable.for.naken replace.untouchable.for.naken <- function(s, replacements) { for(i in seq_len(NROW(replacements))) s <- gsub(replacements[i, 1], replacements[i, 2], s, fixed=TRUE) s } plotmo/R/gbm.backcompat.R0000644000176200001440000001151514664445173015001 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/gbm.R0000644000176200001440000001144114664447040012667 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, ...) { importance <- attr(object, "plotmo.importance") stopifnot(!is.null(importance)) # uninitialized? if(all1) nsingles = length(importance) else # indices of vars with importance >= 1%, max of 10 variables # (10 becauses plotmo.pairs returns 6, total is 16, therefore 4x4 grid) nsingles = min(10, length(importance)) if(nsingles == 0) return(NULL) importance[1: nsingles] } 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 (including singles) # npairs=5 gives 10 pairplots, npairs=4 gives 6 pairplots npairs <- if(length(importance) <= 6) 5 else 4 if(npairs == 0) return(NULL) 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/prolog.R0000644000176200001440000000136314663771205013430 0ustar liggesusers# prolog.R: plotmo.prolog functions, called at the start of plotmo and plotres # gets called at the start of plotmo and plotres plotmo.prolog <- function(object, object.name, trace, ...) { trace2(trace, "--plotmo_prolog for %s object %s\n", class.as.char(object), object.name) UseMethod("plotmo.prolog") } plotmo.prolog.default <- function(object, object.name, ...) { # prevent confusing downstream errors by doing an initial check here if(is.null(getCall(object)) && is.null(object[["x"]])) stopf("%s does not have a 'call' field or %s", object.name, if(is.null(object[["y"]])) "'x' and 'y' fields" else "an 'x' field") object } plotmo/R/pre.R0000644000176200001440000000576614663771205012727 0ustar liggesusers# pre.R: plotmo functions for "pre" package plotmo.prolog.pre <- function(object, object.name, trace, ...) # invoked when plotmo starts { # importance is a vector of variable indices, most important vars first importance <- order.pre.vars.on.importance(object, trace) attr(object, "plotmo.importance") <- importance object } order.pre.vars.on.importance <- function(object, trace) { varimps <- try(pre::importance(object, plot=FALSE)$varimps, silent=TRUE) if(is.try.err(varimps)) { cat("\n") warning0("pre::importance(pre.object) failed\n", "(Will plot all variables regardless of importance. Use all2=TRUE to get degree2 plots.)\n") # NULL be will be treated as all vars by plotmo.single.pre, # and as no vars by plotmo.pairs.pre. return(NULL) } stopifnot(is.data.frame(varimps)) if(NROW(varimps) == 0) { # based on code in importance function in pre.R warning0("importance(pre.object)$varimps is empty") return(NULL) } stopifnot(!is.null(varimps$varname)) # following is needed for multiple response models # we get the combined importance across all responses if(is.null(varimps$imp)) varimps$imp <- rowSums(varimps[,-1]) stopifnot(!is.null(varimps$imp)) # discard variables whose importance is less than 1% of max importance varname <- varimps[varimps$imp > .01 * varimps$imp[1], ]$varname # convert variable names to column indices allvarnames <- object$x_names stopifnot(!is.null(allvarnames) && length(allvarnames) > 0) # paranoia importance <- match(varname, allvarnames) if(any(is.na(importance) | (importance == 0))) { # sanity check warning0("could not get variable importances\n varname=", paste.c(varname, maxlen=30)) return(NULL) } if(trace > 0) cat0("importance: ", paste.trunc(allvarnames[importance], maxlen=120), "\n") importance # return a vector of var indices, most important vars first } plotmo.singles.pre <- function(object, x, nresponse, trace, all1, ...) { importance <- attr(object, "plotmo.importance") if(all1 || is.null(importance)) return(seq_len(NCOL(x))) # all variables # 10 most important variables # (10 becauses plotmo.pairs returns 6, total is 16, therefore 4x4 grid) importance[seq_len(min(10, length(importance)))] } plotmo.pairs.pre <- function(object, x, ...) { importance <- attr(object, "plotmo.importance") if(is.null(importance)) return(NULL) # importances not available so don't plot any pairs # choose npairs so a total of no more than 16 plots # npairs=5 gives 10 pairplots, npairs=4 gives 6 pairplots npairs <- if(length(importance) <= 6) 5 else 4 form.pairs(importance[1: min(npairs, length(importance))]) } plotmo.pairs.gpe <- function(object, x, nresponse=1, trace=0, all2=FALSE, ...) { return(NULL) # not yet supported because importance(gpe) not supported } plotmo/R/grid.func.R0000644000176200001440000002070414663771205014005 0ustar liggesusers# grid.func: apply grid.levels or grid.func to x (a column from the input x mat) # to get a scalar value for the given background variable get.fixed.gridval <- function(x, pred.name, grid.func, grid.levels) { gridval.method <- "grid.levels" # used only in warning messages gridval <- get.fixed.gridval.from.grid.levels.arg(x, pred.name, grid.levels) if(is.na(gridval)) { # pred.name is not in grid.levels? gridval.method <- "grid.func" if(is.null(grid.func)) { grid.func <- default.grid.func gridval.method <- "default.grid.func" } check.grid.func(grid.func) if(length(x) == 0) # paranoia stop0("length(", pred.name, ") is zero") x <- x[!is.na(x)] if(length(x) == 0) # paranoia stop0("all values of ", pred.name, " are NA") gridval <- try(grid.func(x, na.rm=TRUE), silent=TRUE) } check.fixed.gridval(gridval, gridval.method, x, pred.name) # returns gridval } default.grid.func <- function(x, ...) { if(inherits(x, "integer")) # return median rounded to integer return(as.integer(round(median(x)))) if(inherits(x, "logical")) # return most common value return(median(x) > .5) if(inherits(x, "factor")) { # return most common value lev.names <- levels(x) ilev <- which.max(table(x)) if(is.ordered(x)) return(ordered(lev.names, levels=lev.names)[ilev]) return(factor(lev.names, levels=lev.names)[ilev]) } median(x) # default to median } # Check grid.levels arg passed in by the user. This checks that the names # of the list elements are indeed predictor names. The actual levels will # be checked later in get.fixed.gridval.from.grid.levels.arg. check.grid.levels.arg <- function(x, grid.levels, pred.names) { if(!is.null(grid.levels)) { # null is the default value if(!is.list(grid.levels)) stop0("grid.levels must be a list. ", "Example: grid.levels=list(sex=\"male\")") for(name in names(grid.levels)) { if(nchar(name) == 0) stop0( "All elements of grid.levels must be named\n You have grid.levels=", as.char(grid.levels)) if(!pmatch(name, pred.names, 0)) stop0("illegal variable name '", name, "' in grid.levels") } } } # this returns NA if pred.name is not in grid.levels get.fixed.gridval.from.grid.levels.arg <-function(x, pred.name, grid.levels) { if(is.null(grid.levels)) return(NA) gridval <- NA names.grid.levels <- names(grid.levels) # look for pred.name in the grid.levels list, if found use its value iname <- which(pmatch(names.grid.levels, pred.name, duplicates.ok=TRUE) == 1) if(length(iname) == 0) # no match? return(NA) if(length(iname) > 1) # more than one match? stop0("illegal grid.levels argument (\"", names.grid.levels[iname[1]], "\" and \"", names.grid.levels[iname[2]], "\" both match \"", pred.name, "\")") # a name in grid.levels matches pred.name stopifnot(length(iname) == 1) gridval <- grid.levels[[iname]] if(length(gridval) > 1) stop0("length(", pred.name, ") in grid.levels is not 1") if(is.na(gridval)) stop0(pred.name, " in grid.levels is NA") if(is.numeric(gridval) && !all(is.finite(gridval))) stop0(pred.name, " in grid.levels is infinite") if(is.factor(x)) { lev.name <- grid.levels[[iname]] if(!is.character(lev.name) || length(lev.name) != 1 || !nzchar(lev.name)) stop0("illegal level for \"", pred.name, "\" in grid.levels ", "(specify factor levels with a string)") lev.names <- levels(x) ilev <- pmatch(lev.name, lev.names, 0) if(ilev == 0) stop0("illegal level \"", lev.name, "\" for \"", pred.name, "\" in grid.levels (allowed levels are ", quotify(lev.names), ")") gridval <- if(is.ordered(x)) ordered(lev.names, levels=lev.names)[ilev] else factor(lev.names, levels=lev.names)[ilev] } # do type conversions for some common types # (e.g. allow 3 instead of 3L for integer variables) class.gridval <- class(gridval)[1] class.x <- class(x)[1] if(class.gridval != class.x) { if(class.gridval == "numeric" && class.x == "integer") gridval <- as.integer(round(gridval)) else if(class.gridval == "integer" && class.x == "numeric") gridval <- as.numeric(gridval) else if(class.x == "logical") { if(!is.logical(gridval) && !is.numeric(gridval)) stop0("expected a logical value in grid.levels for ", pred.name) gridval <- gridval > .5 } } return(gridval) } check.grid.func <- function(grid.func) { if(!is.function(grid.func)) stop0("'grid.func' is not a function"); formals <- names(formals(grid.func)) # check grid.func signature, we allow argname "na.rm" for mean and median if(length(formals) < 2 || formals[1] != "x" || (!any(formals == "na.rm") && formals[2] != "...")) stop0("The formal arguments of 'grid.func' should be 'x' and '...'\n", " Your 'grid.func' has ", if(length(formals) == 0) "no formal arguments" else if(length(formals) == 1) "a single formal argument " else "formal arguments ", if(length(formals) > 0) paste0("'", formals, "'", collapse=" ") else "") } check.fixed.gridval <- function(gridval, gridval.method, x, pred.name) { if(is.try.err(gridval)) { if(inherits(x, "logical") || inherits(x, "factor")) warning0(gridval.method, " failed for ", pred.name, ", so will use the most common value of ", pred.name) else warning0(gridval.method, " failed for ", pred.name, ", so will use the default grid.func for ", pred.name) gridval <- default.grid.func(x) } if(length(gridval) != 1) { warning0(gridval.method, " returned multiple values for ", pred.name, ", so will use the default grid.func for ", pred.name) gridval <- default.grid.func(x) # revert to default.grid.func } if(is.na(gridval)) { warning0(gridval.method, " returned NA for ", pred.name, ", so will use the default grid.func for ", pred.name) gridval <- default.grid.func(x) # revert to default.grid.func } # possibly type convert gridval class.gridval <- class(gridval)[1] if(class.gridval != class(x)[1]) { if(inherits(x, "integer")) # silently fix so e.g. grid.func=mean works gridval <- as.integer(round(median(gridval))) else if(inherits(x, "logical")) { # silently fix if possible if(!is.logical(gridval) && !is.numeric(gridval)) stop0("expected a logical value in grid.levels for ", pred.name) gridval <- gridval > .5 } else if(inherits(x, "factor")) { warning0(gridval.method, " returned class \"", class.gridval, "\" for ", pred.name, ", so will use the most common value of ", pred.name) gridval <- default.grid.func(x) } else { warning0(gridval.method, " returned class \"", class.gridval, "\" for ", pred.name, ", so will use the default grid.func for ", pred.name) gridval <- default.grid.func(x) } } gridval } # this retunrs NA if pred.name is not in grid.levels get.fixed.gridval.for.partdep <- function(x, ipred, pred.name, grid.levels) { gridval <- get.fixed.gridval.from.grid.levels.arg(x, pred.name, grid.levels) # common type conversions were already done in get.fixed.gridval.from.grid.levels.arg # check here if that wasn't possible if(!is.na(gridval)[1] && class(gridval)[1] != class(x)[1]) stop0("the class \"", class(gridval)[1], "\" of \"", pred.name, "\" in grid.levels does not match its class \"", class(x)[1], "\" in the input data") gridval } plotmo/R/fitted.R0000644000176200001440000000407614663771205013411 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_gbm.R0000644000176200001440000003404514663771205013734 0ustar liggesusers# plot_gbm.R: plot gbm models # # This code is derived from code in gbm 2.1.1 (Aug 2016). # # TODO when selecting best n.trees, why is OOB smoothed but not test or CV? # TODO maybe add arg to rescale errs e.g. RSquared rather than Squared Error # TODO add right hand axis for OOB, or scale OOB to same units when possible? # TODO if gbm calculated CV stddev across folds then we could plot CV conf bands plot_gbm <- function(object=stop("no 'object' argument"), smooth = c(0, 0, 0, 1), col = c(1, 2, 3, 4), ylim = "auto", legend.x = NULL, legend.y = NULL, legend.cex = .8, grid.col = NA, n.trees = NA, col.n.trees ="darkgray", ...) { # GBMFit was added in Oct 2016 for Paul Metcalfe's changes to gbm (version 2.2) check.classname(object, "object", c("gbm", "GBMFit")) obj <- object if((!is.numeric(smooth) && !is.logical(smooth)) || any(smooth != 0 & smooth != 1)) stop0("smooth should be a four-element vector specifying if train, ", "test, CV, and OOB curves are smoothed, e.g. smooth=c(0,0,0,1)") smooth <- rep_len(smooth, 4) # recycle smooth if necessary col <- rep_len(col, 4) # recycle col if necessary col[is.na(col)] <- 0 # make using col below a bit easier check.integer.scalar(n.trees, min=1, max=n.trees, na.ok=TRUE, logical.ok=FALSE) n.alltrees = gbm.n.trees(obj) # final.max is max of values on the right of the curves (excluding OOB) train.error <- gbm.train.error(obj) valid.error <- gbm.valid.error(obj) cv.error <- gbm.cv.error(obj) final.max <- max(train.error[length(train.error)], valid.error[length(valid.error)], cv.error [length(cv.error)], na.rm=TRUE) if(any1(col)) { # must anything be plotted? par <- par("mar", "mgp") # will be modified in init.gbm.plot on.exit(par(mar=par$mar, mgp=par$mgp)) init.gbm.plot(obj, ylim, final.max, par$mar, ...) if(is.specified(grid.col[1])) grid(col=grid.col[1], lty=3) # draw n.trees vertical gray line first, so other plots go on top of it if(is.specified(n.trees)) vertical.line(n.trees, col.n.trees, 1, 0) } leg.text <- leg.col <- leg.lty <- leg.vert <- leg.imin <- NULL # for legend voffset <- 0 # slight offset to prevent overplotting of dotted vertical lines # train curve y <- maybe.smooth(train.error, "train", smooth[1], n.alltrees) imin <- which.min1(y) # index of minimum train error imins <- c(imin, 0, 0, 0) # index of train, test, CV, OOB minima names(imins) <- c("train", "test", "CV", "OOB") train.fraction <- gbm.train.fraction(obj) if(is.specified(col[1])) { lines(y, col=col[1]) leg.text <- c(leg.text, if(train.fraction == 1) "train" else sprint("train (frac %g)", train.fraction)) leg.col <- c(leg.col, col[1]) leg.lty <- c(leg.lty, 1) leg.vert <- c(leg.vert, FALSE) leg.imin <- imin } # test curve (aka valid.error curve) if(train.fraction != 1) { y <- maybe.smooth(valid.error, "test", smooth[2], n.alltrees) imin <- imins[2] <- which.min1(y) if(is.specified(col[2])) { if(imin) vertical.line(imin, col[2], 3, voffset) voffset <- voffset + 1 lines(y, col=col[2]) leg.text <- c(leg.text, if(!imin) "test not plotted" else sprint("test (frac %g)", 1-train.fraction)) leg.col <- c(leg.col, col[2]) leg.lty <- c(leg.lty, 1) leg.vert <- c(leg.vert, FALSE) leg.imin <- c(leg.imin, imin) } } # CV curve if(!is.null(cv.error)) { y <- maybe.smooth(cv.error, "CV", smooth[3], n.alltrees) imin <- imins[3] <- which.min1(y) if(is.specified(col[3])) { if(imin) vertical.line(imin, col[3], 3, voffset) voffset <- voffset + 1 lines(y, col=col[3]) leg.text <- c(leg.text, if(!imin) "CV not plotted" else sprint("CV (%g fold)", gbm.cv.folds(obj))) leg.col <- c(leg.col, col[3]) leg.lty <- c(leg.lty, 1) leg.vert <- c(leg.vert, FALSE) leg.imin <- c(leg.imin, imin) } } # OOB curve bag.fraction <- gbm.bag.fraction(obj) if(bag.fraction != 1) { oobag.improve <- gbm.oobag.improve(obj) y <- maybe.smooth(-cumsum(oobag.improve), "OOB", smooth[4], n.alltrees) imin <- imins[4] <- which.min1(y) if(is.specified(col[4])) { if(imin) draw.oob.curve(y, imin, voffset, col[4], smooth, train.error) voffset <- voffset + 1 leg.text <- c(leg.text, if(!imin) "OOB not plotted" else "OOB (rescaled)") leg.col <- c(leg.col, col[4]) leg.lty <- c(leg.lty, 2) leg.vert <- c(leg.vert, FALSE) leg.imin <- c(leg.imin, imin) } } # legend entry for vertical line at n.trees if(is.specified(n.trees)) { leg.text <- c(leg.text, "predict n.trees") leg.col <- c(leg.col, col.n.trees) leg.lty <- c(leg.lty, 1) leg.vert <- c(leg.vert, TRUE) leg.imin <- c(leg.imin, n.trees) } if(any1(col)) { # was anything plotted? box() # replot box because vertical.line overplots it slightly gbm.legend(legend.x, legend.y, legend.cex, leg.text, leg.col, leg.lty, leg.vert, leg.imin) gbm.top.labels(leg.imin, leg.text, leg.col) } invisible(imins) } init.gbm.plot <- function(obj, ylim, final.max, mar, ...) { xlim <- dota("xlim", ...) # get xlim from dots, NA if not in dots n.alltrees <- gbm.n.trees(obj) if(!is.specified(xlim)) xlim <- c(0, n.alltrees) xlim <- fix.lim(xlim) ylim <- get.gbm.ylim(obj, xlim, ylim, final.max) ylab <- get.gbm.ylab(obj) # set mar[3] space for top labels and possibly (user-specified) main main <- dota("main", ...) # get main from dots, NA if not in dots nlines.needed.for.main <- if(is.specified(main)) nlines(main) + .5 else 0 par(mar=c(mar[1], mar[2], max(mar[3], nlines.needed.for.main + 1), mar[4])) par(mgp=c(1.5, .4, 0)) # squash axis annotations # Call graphics::plot but drop args in dots that aren't graphics args # or formal args of graphics::plot. # If argname below is prefixed with force. then ignore any such arg in dots. # Any argname below prefixed with def. can be overridden by a user arg in dots. # force.main="" because we add (user-specified) main manually because top labels. train.error <- gbm.train.error(obj) call.plot(graphics::plot, force.x=1:n.alltrees, force.y=train.error, force.type="n", force.main="", force.xlim=xlim, def.ylim=ylim, def.xlab="Number of Trees", def.ylab=ylab, ...) if(is.specified(main)) mtext(main, side=3, line=1.3, cex=par("cex")) # above top labels } get.gbm.ylim <- function(obj, xlim, ylim, final.max) { train.error <- gbm.train.error(obj) valid.error <- gbm.valid.error(obj) cv.error <- gbm.cv.error(obj) if(is.character(ylim) && substr(ylim[1], 1, 1) == "a") { # auto ylim? imin <- max(1, min(1, xlim[1])) imax <- min(length(train.error), max(length(train.error), xlim[2])) cv.error <- gbm.cv.error(obj) ylim <- range(train.error[imin:imax], valid.error[imin:imax], cv.error [imin:imax], na.rm=TRUE) # decrease ylim[2] to put more resolution in the "interesting" # part of the curve by putting final.max half way up plot ylim[2] <- ylim[1] + 2 * (final.max - ylim[1]) # ensure 75% of training curve is visible # (typically needed when no test or CV curve) i <- floor(xlim[1] + .25 * (xlim[2] - xlim[1])) if(i >= 1 && i <= length(train.error[imin:imax])) ylim[2] <- max(ylim[2], train.error[i]) } else if(!is.specified(ylim)) # ylim=NULL or ylim=NA ylim <- range(train.error, valid.error, cv.error, na.rm=TRUE) fix.lim(ylim) } get.gbm.ylab <- function(obj) { dist <- gbm.short.distribution.name(obj) if(dist =="pa") # pairwise switch(obj$distribution$metric, conc="Fraction of Concordant Pairs", ndcg="Normalized Discounted Cumulative Gain", map ="Mean Average Precision", mrr ="Mean Reciprocal Rank", stop0("unrecognized pairwise metric: ", obj$distribution$metric)) else # not pairwise switch(dist, ga="Squared Error Loss", # gaussian la="Absolute Loss", # laplace td="t-distribution deviance", be="Bernoulli Deviance", # logistic hu="Huberized Hinge Loss", mu="Multinomial Deviance", ad="Adaboost Exponential Bound", ex="Exponential Loss", po="Poisson Deviance", co="Cox Partial Deviance", qu="Quantile Loss", stop0("unrecognized distribution name: ", obj$distribution.name)) } vertical.line <- function(x, col=1, lty=1, voffset=0) # draw a vertical line at x { if(is.specified(col)) { usr <- par("usr") # xmin, xmax, ymin, ymax range <- usr[4] - usr[3] lwd <- 1 if(lty == 3) { # dotted line? # increase lwd to make dotted lines more visible lwd <- min(1.5, 2 * par("cex")) # small vertical offset so multiple dotted lines at same xpos visible voffset <- 0.008 * voffset * range } else voffset <- 0 lines(x=c(x, x), y=c(usr[3], usr[4]) - voffset, col=col, lty=lty, lwd=lwd) lines(x=c(x, x), y=c(usr[3], usr[3] + .02 * range), col=col, lty=1) # tick } } # this returns a single NA if y has non finite values maybe.smooth <- function(y, yname, must.smooth, n.alltrees) { if(any(!is.finite(y))) { # infinities in OOB curve occur with distribution="huberized" warning0("plot_gbm: cannot plot ", yname, " curve (it has some non-finite values)") return(NA) } if(must.smooth) { x <- 1:n.alltrees if(n.alltrees < 10) # loess tends to fail for small n.alltrees, use lowess instead y <- lowess(x, y)$y else # use loess for compatibility with gbm y <- loess(y~x, na.action=na.omit, # paranoia, prevent warnings from loess # enp.target is the same as gbm.perf for compatibility # (this does only minimal smoothing) enp.target=min(max(4, n.alltrees/10), 50))$fitted } y } which.min1 <- function(x) # like which.min but return 0 if x is all NA { if(all(is.na(x))) return(0) which.min(x) } draw.oob.curve <- function(y, imin, voffset, col, smooth, train.error) { stopifnot(!is.na(imin)) vertical.line(imin, col, 3, voffset) # rescale y to fit into plot usr <- par("usr") # xmin, xmax, ymin, ymax y <- y - min(y) y <- y / max(y) # y is now 0..1 e <- train.error n <- length(e) # start and end of OOB curve same as 10% into train curve and end train curve y <- e[n] + (e[max(1, 0.1 * n)] - e[n]) * y lines(1:n, y, col=col, lty=2) } gbm.legend <- function(legend.x, legend.y, legend.cex, leg.text, leg.col, leg.lty, leg.vert, leg.imin) { xjust <- 0 usr <- par("usr") # xmin, xmax, ymin, ymax if(is.null(legend.y)) legend.y <- usr[3] + .65 * (usr[4] - usr[3]) if(is.null(legend.x)) { # Automatically position the legend just to the left of the # leftmost vertical line that is to the right of .7 * usr[2]. # Hopefully that puts it not on top of anything interesting. xjust <- 1 imin <- c(usr[2], leg.imin[which(leg.imin > usr[1] + .7 * (usr[2]-usr[1]))]) legend.x <- min(imin) - .05 * (usr[2] - usr[1]) legend.y <- usr[4] - .05 * (usr[4] - usr[3]) } if(is.specified(legend.x)) elegend(x=legend.x, y=legend.y, legend=leg.text, col=leg.col, lty=leg.lty, vert=leg.vert, # vert is supported by elegend but not by legend bg="white", cex=legend.cex, xjust=xjust, yjust=xjust) } # print the best number-of-trees for each curve along the top of the plot gbm.top.labels <- function(leg.imin, leg.text, leg.col) { # don't print number-of-trees for the training curve stopifnot(substring(leg.text[1], 1, 5) == "train") leg.col[1] <- 0 # darker than darkgray seems needed for top text # to be perceived as darkgray, not sure why leg.col[leg.col == "darkgray"] <- lighten("darkgray", -0.1) usr <- par("usr") # xmin, xmax, ymin, ymax # TODO spread.labs is buggy for horizontal labels (too much space sometimes)? x <- spread.labs(leg.imin,mindiff=par("cex") * max(strwidth(paste0(leg.imin, " "))), min=usr[1], max=usr[2]) # use of "ok" prevents display off the right or left of the plot # (necessary if user specifies xlim) # check against leg.imin is for when which.lim1(NA) returns 0 margin <- .05 * (usr[2] - usr[1]) ok <- (x > usr[1] - margin) & (x < usr[2] + margin) & (leg.imin != 0) if(any(ok)) text(x=x[ok], # this call to text works with call to text in init.gbm.plot y=usr[4] + .4 * strheight("X"), # just above plot labels=leg.imin[ok], col=leg.col[ok], adj=c(.5, 0), # x is middle of text, y is bottom of text xpd=NA) # allow plotting out the plot area } plotmo/R/do.par.R0000644000176200001440000002104714663771205013312 0ustar liggesusers# do.par.R: functions setting par() and for setting the overall caption # main1 is not called main else would clash with main passed in dots (which # we ignore but cause an error message). Likewise for xlab1 and ylab1. do.par <- function(..., nfigs, caption, main1, xlab1, ylab1, trace, nlines.in.main=if(is.specified(main1)) nlines(main1) else 1, def.cex.main=1, def.font.main=2, # use 1 for compat with plot.lm def.right.mar=.8) { nrows <- ceiling(sqrt(nfigs)) # Note that the plain old cex argument is used in plotmo only in par() # (but we also query it later using par("cex")). # We use plain old cex relative to the cex calculated by nrows (so passing # cex=1 to plotmo causes no changes, and cex=.8 always makes things smaller). # TODO cex.axis etc. should be treated in the same way # TODO consider moving this into the dotargs functions, also extend for cex.axis, cex.main plain.old.cex <- dota("cex", DEF=1, ...) check.numeric.scalar(plain.old.cex) cex <- if(nrows == 1) 1 else if(nrows == 2) .83 else if(nrows >= 3) .66 cex <- plain.old.cex * cex # set oma to make space for caption if necessary stopifnot.string(caption, allow.empty=TRUE, null.ok=TRUE) def.oma <- dota("oma", ...) if(!is.specified(def.oma)) { def.oma <- par("oma") def.oma[3] <- max(def.oma[3], # .333 to limit cex adjustmment 2 + (plain.old.cex^.333 * nlines(caption))) } cex.lab <- dota("cex.lab", # make the labels small if multiple figures DEF=if(def.cex.main < 1) .8 * def.cex.main else 1, ...) mgp <- # compact title and axis annotations if(cex.lab < .6) c(1, 0.2, 0) else if(cex.lab < .8) c(1, 0.25, 0) else c(1.5, 0.4, 0) # margins are small to pack plots in, but make bigger if xlab # or ylab specified (note that xlab or ylab equal to NULL means # that we will later auto generate them) mar <- c( if(is.null(xlab1) || (is.specified(xlab1) && any(nzchar(xlab1)))) 4 else 3, # bottom if(is.null(ylab1) || (is.specified(ylab1) && any(nzchar(ylab1)))) 3 else 2, # left 1.2 * nlines.in.main, # top def.right.mar) # right if(nrows >= 5) # small margins if lots of figures mar <- cex * mar trace2(trace, "\n") call.dots(graphics::par, DROP="*", # drop everything KEEP="PREFIX,PAR.ARGS", # except args matching PREFIX and PAR.ARGS TRACE=if(trace >= 2) trace-1 else 0, SCALAR=TRUE, def.mfrow = c(nrows, nrows), def.mgp = mgp, # compact title and axis annotations def.tcl = -.3, # shorten tick length def.font.main = def.font.main, def.mar = mar, def.oma = def.oma, def.cex.main = def.cex.main, # ignored by most plot funcs so do it here def.cex.lab = cex.lab, def.cex.axis = cex.lab, force.cex = cex, # last, overrides any cex set by any arg above ...) # any remaining graphic dot args are also processed } # call do.par on any graphics args in dots, and return a list of their # old values so the caller can use on.exit to restore them do.par.dots <- function(..., trace=0) { dots <- match.call(expand.dots=FALSE)$... if(length(dots) == 0) return(NULL) oldpar <- args <- list() env <- parent.frame() for(dotname in PAR.ARGS) if(is.dot(dotname, ...)) { arg <- list(par(dotname)) names(arg) <- dotname oldpar <- append(oldpar, arg) dot.org <- dota(dotname, ...) dot <- try(eval(dot.org, envir=env, enclos=env), silent=TRUE) if(is.try.err(dot)) dot <- dot.org # TODO consider moving this into the dotargs functions, also extend for cex.axis, cex.main # special handling for cex args: we want cex to be relative # to the current setting, so e.g cex=1 causes no change if(substr(dotname, 1, 3) == "cex") { olddot <- par(dotname) dot <- dot[[1]] * olddot } else if(!(dotname %in% PAR.VEC) && length(dot) != 1) dot <- dot[[1]] # similar to handling of argument "scalar" in eval.dotlist arg <- list(dot) names(arg) <- dotname args <- append(args, arg) } if(length(args)) { if(trace >= 2) printf.wrap("\npar(%s)\n", list.as.char(args)) do.call(par, args) } oldpar # a list of old values of args that were changed, empty if none } check.do.par <- function(do.par, nfigs) # auto do.par if null, check is 0,1, or 2 { if(is.null(do.par)) do.par <- nfigs > 1 if(is.logical(do.par)) do.par <- as.numeric(do.par) stopifnot(length(do.par) == 1) if(!is.numeric(do.par) || (do.par != 0 && do.par != 1 &&do.par != 2)) stop0("do.par must be 0, 1, or 2") do.par } auto.caption <- function(caption, resp.name, type, model.call, object.name, my.call) { sresponse <- stype <- smodel <- scaption <- smy.call <- "" if(!is.null(caption)) scaption <- sprint("%s ", caption) # the test against "y" is because "y" may just be a fabricated # name created because the actual name was not available if(!is.null(resp.name) && resp.name != "y") sresponse <- paste0(resp.name, " ") if(type != "response") stype <- paste0("type=", type, " ") if(!is.null(model.call)) { smodel <- strip.deparse(model.call) smodel <- sub("\\(formula=", "(", smodel) # delete formula= } else smodel <- paste0("model: ", object.name) s <- paste0(scaption, sresponse, stype, smodel) smy.call <- process.my.call.for.caption(my.call) if(nzchar(smy.call)) s <- paste0(s, if(nzchar(s)) "\n" else "", smy.call) s } # Call this only after a plot is on the screen to avoid # an error message "plot.new has not been called yet" draw.caption <- function(caption, ...) { if(!is.null(caption) && any(nzchar(caption))) { # allow use of dot args for caption specs cex <- dota("caption.cex cex.caption", DEF=1, NEW=1, ...) font <- dota("caption.font font.caption", DEF=1, NEW=1, ...) col <- dota("caption.col col.caption", DEF=1, NEW=1, ...) line <- dota("caption.line", DEF=1, ...) # trim so caption fits # strwidth doesn't have units of device coords so work with usr coords # TODO the algorithm below is not quite correct caption <- strsplit(caption, "\n")[[1]] usr <- par("usr") # xmin, xmax, ymin, ymax n <- par("mfrow")[2] # number of figures horizontally across page avail <- .7 * n * (usr[2] - usr[1]) strwidth <- max(strwidth(caption)) if(strwidth > avail) { which <- strwidth(caption) > avail max <- max(nchar(caption)) max.nchar <- max * avail / strwidth if(max.nchar < max) { # TODO should always be FALSE but actually isn't caption <- substr(caption, 1, max.nchar) caption[which] <- paste0(caption[which], "...") } } caption <- paste(caption, collapse="\n") mtext(text=caption, line=line, outer=TRUE, cex=cex * par("cex")^.333, col=col, font=font) } caption } get.caption <- function(nfigs, do.par, caption, resp.name, type, model.call, object.name, my.call) { stopifnot.string(caption, null.ok=TRUE, allow.empty=TRUE) if(nfigs > 1 && do.par && (is.null(caption) || !is.null(my.call))) auto.caption(caption, resp.name, type, model.call, object.name, my.call) else paste0(if(is.null(caption)) "" else caption, if(!is.null(caption) && !is.null(my.call)) "\n" else "", if(!is.null(my.call)) "" else process.my.call.for.caption(my.call)) } process.my.call.for.caption <- function(my.call) { s <- "" if(!is.null(my.call)) { s <- sub("\\(object=", "(", my.call) # delete object= s <- sub(", trace=[-._$[:alnum:]]+", "", s) # delete trace=xxx s <- sub(", SHOWCALL=[-._$[:alnum:]]+", "", s) # delete SHOWCALL=xxx } s # a string, may be "" } plotmo/R/grid.R0000644000176200001440000002417514663771205013061 0ustar liggesusers# grid.R: functions for creating the grid of values to be plotted in plotmo graphs # Get the x matrix (actually a data.frame) with median values (or first level # for factors), ngrid1 rows, all rows identical, nrow(xgrid) is ngrid1. get.degree1.xgrid <- function(x, grid.func, grid.levels, pred.names, ngrid1) { stopifnot(!is.null(pred.names)) check.grid.levels.arg(x, grid.levels, pred.names) xgrid <- data.frame(matrix(0, ngrid1, ncol(x), byrow=TRUE)) for(ipred in seq_len(ncol(x))) xgrid[[ipred]] <- get.fixed.gridval(x[[ipred]], pred.names[ipred], grid.func, grid.levels) warn.if.not.all.finite(xgrid, "'xgrid' for degree1 plots") colnames(xgrid) <- pred.names xgrid } # Update xgrid for the predictor currently being plotted. # That is, replace this predictor's column with a range of values. # For factors or discrete variables, we shorten the frame to match the nbr of levels. get.degree1.xframe <- function(xgrid, x, ipred, ngrid1, ndiscrete, ux.list, extend, mean) { x1 <- x[[ipred]] # uxlist is a list, each elem is the unique levels for corresponding column of x u1 <- ux.list[[ipred]] if(is.factor(x1) && length(u1) > ngrid1) stop0("ngrid1=", ngrid1, " is less than the number ", "of levels ", length(u1), " in '", colnames(x)[ipred], "'\n Workaround: call plotmo with ngrid1=", length(u1)) if(is.factor(x1) || is.logical(x1) || length(u1) <= ndiscrete) { levels <- get.all.levs(x1, u1) xframe <- xgrid[1:length(levels), , drop=FALSE] # shorten xframe xframe[[ipred]] <- levels } else { xframe <- xgrid xrange <- range1(x1) if(extend != 0) { # extend the range of x (TODO consider allowing extend with discrete vars) stopifnot(xrange[2] >= xrange[1]) ext <- extend * (xrange[2] - xrange[1]) xrange[1] <- xrange[1] - ext xrange[2] <- xrange[2] + ext } xval <- seq(from=xrange[1], to=xrange[2], length.out=ngrid1) # # following commented out because it causes cliffs to slope more than necessary # # e.g. test.fac.R plotmo(rpart(survived ~ pclass.num+parch.int, data=et)) # if(is.integer(x1)) { # xval <- unique(as.integer(xval)) # if(length(xval) < ngrid1) # xframe <- xframe[1:length(xval), , drop=FALSE] # shorten xframe # } xframe[[ipred]] <- xval } xframe } # We want to display discrete variables in degree1 plots as quantized. # (Factors get handled elsewhere.) So if a variable is discrete, then # modify the xframe and yhat to do so. For example, an xframe that was # # pclass yhat # 1 1.1 # 2 2.2 # 3 3.3 # # becomes # # pclass yhat # 1.0 1.1 # 1.5 1.1 # 1.5 2.2 # 2.5 2.2 # 2.5 3.3 # 3.0 3.3 blockify.degree1.frame <- function(xframe, yhat, intervals, ipred, ux.list, ndiscrete) { u1 <- ux.list[[ipred]] # TODO the integral check is necessary for compatibility with blockify.degree2.frame # (the code here can handle non integers but the code in blockify.degree2.frame can't) if(length(u1) <= ndiscrete && !is.factor(xframe[[ipred]]) && !inherits(u1, "Date") && is.integral(u1)) { # discrete, so duplicate each elem in yhat yhat <- rep(yhat, each=2) if(!is.null(intervals)) { new.intervals <- data.frame( lwr = rep(intervals$lwr, each=2), upr = rep(intervals$upr, each=2)) if(!is.null(intervals$fit)) new.intervals$fit <- rep(intervals$fit, each=2) if(!is.null(intervals$cint.lwr)) { new.intervals$cint.lwr <- rep(intervals$cint.lwr, each=2) new.intervals$cint.upr <- rep(intervals$cint.upr, each=2) } intervals <- new.intervals } # duplicate each row of xframe, except the first and last row xframe <- xframe[rep(seq_len(nrow(xframe)), each=2), , drop=FALSE] if(nrow(xframe) >= 4) { x1 <- xframe[[ipred]] for(i in seq(2, length(x1)-1, by=2)) x1[i] <- x1[i+1] <- (x1[i] + x1[i+1]) / 2 xframe[[ipred]] <- x1 } } list(xframe=xframe, yhat=yhat, intervals=intervals) } # Get the x matrix (actually a data.frame) to plot in degree2 plots. # Each row of xgrid is identical (the medians). get.degree2.xgrid <- function(x, grid.func, grid.levels, pred.names, ngrid2) { check.grid.levels.arg(x, grid.levels, pred.names) xgrid <- list(ncol(x)) for(ipred in seq_len(ncol(x))) xgrid[[ipred]] <- get.fixed.gridval(x[[ipred]], pred.names[ipred], grid.func, grid.levels) warn.if.not.all.finite(xgrid, "'xgrid' for degree2 plots") xgrid <- as.data.frame(xgrid) colnames(xgrid) <- pred.names xgrid[seq_len(ngrid2^2), ] <- xgrid xgrid } # Update xgrid for the predictor pair currently being plotted (ipred1 # and ipred2 are column numbers in x). That is, replace two columns # with a range of values. # # This will also shorten xgrid if possible (i.e. if predictor is discrete # with number of discrete values less than ngrid2, typically because # predictor is a factor.) This shortening is for efficiency later, # because it means we avoid duplicate cases in xgrid. get.degree2.xframe <- function(xgrid, x, ipred1, ipred2, ngrid2, xranges, ux.list, ndiscrete) { ret1 <- get.degree2.xframe.aux(xgrid, x, ipred1, ngrid2, xranges, ux.list, ndiscrete) ret2 <- get.degree2.xframe.aux(xgrid, x, ipred2, ngrid2, xranges, ux.list, ndiscrete) # pack x1grid and x2grid into xgrid if(ret1$n != ngrid2 || ret2$n != ngrid2) xgrid <- xgrid[1:(ret1$n * ret2$n), , drop=FALSE] # shorten xgrid xgrid[[ipred1]] <- ret1$xgrid # will recycle xgrid[[ipred2]] <- rep(ret2$xgrid, each=ret1$n) list(xframe=xgrid, x1grid=ret1$xgrid, x2grid=ret2$xgrid) } get.degree2.xframe.aux <- function(xgrid, x, ipred1, ngrid2, xranges, ux.list, ndiscrete) { n1 <- ngrid2 # will change if ipred1 is discrete u1 <- ux.list[[ipred1]] nlevs1 <- length(u1) if(is.factor(x[[ipred1]]) && nlevs1 > ngrid2) stop0("ngrid2=", ngrid2, " is less than the number", " of levels ", nlevs1, " in '", colnames(x)[ipred1], "'\n Workaround: call plotmo with ngrid2=", length(u1)) x1 <- x[[ipred1]] x1grid <- if(is.factor(x1) || is.logical(x1) || nlevs1 <= ndiscrete) { # discrete? n1 <- nlevs1 x1grid <- get.all.levs(x1, u1) } else seq(from=xranges[1,ipred1], to=xranges[2,ipred1], length.out=ngrid2) if(is.integer(x1)) { x1grid <- unique(as.integer(x1grid)) n1 <- length(x1grid) } list(xgrid=x1grid, n=n1) } # we want to draw discrete variables in persp and contour plots using "blocks" blockify.degree2.frame <- function(x, yhat, x1grid, x2grid, ipred1, ipred2, ux.list, ndiscrete) { is.discrete2 <- function(ipred, x1grid) { if(is.factor(x[[ipred]])) return(TRUE) u1 <- ux.list[[ipred]] # the integral check is necessary with the current # implementation which adds/subtracts a hardcoded .499 # TODO make this like blockify.degree1.frame (which can handle non integers) length(u1) <= ndiscrete && is.integral(x1grid) } if(is.discrete2(ipred1, x1grid)) { yhat <- rep(yhat, each=2) # duplicate each elem in yhat x1grid <- rep(x1grid, each=2) # duplicate each elem in x1grid is.even <- (1:length(x1grid)) %% 2 == 0 x1grid[!is.even] <- x1grid[!is.even] - .499 # sub .5 from odd elems x1grid[is.even] <- x1grid[is.even] + .499 # add .5 to even elems } if(is.discrete2(ipred2, x2grid)) { # duplicate each block in yhat (each block has n1 elements) y.old <- yhat yhat <- double(2 * length(yhat)) n1 <- length(x1grid) for(i in 1:length(x2grid)) { start <- n1 * (i-1) end <- n1 * i yhat[(2 * start + 1): (2 * end)] <- y.old[(start + 1): end] } x2grid <- rep(x2grid, each=2) # duplicate each elem in x2grid is.even <- (1:length(x2grid)) %% 2 == 0 x2grid[!is.even] <- x2grid[!is.even] - .499 # sub .5 from odd elems x2grid[is.even] <- x2grid[is.even] + .499 # add .5 to even elems } list(yhat=yhat, x1grid=x1grid, x2grid=x2grid) } # if x is a factor # return a factor vector with nlevs elements, e.g. pclass1, pclass2, pclass3. # else # return a vector with all unique values in x, e.g. 1,2,3 or FALSE, TRUE get.all.levs <- function(x, levels) { if(!is.factor(x)) return(levels) # TODO Sanity check, quite expensive, make sure no gaps in factor coding # Could remove this if convert levels to factors in a better way below? range <- range(as.numeric(x), na.rm=TRUE) if(range[1] < 1 || range[2] > length(levels)) stop0("internal error: illegal factor range ", range[1], " ", range[2], " for levels ", quotify(levels)) if(is.ordered(x)) ordered(1:length(levels), labels=levels) else factor(1:length(levels), labels=levels) } # Print the grid values, must do some finagling for a nice display print_grid_values <- function(xgrid, trace) { trace1(trace, "\n") # extra space when tracing row <- xgrid[1, , drop=FALSE] names(row) <- c(paste("plotmo grid: ", names(row)[1]), names(row)[-1]) rownames(row) <- "" print(row) trace1(trace, "\n") } plotmo/R/plotresids.R0000644000176200001440000010713014663771205014315 0ustar liggesusers# plotresids.R plotresids <- function( object, which, info, standardize, level, versus1, id.n, smooth.col, grid.col, jitter, npoints, center, type, fitted, rinfo, rsq, iresids, nversus, colname.versus1, force.auto.resids.xlim, force.auto.resids.ylim, SHOWCALL=NA, # this is here to absorb SHOWCALL from dots ...) { stopifnot(length(which) == 1) info <- check.boolean(info) ok <- which %in% c(W3RESID,W5ABS:W9LOGLOG) if(!all(ok)) stop0("which=", which[!ok][1], " is not allowed") # id.n has already been checked in plotres.data id.indices.specified <- FALSE if(which %in% c(W3RESID, W4QQ:W8CUBE) && id.n != 0) id.indices.specified <- TRUE level <- check.level.arg(level, zero.ok=TRUE) if(which %in% (W5ABS:W9LOGLOG)) level <- 0 # no pints pints <- NULL cints <- NULL level.shade <- dota("level.shade shade.pints", DEF="mistyrose2", ...) level.shade2 <- dota("level.shade2 shade.cints", DEF="mistyrose4", ...) if(which == W3RESID && is.specified(level)) { p <- plotmo.pint(object, newdata=NULL, type, level, trace=0) if(!is.null(p$fit) && max(abs(p$fit - fitted)) != 0) { # TODO $$ happens with test.unusual.vars.R:earth.glm.spaced.bx warning0("Internal inconsistency: p$fit != fitted", if(inherits(object, "earth")) "\n Workaround: no 'glm' arg in call to earth, or no 'level' arg n call to plotres" else "") fitted <- p$fit # hack } if(is.specified(level.shade) && !is.null(p$upr)) { pints <- data.frame(upr=rinfo$scale * (p$upr - fitted), lwr=rinfo$scale * (p$lwr - fitted)) colnames(pints) <- c("upr", "lwr") } if(is.specified(level.shade2) && !is.null(p$cint.upr)) { cints <- data.frame(upr=rinfo$scale * (p$cint.upr - fitted), lwr=rinfo$scale * (p$cint.lwr - fitted)) colnames(cints) <- c("upr", "lwr") } } if(is.null(pints) && is.null(cints)) level <- 0 resids <- rinfo$scale * rinfo$resids if((which %in% W7VLOG:W9LOGLOG)) check.that.most.are.positive( versus1, "fitted", sprint("which=%d", which), "nonpositive") # TODO following is redundant after above check? # abs(resids) must be nonnegative to take their log if(which %in% W7VLOG:W9LOGLOG) check.that.most.are.positive( abs(resids), "abs(residuals)", sprint("which=%d", which), "zero") trans.versus <- trans.versus(versus1[iresids], which) trans.resids <- trans.resids(resids[iresids], which) x <- if(nversus == V2INDEX) 1:length(trans.versus) else trans.versus jitter <- as.numeric(check.numeric.scalar(jitter, logical.ok=TRUE)) stopifnot(jitter >= 0, jitter <= 10) # 10 is arbitrary jittered.x <- x jittered.trans.resids <- trans.resids if(jitter > 0) { # we use amount=0 (same as S) which seems to work better in this context jittered.x <- jitter(x, factor=jitter, amount=0) jittered.trans.resids <- jitter(trans.resids, factor=jitter, amount=0) } derived.xlab <- derive.xlab(dota("xlab", DEF=NULL, ...), which, colname.versus1, nversus) derived.ylab <- derive.ylab(dota("ylab", DEF=NULL, ...), which, rinfo$name) main <- derive.main(main=dota("main", DEF=NULL, ...), derived.xlab, derived.ylab, level, attr(object, "plotmo.s")) # allow col.response as an argname for compat with old plotmo pt.col <- dota("col.response col.resp", DEF=1, ...) pt.col <- dota("pt.col col.points col.point col.residuals col.resid col", EX=c(0,1,1,1,1,1), DEF=pt.col, NEW=1, ...) # recycle pt.col <- repl(pt.col, length(resids)) pt.cex <- dota("response.cex cex.response", DEF=1, ...) pt.cex <- dota("pt.cex cex.points cex.point cex.residuals cex", EX=c(0,1,1,1,1), DEF=pt.cex, NEW=1, ...) pt.cex <- pt.cex * pt.cex(length(x), npoints) pt.cex <- repl(pt.cex, length(resids)) pt.pch <- dota("response.pch pch.response", DEF=20, ...) pt.pch <- dota("pt.pch pch.points pch.point pch.residuals pch", EX=c(0,1,1,1,1), DEF=pt.pch, NEW=1, ...) pt.pch <- repl(pt.pch, length(resids)) ylim <- get.resids.ylim(ylim=dota("ylim", ...), force.auto.resids.ylim, object, fitted, trans.resids, which, info, standardize, id.indices.specified, center, pints, cints, rinfo$scale, nversus) xlim <- get.resids.xlim(xlim=dota("xlim", ...), force.auto.resids.xlim, which, x, trans.versus, ylim, nversus, id.indices.specified) id.indices <- NULL if(id.indices.specified) id.indices <- get.id.indices(rinfo$scale * rinfo$resids, id.n, if(nversus == V4LEVER) hatvalues1(object, sprint("versus=%g", V4LEVER)) else NULL) call.plot(graphics::plot.default, PREFIX="pt.", force.x = x, force.y = jittered.trans.resids, force.main = main, force.xlab = derived.xlab, force.ylab = derived.ylab, force.xlim = xlim, force.ylim = ylim, force.col = NA, # no points will actually be plotted at this stage ...) if(is.specified(grid.col)) grid(col=grid.col, lty=1) else if(which != W9LOGLOG) abline(h=0, lty=1, col="lightgray") # axis if(level && nversus != V4LEVER) { if(is.specified(level.shade)) draw.pint.resids(pints=pints, x=versus1, shade=level.shade, nversus=nversus, ...) if(is.specified(level.shade2)) draw.pint.resids(pints=cints, x=versus1, shade=level.shade2, nversus=nversus, ...) } if(nversus == V4LEVER) { # vertical line at mean leverage mean <- mean(x, na.rm=TRUE) abline(v=mean, col="gray") # add label "mean" if(which == W3RESID) { # not for others otherwise put text over the points usr <- par("usr") # xmin, xmax, ymin, ymax text(mean, if(info) usr[3] + .1 * (usr[4] - usr[3]) # beyond density plot else usr[3] + .02 * (usr[4] - usr[3]), "mean", adj=c(0, -.2), cex=.8, srt=90) } if(standardize && inherits(object, "lm")) draw.cook.levels(object, ...) } call.plot(graphics::points, PREFIX="pt.", force.x = jittered.x, force.y = jittered.trans.resids, force.col = pt.col[iresids], force.cex = pt.cex[iresids], force.pch = pt.pch[iresids], ...) box() # plot points with unity leverage as stars draw.bad.leverage.as.star(jittered.x, rinfo, iresids, pt.cex, smooth.col) coef.rlm <- NULL if(info && nversus != V4LEVER && (which == W5ABS || which == W9LOGLOG)) coef.rlm <- draw.rlm.line(which, versus1, resids, nversus, ...) if(which != W9LOGLOG) draw.smooth(x, trans.resids, rinfo$scale[iresids], smooth.col, ...) col.cv <- dota("col.cv", ...) oof.meanfit.was.plotted <- FALSE if(level && !is.null(object$cv.oof.fit.tab) && is.specified(col.cv)) { draw.oof.meanfit(object$cv.oof.fit.tab, fitted, versus1, rinfo, which, col.cv, nversus) oof.meanfit.was.plotted <- TRUE } # TODO implement id.indices for nversus=V2INDEX if(id.indices.specified && nversus != V2INDEX) { # TODO as.numeric is needed if versus1 is a factor # is.na test needed for which=7 (if some are negative?) x1 <- as.numeric(trans.versus(versus1, which)[id.indices]) if(!anyNA(x1)) plotrix::thigmophobe.labels(x=x1, # TODO labels should take into account jitter y=trans.resids(resids, which)[id.indices], labels=rinfo$labs[id.indices], offset=.33, xpd=NA, font=dota("label.font", DEF=1, ...)[1], cex=.8 * dota("label.cex", DEF=1, ...)[1], col=dota("label.col", DEF=if(is.specified(smooth.col)) smooth.col else 2, ...)[1]) } if(info) draw.resids.info(which, info, versus1, resids, nversus, rsq, coef.rlm, ...) else possible.plotres.legend(which=which, level=level, smooth.col=smooth.col, oof.meanfit.was.plotted=oof.meanfit.was.plotted, ...) list(x=x, y=trans.resids) # does not include jittering } get.plotres.data <- function(object, object.name, which, standardize, delever, level, versus, id.n, labels.id, trace, npoints, type, nresponse, ..., must.get.rsq) { # the dot argument FORCEPREDICT is to check compat with old plot.earth meta <- plotmo_meta(object, type, nresponse, trace, avoid.predict=!dota("FORCEPREDICT", DEF=FALSE, ...), ...) nresponse <- meta$nresponse # column index resp.name <- meta$resp.name # used only in automatic caption, may be NULL type <- meta$type # always a string (converted from NULL if necessary) residtype <- meta$residtype # ditto # we get rsq only if necessary, because error reporting if we can't get it # is weak (because of nested try blocks, here and in do.call.trace) rsq <- NA if(must.get.rsq) { rsq <- try(plotmo_rsq1(object=object, newdata=NULL, trace=if(trace == 1) -1 else trace, meta=meta, ...), silent=trace < 2) if(is.try.err(rsq)) { trace0(trace, "Cannot get training rsq (%s)\n", cleantry(rsq)) rsq <- NA } } # get the residuals and fitted info rinfo <- plotmo_rinfo(object=object, type=type, residtype=residtype, nresponse=nresponse, standardize=standardize, delever=delever, trace=trace, leverage.msg= if(any(which %in% c(W3RESID,W5ABS:W9LOGLOG))) "plotted as a star" else "ignored", expected.levs=meta$resp.levs, labels.id=labels.id, ...) fitted <- rinfo$fitted # n x 1 numeric matrix rinfo$fitted <- NA # prevent accidental use of rinfo$fitted later stopifnot(NCOL(fitted) == 1) stopifnot(length(dim(fitted)) == 2) colnames(fitted) <- "Fitted" # colname will be used in labels in plots # get the values we will plot against (by default the fitted values) vinfo <- get.versus.info(which, versus, object, fitted, nresponse, trace) stopifnot(nrow(fitted) == length(rinfo$resids)) ncases <- length(rinfo$resids) id.n <- get.id.n(id.n, ncases) # convert special values of id.n # convert special values of npoints check.integer.scalar(npoints, min=-1, null.ok=TRUE, logical.ok=TRUE) npoints.was.neg <- FALSE if(is.null(npoints)) npoints <- 0 else if(is.logical(npoints)) npoints <- if(npoints) ncases else 0 else if(npoints == -1) { npoints.was.neg <- TRUE npoints <- ncases } else if(npoints > ncases) npoints <- ncases # Use a maximum of NMAX residuals (unless npoints is bigger or negative). # Allows plotres to be fast even on models with millions of cases. NMAX <- 1e4 nmax <- max(NMAX, npoints) if(!npoints.was.neg && nrow(fitted) > nmax) { if(trace >= 1) printf("using %g of %g residuals%s\n", nmax, ncases, if(id.n > 0) ", forcing id.n=0 because of that (implementation restriction)" else "") # see comment in plotres for use of V4LEVER here isubset <- get.isubset(rinfo$resids, nmax, id.n, use.all=(vinfo$nversus == V4LEVER), rinfo$scale) fitted <- fitted [isubset, , drop=FALSE] rinfo$resids <- rinfo$resids[isubset, , drop=FALSE] rinfo$scale <- rinfo$scale [isubset] vinfo$versus.mat <- vinfo$versus.mat [isubset, , drop=FALSE] # Can no longer draw point labels because row numbers are different. # TODO Come up with a solution so it doesn't have to be that way. id.n <- 0 } list(nresponse = nresponse, # col index in the response (converted from NA if necessary) resp.name = resp.name, # used only in automatic caption, may be NULL type = type, # always a string (converted from NULL if necessary) rinfo = rinfo, # resids, scale, name, etc. vinfo = vinfo, # versus.mat, icolumns, nversus, etc. fitted = fitted, # n x 1 numeric matrix, colname is "Fitted" id.n = id.n, # forced to zero if row indexing changed npoints = npoints, # special values have been converted rsq = rsq) } get.id.n <- function(id.n, ncases) # convert special values of id.n { check.integer.scalar(id.n, null.ok=TRUE, logical.ok=TRUE) if(is.null(id.n)) id.n <- 0 else if(is.logical(id.n)) { id.n <- if(id.n) ncases else 0 } else if(id.n == -1) id.n <- ncases else if(abs(id.n) > ncases) id.n <- ncases id.n } get.versus.info <- function(which, versus, object, fitted, nresponse, trace=0) { versus.mat <- fitted icolumns <- 1 trim.which <- FALSE got.versus <- FALSE nversus <- versus if(is.numeric(versus)) { got.versus <- TRUE trim.which <- TRUE if(length(versus) != 1) stop0( "illegal 'versus' argument (length of 'versus' must be 1 when 'versus' is numeric)") if(floor(versus) != versus) versus.err() if(versus == V1FITTED) trim.which <- FALSE else if(versus == V2INDEX) NULL else if(versus == V3RESPONSE) { versus.mat <- plotmo_y(object, nresponse, trace, expected.len=NROW(fitted), object$levels)$y colnames(versus.mat) <- "Response" } else if(versus == V4LEVER) { # TODO handle constant leverages for factors in the same way as plot.lm versus.mat <- matrix(hatvalues1(object, sprint("versus=%g", V4LEVER)), ncol=1) colnames(versus.mat) <- "Leverage" } else versus.err() } else if(!is.character(versus)) versus.err() else if(length(versus) == 1 && nchar(versus) >= 2 && (substr(versus, 1, 2) == "b:" || substr(versus, 1, 2) == "B:")) { # use the basis matrix got.versus <- TRUE trim.which <- TRUE nversus <- 0 plotmo_bx <- plotmo_bx(object, trace, versus=substring(versus, 3)) # substring drops "bx:" versus.mat <- plotmo_bx$bx icolumns <- plotmo_bx$icolumns } if(!got.versus) { # user specified x variables trim.which <- TRUE prefix <- substr(versus, 1, 1) nversus <- 0 # following are needed if versus is a vector if(any(prefix == "*")) stop0("\"*\" is not allowed in this context in the 'versus' argument\n", " Your 'versus' argument is ", quote.with.c(versus)) versus.mat <- plotmo_x(object, trace) versus.mat <- as.matrix(versus.mat) colnames(versus.mat) <- gen.colnames(versus.mat, "x", "x", trace) icolumns <- check.index(versus, "versus", seq_len(NCOL(versus.mat)), colnames=colnames(versus.mat)) } if(trim.which) { # remove all entries from which except standard resid and abs resid plots org.which <- which which <- which[which %in% c(W3RESID,W5ABS)] if(length(which) == 0) warnf( "which=%s is now empty because plots were removed because versus=%s", paste.c(org.which, maxlen=50), paste.c(versus, maxlen=30)) } list(which = which, # which after possibly removing some plots versus.mat = versus.mat, # either fitted, response, x, or bx icolumns = icolumns, # desired column indices in versus.mat nversus = nversus) # versus as a number, 0 if versus is character } get.resids.xlim <- function(xlim, force.auto.resids.xlim, which, x, trans.versus, ylim, nversus, id.indices.specified) { if(force.auto.resids.xlim || !is.specified(xlim)) { # auto xlim? if(which == W9LOGLOG) { # don't show lower 5% of points quant <- quantile(trans.versus, probs=c(.05, 1), names=FALSE) min <- quant[1] max <- quant[2] # extra left margin so slope of linear fit not flattened if(min > .2 * ylim[1]) min <- .2 * ylim[1] xlim <- c(min, max) } else if(nversus == V4LEVER) # room for labels on high leverage points xlim <- c(0, 1.1 * max(x, na.rm=TRUE)) else xlim <- range1(x, na.rm=TRUE) range <- xlim[2] - xlim[1] if(id.indices.specified) # space for point labels xlim <- c(xlim[1] - .04 * range, xlim[2] + .04 * range) } stopifnot(is.numeric(xlim), length(xlim) == 2) fix.lim(xlim) } get.resids.ylim <- function(ylim, force.auto.resids.ylim, object, fitted, resids, which, info, standardize, id.indices.specified, center, pints, cints, scale, nversus) { if(force.auto.resids.ylim || !is.specified(ylim)) { # auto ylim? if(!is.null(pints)) { min <- min(resids, pints$lwr, na.rm=TRUE) max <- max(resids, pints$upr, na.rm=TRUE) } else if(!is.null(cints)) { min <- min(resids, cints$lwr, na.rm=TRUE) max <- max(resids, cints$upr, na.rm=TRUE) } else { min <- min(resids, na.rm=TRUE) max <- max(resids, na.rm=TRUE) } maxa <- mina <- 0 # adjustments to max and min if(which %in% (W5ABS:W8CUBE)) min <- 0 else if(which == W3RESID && center) { # want symmetric ylim so can more easily see asymmetry if(abs(min) > abs(max)) max <- -min else if(abs(max) > abs(min)) min <- -max } else if(which == W9LOGLOG) maxa <- .5 # more space on top, looks better range <- abs(max - min) if(id.indices.specified) { # space for point labels # TODO only do this if point labels are near the edges mina <- max(mina, .03 * range) maxa <- max(maxa, .03 * range) } if(nversus == V4LEVER && standardize && inherits(object, "lm")) { maxa <- max(maxa, maxa + .2 * range) # space for cook distance legend mina <- max(mina, mina + .1 * range) # space for "mean" label } if(info) { # space for extra text (on top) and density plot (in the bottom) maxa <- maxa + max * if(id.indices.specified) .2 else .1 mina <- mina + max * if(id.indices.specified) .2 else .1 } ylim <- c(min-mina, max+maxa) } fix.lim(ylim) } draw.pint.resids <- function(pints, x, shade, nversus, ...) { if(!is.null(pints)) { # abscissa must be ordered for polygon to work order <- order(x) x <- x[order] pints <- pints[order,] x <- if(nversus == V2INDEX) c(1:length(x), length(x):1) else trans.versus(c(x, rev(x)), 0) call.plot(graphics::polygon, PREFIX="level.", drop.shade=1, drop.shade2=1, force.x = x, force.y = trans.resids(c(pints$lwr, rev(pints$upr)), 0), force.col = shade, def.border = shade, def.lty = 0, ...) } } # this should be used only for models with homoscedastic errors draw.cook.levels <- function(object, ...) { cook.levels <- dota("cook.levels", DEF=c(0.5, 1.0), ...) stopifnot(is.numeric(cook.levels), all(cook.levels > 0)) col <- dota("cook.col", DEF="slategray4", ...) lty <- dota("cook.lty", DEF=1, ...) lwd <- dota("cook.lwd", DEF=1, ...) # based on code in stats::plot.lm.R leverage <- hatvalues1(object, "'standardize'") p <- length(coef(object)) leverage.range <- range(leverage, na.rm=TRUE) # though should never have NA x <- seq.int(0, 1, length.out=101) for(cook.level in cook.levels) { cl <- sqrt(cook.level * p *(1 - x) / x) lines(x, cl, col=col, lty=lty, lwd=lwd) lines(x, -cl, col=col, lty=lty, lwd=lwd) } # we don't use bottomleft like plot.lm because we may plot the density there usr <- par("usr") # xmin, xmax, ymin, ymax legend(usr[1]-.7 * strwidth("X"), # jam it into the corner usr[4]+.5 * strheight("X"), legend="Cook's distance", col=col, lty=lty, lwd=lwd, box.col="white", bg="white", x.intersp=.2, seg.len=1.5) xmax <- min(0.99, usr[2]) ymult <- sqrt(p * (1 - xmax) / xmax) axis(4, at=c(-sqrt(rev(cook.levels)) * ymult, sqrt(cook.levels)*ymult), labels=paste(c(rev(cook.levels), cook.levels)), mgp=c(.25,.15,0), las=2, tck=0, cex.axis=.7, col.axis=col, font=2) # makes the gray labels a bit more legible } # Plot points with unity leverage as stars. We plot them on # the axis, which is arguably incorrect but still useful. # TODO add a test for this to the test suite draw.bad.leverage.as.star <- function(x, rinfo, iresids, pt.cex, smooth.col) { which <- which(is.na(rinfo$scale[iresids])) if(length(which) > 0) { points(x[which], 0, col=1, cex=pt.cex[iresids], pch=8) # pch 8 is a star # add label if possible (not poss if not all points plotted, see npoints) if(length(iresids) == length(rinfo$scale)) { label <- which(is.na(rinfo$scale)) text.on.white(x=x[which], y=0, label=label, col=if(is.specified(smooth.col)) smooth.col else 2, cex=.8, adj=-.5, xpd=NA) } } } draw.smooth <- function(x, resids, scale, smooth.col, ...) { if(!is.specified(smooth.col)) return(NULL) # na.rm is needed if we take logs of nonpos, see check.that.most.are.positive. # That's why we calculate delta explicitly instead of using lowess default. delta <- .01 * diff(range1(x, na.rm=TRUE)) # Replace points with NA scale with 0 (else lowess stops at the NA). # Zero is appropriate because the points are 0 resids with leverage 1. resids[which(is.na(scale))] <- 0 # we use lowess rather than loess because loess tends to give warnings smooth.f <- dota("smooth.f loess.f", DEF=2/3, NEW=1, ...) smooth.iter <- dota("smooth.iter", DEF=3, ...) check.numeric.scalar(smooth.f) stopifnot(smooth.f > .01, smooth.f < 1) smooth <- lowess(x, resids, f=smooth.f, iter=smooth.iter, delta=delta) call.plot(graphics::lines.default, PREFIX="smooth.", drop.f=1, force.x = smooth$x, force.y = smooth$y, force.col = smooth.col, force.lwd = dota("smooth.lwd lwd.smooth lwd.loess", EX=c(0,1,1), DEF=1, NEW=1, ...), force.lty = dota("smooth.lty lty.smooth", EX=c(0,1), DEF=1, NEW=1, ...), ...) } derive.xlab <- function(xlab, which, colname.versus1, nversus) { if(is.specified(xlab)) { stopifnot.string(xlab, allow.empty=TRUE) if(!nzchar(xlab)) return("") } if(!is.specified(xlab)) xlab <- colname.versus1 stopifnot.string(xlab) if(which %in% (W7VLOG:W9LOGLOG)) xlab <- sprint("Log %s", xlab) if(nversus == V2INDEX) xlab <- sprint("%s index", xlab) xlab } derive.ylab <- function(ylab, which, rinfo.name) { if(is.specified(ylab)) { stopifnot.string(ylab, allow.empty=TRUE) if(!nzchar(ylab)) return("") } if(!is.specified(ylab)) ylab <- sprint("%ss", rinfo.name) if(which == W5ABS) ylab <- sprint("Abs %s", ylab) else if(which == W6SQRT) ylab <- sprint("Sqrt Abs %s", ylab) else if(which == W7VLOG) ylab <- sprint("Abs %s", ylab) else if(which == W8CUBE) ylab <- sprint("Cube Root Squared %s", ylab) else if(which == W9LOGLOG) ylab <- sprint("Log Abs %s", ylab) ylab } derive.main <- function(main, xlab, ylab, level, predict.s) # title of plot { # TODO should really use strwidth for newline calculation # The "Fitted" helps with limitations of the formula below newline <- xlab != "Fitted" && xlab != "Fitted index" && xlab != "Response" && nchar(ylab) + nchar(xlab) > 15 if(xlab == "Leverage" && ylab == "Residuals") # special case, mainly for which=1 with lm newline <- FALSE else if(grepl("Standardized", ylab[1]) || grepl("Delevered", ylab[1])) newline <- TRUE if(!is.specified(main)) { # generate a main only if user didn't specify main main <- sprint("%s vs%s%s", ylab, if(newline) "\n" else " ", xlab) if(!is.null(predict.s)) { # include the s argument that is used to make the model predictions if(is.character(predict.s)) # "lambda.1se" or "lambda.min" main <- sprint("%s (s=\"%s\")", main, predict.s) else if(is.numeric(predict.s)) { main <- sprint("%s (s=%s)", main, if(predict.s == 0) "0" else signif(predict.s,2)) } else warning0("predict.s has an unexpected class ", quotify(class(predict.s))) } } if(xlab != "Leverage" && level && !newline) # two newlines is too many main <- sprint("%s\n%g%% level shaded", main, 100*(level)) main } # plot resids of oof meanfit with col.cv (default lightblue) draw.oof.meanfit <- function(cv.oof.fit.tab, fitted, versus1, rinfo, which, col.cv, nversus) { # mean of each row of oof.fit.tab meanfit <- apply(cv.oof.fit.tab, 1, mean) meanfit <- rinfo$scale * (meanfit - fitted) order <- order(versus1) trans.versus1 <- trans.versus(versus1[order], which) x <- if(nversus == V2INDEX) 1:length(trans.versus1) else trans.versus1 lines(x, trans.resids(meanfit[order], which), col=col.cv) } draw.density.along.the.bottom <- function(x, den.col=NULL, scale=NULL, ...) { if(is.null(den.col)) den.col <- dota("density.col", DEF="gray57", EX=0, ...) den <- try(density(x, adjust=dota("density.adjust", DEF=.5, EX=0, ...), na.rm=TRUE), silent=TRUE) if(is.try.err(den)) warning0("draw.density.along.the.bottom: cannot determine density") else { usr <- par("usr") # xmin, xmax, ymin, ymax if(is.null(scale)) scale <- .08 / (max(den$y) - min(den$y)) den$y <- usr[3] + den$y * scale * (usr[4] - usr[3]) call.plot(graphics::lines.default, PREFIX="density.", drop.adjust=1, force.x=den, force.y=NULL, def.col=den.col, ...) } } draw.rlm.line <- function(which, versus1, resids, nversus, ...) { trans.resids <- trans.resids(resids, which) trans.versus <- trans.versus(versus1, which) x <- if(nversus == V2INDEX) 1:length(trans.versus) else trans.versus if(which == W9LOGLOG) { # ignore lower 10% of points (very small residuals i.e. very neg logs) quant <- quantile(trans.versus, probs=.1, na.rm=TRUE, names=FALSE) ok <- which(x > quant) x <- x[ok] trans.resids <- trans.resids[ok] } # # regression on 10 bootstrap samples so we can see variance of versus1 # for(i in 1:10) { # j <- sample.int(length(x), replace=TRUE) # trans.resids1 <- trans.resids[j] # trimmed.trans.fit1 <- x[j] # rlm <- MASS::rlm(trans.resids1~trimmed.trans.fit1, # method="MM", na.action="na.omit") # if(draw) # abline(coef(rlm), col="lightgray", lwd=.6) # } # robust linear regression of trans.resids on x # na.omit is needed if some versus1 (or resids) were nonpos so log(versus1) is NA rlm <- MASS::rlm(trans.resids~x, method="MM", na.action="na.omit") call.dots(abline, force.coef = coef(rlm), force.col = "lightblue", force.lwd = dota("smooth.lwd lwd.smooth lwd.loess", EX=c(0,1,1), DEF=1, NEW=1, ...) + 1, ...) box() # abline overplots the box coef(rlm) } draw.resids.info <- function(which, info, versus1, resids, nversus, rsq, coef.rlm, ...) { trans.versus <- trans.versus(versus1, which) x <- if(nversus == V2INDEX) 1:length(trans.versus) else trans.versus # TODO consider also drawing the density along the right side draw.density.along.the.bottom(x, ...) if(nversus != V4LEVER) { lm.text <- "" slope.text <- "" if(which == W5ABS || which == W9LOGLOG) { # added linear regression line? stopifnot(length(coef.rlm) == 2) slope.text <- sprint(" slope %.2g", coef.rlm[2]) } # exact=FALSE else get warning "Cannot compute exact p-value with ties" cor.abs <- cor.test(versus1, abs(resids), method="spearman", exact=FALSE) if(nversus == V3RESPONSE) { cor <- cor.test(versus1, resids, method="spearman", exact=FALSE) text <- sprint("spearman abs %.2f resids %.2f\n%s", cor.abs$estimate, cor$estimate, slope.text) } else if(which == W3RESID && nversus == V1FITTED) text <- sprint("rsq %.2f spearman abs %.2f", rsq, cor.abs$estimate) else text <- sprint("spearman abs %.2f%s", cor.abs$estimate, slope.text) cex <- .9 usr <- par("usr") # xmin, xmax, ymin, ymax text.on.white(x = usr[1] + strwidth("x", font=1), y = usr[4] - cex * (strheight(text, font=1) + .5 * strheight("X", font=1)), label = text, cex = cex, adj=c(0, 0), font=1, col=1, xpd=NA) } } my.log10 <- function(x) # log of very small values is silently set to NA { i <- which(x < max(x) / 1e6) x[i] <- 1 x <- log10(x) x[i] <- NA x } trans.versus <- function(versus, which) { if(which %in% (W7VLOG:W9LOGLOG)) my.log10(versus) else versus } trans.resids <- function(resid, which) # transform the residuals { if(which == W5ABS) abs(resid) else if(which == W6SQRT) sqrt(abs(resid)) else if(which == W7VLOG) abs(resid) else if(which == W8CUBE) { # do it in two steps so no problem with negative numbers resid <- resid^2 resid^(1/3) } else if(which == W9LOGLOG) my.log10(abs(resid)) else resid } # Get a subset of x. Size of subset is nsubset. Returns an index vector. # The subset includes the 20 biggest absolute values in x. # If you want more than the 20 biggest values, set nbiggest. get.isubset <- function(x, nsubset, nbiggest=0, use.all=FALSE, scale=NULL) { check.vec(x, "x passed to get.isubset", length(x)) ix <- seq_len(length(x)) if(nsubset > 0 && nsubset < length(x) && !use.all) { # TODO move this into caller # take a sample, but make sure it includes the 20 biggest absolute values nsubset <- min(nsubset, length(x)) nbiggest <- min(max(20, nbiggest), nsubset) isorted <- order(abs(x), decreasing=TRUE) # expensive ikeep <- seq_len(nbiggest) if(nsubset > nbiggest) ikeep <- c(ikeep, seq(from=nbiggest + 1, to=length(x), length.out=nsubset - nbiggest)) ix <- isorted[ikeep] # force in points with unity leverage if(!is.null(scale)) { which <- which(is.na(scale)) if(length(which) > 0) ix <- sort_unique(c(which, ix)) } } ix # index vector } # get the indices of the id.n biggest resids (requires a sort) get.id.indices <- function(resids, id.n, hatvalues=NULL) { # id.n has already been checked in plotres.data if(id.n == 0) return(NULL) if(id.n > 0) { # same as plot.lm i <- sort.list(abs(resids), decreasing=TRUE, na.last=NA) if(length(i) > id.n) i <- i[1:id.n] } else { # id.n is negative: most positive and most negative residuals id.n <- -id.n i <- sort.list(resids, decreasing=TRUE, na.last=NA) if(length(i) > id.n) i <- i[c(1:id.n, length(i) + 1 - (1:id.n))] } if(!is.null(hatvalues)) { # add the worst hatvalues i.e. the worst leverages i <- unique(c(i, order(hatvalues, decreasing=TRUE)[1:id.n])) } i } possible.plotres.legend <- function(which, level, smooth.col, oof.meanfit.was.plotted, ...) { # add legend, else red and blue may confuse the user legend.pos <- dota("legend.pos", DEF=NULL, ...) if(level && oof.meanfit.was.plotted && (is.null(legend.pos) || !all(is.na(legend.pos)))) { if(is.null(legend.pos)) { # auto? legend.x <- "bottomleft" legend.y <- NULL } else { # user specified legend position legend.x <- legend.pos[1] legend.y <- if(length(legend.pos) > 1) legend.pos[2] else NULL } legend.txt <- NULL legend.col <- NULL legend.lwd <- NULL legend.lty <- NULL if(which != W9LOGLOG && is.specified(smooth.col)) { # smooth plotted? legend.txt <- "smooth" legend.col <- smooth.col legend.lwd <- dota("smooth.lwd lwd.smooth lwd.loess", EX=c(0,1,1), DEF=1, NEW=1, ...) legend.lty <- 1 } if(oof.meanfit.was.plotted) { legend.txt <- c(legend.txt, "cross validated oof fit") legend.col <- c(legend.col, dota("col.cv", ...)) legend.lwd <- c(legend.lwd, 1) legend.lty <- c(legend.lty, 1) } if(!is.null(legend.txt)) call.dots(graphics::legend, DROP="*", KEEP="PREFIX", force.x = legend.x, force.y = legend.y, force.legend = legend.txt, def.col = legend.col, def.lwd = legend.lwd, def.lty = legend.lty, def.bg = "white", def.cex = .8, ...) } } plotmo/R/methods.R0000644000176200001440000002773214663771205013601 0ustar liggesusers# methods.R: plotmo method functions for miscellaneous objects plotmo.x.mars <- function(object, trace, ...) # mda package { # like plotmo.x.default but ignore object$x get.x.or.y(object, "x", trace, try.object.x.or.y=FALSE) } plotmo.type.bruto <- function(object, ..., TRACE) "fitted" plotmo.predict.bruto <- function(object, newdata, type, ..., TRACE) # mda package { # TODO fails: predict.bruto returned a response of the wrong length plotmo.predict.defaultm(object, newdata, type=type, ..., TRACE=TRACE) } plotmo.type.clm <- function(object, ..., TRACE) "prob" # ordinal package plotmo.predict.clm <- function(object, newdata, type, ..., TRACE) # ordinal package { as.data.frame(plotmo.predict.default(object, newdata, type=type, ..., TRACE=TRACE)) } plotmo.type.lars <- function(object, ..., TRACE) "fit" plotmo.predict.lars <- function(object, newdata, type, ..., TRACE) # lars package { # newx for predict.lars must be a matrix not a dataframe, # so here we use plotmo.predict.defaultm (not plotmo.predict.default) plotmo.predict.defaultm(object, newdata, type=type, ..., TRACE=TRACE)$fit } plotmo.predict.mvr <- function(object, newdata, type, ..., TRACE) # pls package { # the following calls predict.mvr y <- plotmo.predict.default(object, newdata, type=type, ..., TRACE=TRACE) dim <- dim(y) if(length(dim) == 3) { # type="response" returns a 3 dimensional array if(dim[2] != 1) stop0("multiple response models are not supported") y <- y[,1,] } y } plotmo.predict.quantregForest <- function(object, newdata, ..., TRACE) { # the following calls predict.quantregForest plotmo.predict.default(object, newdata, def.quantiles=.5, ..., TRACE=TRACE) } # plotmo.type.cosso works only if before calling plotmo # you manually do class(cosso.object) <- "cosso" plotmo.type.cosso <- function(object, ..., TRACE) "fit" # cosso package plotmo.predict.cosso <- function(object, newdata, type, ..., TRACE) { # xnew for predict.cosso must be a matrix not a dataframe, # so here we use plotmo.predict.defaultm (not plotmo.predict.default). # We default M so first time users can call plotmo easily. yhat <- plotmo.predict.defaultm(object, newdata, type=type, def.M=min(ncol(newdata), 2), ..., TRACE=TRACE) stopifnot(NCOL(yhat) == 1) # class(yhat) is "predict.cosso" but that chokes as.data.frame later class(yhat) <- "vector" yhat } plotmo.type.lda <- function(object, ..., TRACE) "class" plotmo.type.qda <- function(object, ..., TRACE) "class" plotmo.predict.lda <- function(object, newdata, type, ..., TRACE) # MASS package { # the following calls predict.lda yhat <- plotmo.predict.default(object, newdata, ..., TRACE=TRACE) get.lda.yhat(object, yhat, type, trace=0) } plotmo.predict.qda <- function(object, newdata, type, ..., TRACE) # MASS package { # the following calls predict.qda yhat <- plotmo.predict.default(object, newdata, ..., TRACE=TRACE) get.lda.yhat(object, yhat, type, trace=0) } # Special handling for MASS lda and qda predicted response, which # is a data.frame with fields "class", "posterior", and "x". # Here we use plotmo's type argument to choose a field. get.lda.yhat <- function(object, yhat, type, trace) { yhat1 <- switch(match.choices(type, c("class", "posterior", "response", "ld"), "type"), class = yhat$class, # default posterior = yhat$posterior, response = yhat$x, ld = { warning0("type=\"ld\" is deprecated for lda and qda models"); yhat$x }) if(is.null(yhat1)) { msg <- paste0( if(!is.null(yhat$x)) "type=\"response\" " else "", if(!is.null(yhat$class)) "type=\"class\" " else "", if(!is.null(yhat$posterior)) "type=\"posterior\" " else "") stop0("type=\"", type, "\" is not allowed for predict.", class(object)[1], ". ", if(nzchar(msg)) paste("Use one of:", msg) else "", "\n") } yhat1 } plotmo.type.varmod <- function(object, ..., TRACE) "se" plotmo.x.varmod <- function(object, trace, ...) { attr(object$parent, ".Environment") <- get.model.env(object$parent, "object$parent", trace) plotmo.x(object$parent, trace) } plotmo.y.varmod <- function(object, trace, naked, expected.len, nresponse, ...) { attr(object$residmod, ".Environment") <- get.model.env(object$residmod, "object$residmod", trace) plotmo.y(object$residmod, trace, naked, expected.len, nresponse) } order.randomForest.vars.on.importance <- function(object, x, trace) { importance <- object$importance colnames <- colnames(importance) if(!is.matrix(importance) || # sanity checks nrow(importance) == 0 || !identical(row.names(importance), colnames(x)) || is.null(colnames)) { warning0("object$importance is invalid") return(NULL) } colname <- if("%IncMSE" %in% colnames) # regression model: "%IncMSE" # importance=TRUE else if("IncNodePurity" %in% colnames) "IncNodePurity" # importance=FALSE else if("MeanDecreaseAccuracy" %in% colnames) # classification model: "MeanDecreaseAccuracy" # importance=TRUE else if("MeanDecreaseGini" %in% colnames) "MeanDecreaseGini" # importance=FALSE else { warning0("column names of object$importance are unrecognized") return(NULL) } if(trace > 0) printf("randomForest built with importance=%s, ranking variables on %s\n", if(colname == "%IncMSE" || colname == "MeanDecreaseAccuracy") "TRUE" else "FALSE", colname) # vector of var indices, most important vars first order(importance[,colname], decreasing=TRUE) } plotmo.singles.randomForest <- function(object, x, nresponse, trace, all1, ...) { importance <- order.randomForest.vars.on.importance(object, x, trace) if(all1) return(importance) if(is.null(importance)) seq_len(NCOL(x)) # all variables # 10 most important variables # (10 becauses plotmo.pairs returns 6, total is 16, therefore 4x4 grid) importance[seq_len(min(10, length(importance)))] } plotmo.pairs.randomForest <- function(object, x, ...) { if(is.null(object$forest)) stop0("object has no 'forest' component ", "(use keep.forest=TRUE in the call to randomForest)") importance <- order.randomForest.vars.on.importance(object, x, trace=FALSE) if(is.null(importance)) return(NULL) # choose npairs so a total of no more than 16 plots # npairs=5 gives 10 pairplots, npairs=4 gives 6 pairplots npairs <- if(length(importance) <= 6) 5 else 4 form.pairs(importance[1: min(npairs, length(importance))]) } possible.biglm.warning <- function(object, trace) { if(inherits(object, "biglm")) { n <- check.integer.scalar(object$n, min=1) y <- plotmo.y.default(object, trace, naked=TRUE, expected.len=NULL)$field if(NROW(y) != n) warnf("plotting %g cases but the model was built with %g cases\n", NROW(y), n) } } plotmo.predict.biglm <- function(object, newdata, type, ..., TRACE) # biglm package { # predict.biglm: newdata must include the response even though it isn't needed # The following extracts the response from the formula, converts it to a # string, then "nakens" it (converts e.g. "log(Volume)" to plain "Volume"). resp.name <- naken.collapse(format(formula(object)[[2]])) if(TRACE >= 1) printf("plotmo.predict.biglm: adding dummy response \"%s\" to newdata\n", resp.name) data <- data.frame(NONESUCH.RESPONSE=1, newdata) colnames(data) <- c(resp.name, colnames(newdata)) plotmo.predict.default(object, data, type=type, ..., TRACE=TRACE) } plotmo.predict.boosting <- function(object, newdata, # adabag package type="prob", newmfinal=length(object$trees), ...) { stopifnot(inherits(object, "boosting") || inherits(object, "bagging")) predict <- predict(object, newdata=newdata, newmfinal=newmfinal, ...) # adabag (version 4.0) returns a list, so use the type arg to select what we want # note that data.frames are lists, hence must check both below if(is.list(predict) && !is.data.frame(predict)) predict <- switch(match.arg(type, c("response", "votes", "prob", "class")), response = predict$prob, # plotmo default, same as prob votes = predict$votes, prob = predict$prob, class = predict$class) stopifnot(!is.null(predict), NROW(predict) == NROW(newdata)) predict } plotmo.predict.bagging <- function(object, newdata, # adabag package type="prob", newmfinal=length(object$trees), ...) { plotmo.predict.boosting(object, newdata=newdata, type=type, newmfinal=newmfinal, ...) } plotmo.predict.svm <- function(object, newdata, type, ..., TRACE) # package e1071 { # treat warnings as errors (to catch if user didn't specify # probability when building the model) old.warn <- getOption("warn") on.exit(options(warn=old.warn)) options(warn=2) predict <- plotmo.predict.default(object, newdata=newdata, ..., TRACE=TRACE) # no type arg probabilities <- attr(predict, "probabilities") decision.values <- attr(predict, "decision.values") if(!is.null(decision.values) && !is.null(probabilities)) stop0("predict.svm: specify either 'decision.values' or 'probability' (not both)") if(!is.null(decision.values)) # user specified decision.values decision.values else if(!is.null(probabilities)) # user specified probability probabilities else predict } plotmo.prolog.model_fit <- function(object, object.name, trace, ...) # parsnip package { # sanity check: that it is indeed a parnsip model if(!is.list(object[["spec"]]) || !is.list(object[["fit"]])) stop0("unrecognized \"model_fit\" object (was expecting a parsnip model)") # USE.SUBMODEL is an undocumented plotmo dots argument, default is TRUE # TODO this is supposed to be temporary solution use.submodel <- dota("USE.SUBMODEL", DEF=TRUE, ...) if(is.specified(use.submodel)) object$fit else object } # TODO Following commented out because polyreg is not supported by plotmo # So with this commented out we support plotmo(fda.object) # but not plotmo(fda.object$fit). # If it were not commented out, we would support neither. # # plotmo.singles.fda <- function(object, x, nresponse, trace, all1, ...) # { # trace2(trace, "Invoking plotmo_x for embedded fda object\n") # x <- plotmo_x(object$fit, trace) # plotmo.singles(object$fit, x, nresponse, trace, all1) # } # plotmo.pairs.fda <- function(object, x, nresponse, trace, all2, ...) # { # trace2(trace, "Invoking plotmo_x for embedded fda object\n") # x <- plotmo_x(object$fit, trace) # plotmo.pairs(object$fit, x, nresponse, trace, all2) # } # # Simple interface for the AMORE package. # # Thanks to Bernard Nolan and David Lorenz for these. # # Commented out so we don't have to include AMORE in plotmo's DESCRIPTION file. # # plotmo.x.MLPnet <- function(object, ...) # { # get("P", pos=1) # } # plotmo.y.MLPnet <- function(object, ...) # { # get("T", pos=1) # } # plotmo.predict.MLPnet <- function(object, newdata, type, ..., TRACE) # { # # the following calls AMORE::sim.MLPnet # plotmo.predict.default(object, newdata, func=AMORE::sim.MLPnet, ..., TRACE=TRACE) # } plotmo/R/singles.R0000644000176200001440000002043714663771205013575 0ustar liggesusers# singles.R: plotmo.singles and plotmo.pairs #------------------------------------------------------------------------------ # Return a vector of indices of predictors for degree1 plots, e.g, c(1,3,4). # The indices are col numbers in the x matrix. The caller will sort the # returned vector and remove duplicates. The default method simply # returns the indices of all predictors. The object specific methods # typically return only the predictors actually used in the model. # # Note on the x argument: # If the formula is resp ~ num + sqrt(num) + bool + ord:num + fac # then colnames(x) is num bool ord fac plotmo.singles <- function(object, x, nresponse, trace, all1, ...) { UseMethod("plotmo.singles") } plotmo.singles.default <- function(object, x, nresponse, trace, all1, ...) { seq_len(NCOL(x)) } #------------------------------------------------------------------------------ # Get the pairs of predictors to be displayed in degree2 plots. # Each row of the returned pairs matrix is the indices of two predictors # for a degree2 plot. Example (this was returned from plotmo.pairs.rpart): # # 1 2 # 1 2 # 2 1 # # The indices are col numbers in the x matrix. The caller will remove # duplicated pairs and re-order the pairs on the order of the predictors # in the original call to the model function. The above example will # become simply # # 1 2 # # It is ok to return NULL or a matrix with zero rows. plotmo.pairs <- function(object, x, nresponse=1, trace=0, all2=FALSE, ...) { UseMethod("plotmo.pairs") } # Predictors x1 and x2 are considered paired if they appear in # the formula in forms such as x1:x2 or I(x1*x2) or s(x1,x2) # # We use both formula(object) and attr(terms(object), "term.labels"). # formula(object) is necessary for gam formula like "s(x,v1)" because it # appears in attr(terms,"term.labels") as "x" "v1" (i.e. as unpaired). # But our rudimentary parsing of the formula is not reliable, so we also # use the term.labels. An lm formula like Volume~(Girth*Height2)-Height # has term.labels "Girth" "Height2" "Girth:Height2" plotmo.pairs.default <- function(object, x, nresponse, trace, all2, ...) { formula.vars <- NULL formula <- try(formula(object), silent=trace < 2) if(is.try.err(formula) || is.null(formula)) trace2(trace, "formula(object) failed for %s object in plotmo.pairs.default\n", class.as.char(object)) else { trace2(trace, "formula(object) returned %s\n", paste.trunc(format(formula), maxlen=100)) # Note that formula() returns a formula with "." expanded. # After as.character: [1] is "~", [2] is lhs, and [3] is rhs rhs <- as.character(formula(object))[3] # rhs of formula # Sep 2020: removed code below because a `var` may have a "-" in its name # if(grepl("\\-", rhs)) { # "-" in formula? # # formula() gives "(Girth + Height)-Height" for Volume~.-Height # rhs <- sub("\\-.*", "", rhs) # delete "-" and all after # rhs <- gsub("\\(|\\)", "", rhs) # delete ( and ) # } formula.vars <- unlist(strsplit(rhs, "+", fixed=TRUE)) formula.vars <- gsub("^ +| +$", "", formula.vars) # trim leading and trailing spaces trace2(trace, "formula.vars %s\n", quotify.trunc(formula.vars)) } term.labels <- NULL terms <- try(terms(object), silent=trace < 2) if(is.try.err(terms) || is.null(terms)) trace2(trace, "terms(object) failed for %s object in plotmo.pairs.default\n", class.as.char(object)) else { term.labels <- attr(terms, "term.labels") if(is.null(term.labels)) trace2(trace, "attr(terms,\"term.labels\") is NULL in plotmo.pairs.default\n") else trace2(trace, "term.labels %s\n", quotify.trunc(term.labels, maxlen=100)) } if(is.null(formula.vars) && is.null(term.labels)) return(NULL) plotmo_pairs_from_term_labels(c(formula.vars, term.labels), colnames(x), trace) } get.all.pairs.from.singles <- function(object, x, trace, all2) { singles <- plotmo.singles(object, x, nresponse=1, trace, all1=TRUE) if(length(singles) == 0) return(NULL) # no pairs (must be an intercept only model) if(any(is.na(singles))) { # We already issued warning0("NA in singles, will plot all variables") singles <- seq_len(NCOL(x)) # plot all pairs } singles <- unique(singles) if(all2 >= 2) { max <- 20 # note that 20 * 19 / 2 is 120 plots if(length(singles) > max) { warning0("too many predictors to plot all pairs,\n ", "so plotting degree2 plots for just the first ", max, " predictors.") singles <- singles[1:max] } } else { max <- 7 # note that 7 * 6 / 2 is 21 plots if(all2 && length(singles) > max) { warning0("too many predictors to plot all pairs,\n ", "so plotting degree2 plots for just the first ", max, " predictors.\n ", "Call plotmo with all2=2 to plot degree2 plots for up to 20 predictors.") singles <- singles[1:max] } } form.pairs(singles) } form.pairs <- function(varnames) # return a two column matrix, each row is a pair { col1 <- rep(varnames, times=length(varnames)) col2 <- rep(varnames, each=length(varnames)) pairs <- cbind(col1, col2) pairs[col1 != col2, , drop=FALSE] } # Given the term.labels, return a npairs x 2 matrix specifying which predictors # are paired. The elements in the returned matrix are column indices of x. # # This routine is not infallible but works for the commonly used formulas. # It works by extracting substrings in each term.label that looks like a # predictor pair. The following combos of x1 and x2 for example are # considered pairs: x1*x2, x1:x2, s(x1,x2), and similar. plotmo_pairs_from_term_labels <- function(term.labels, pred.names, trace, ...) { trace2(trace, "plotmo_pairs_from_term_labels\n") trace2(trace, "term.labels: %s\n", quotify.trunc(term.labels, maxlen=100)) trace2(trace, "pred.names: %s\n", quotify.trunc(pred.names, maxlen=100)) pairs <- matrix(0, nrow=0, ncol=2) # no pairs initially for(i in 1:length(term.labels)) { untouchable <- get.untouchable.for.naken(term.labels[i]) if(NROW(untouchable$replacements)) { # weird variable name (backquoted in formula handling) e.g. `sexmale*h(16-age)` # the gregexpr below won't work because of spaces etc. in the variable name warnf("Cannot determine which variables to plot in degree2 plots (use all2=TRUE?)\n Confused by variable name %s", quotify.trunc(term.labels[i])[1]) return(pairs) } s <- strip.space(term.labels[i]) s <- gsub("[+*/,]", ":", s) # replace + * / , with : s <- gsub("=[^,)]+", "", s) # delete "=any" # get the indices of expressions of the form "ident1:ident2" igrep <- gregexpr("[._$[:alnum:]]+:[._$[:alnum:]]+", s)[[1]] trace2(trace, "considering %s", s) if(igrep[1] > 0) for(i in seq_along(igrep)) { # extract the i'th "ident1:ident2" into pair start <- igrep[i] stop <- start + attr(igrep, "match.length")[i] - 1 pair <- substr(s, start=start, stop=stop) pair <- strsplit(pair, ":")[[1]] # pair is now c("ident1","ident2") # are the variables in the candidate pair in pred.names? ipred1 <- which(pred.names == pair[1]) ipred2 <- which(pred.names == pair[2]) trace2(trace, " ->%s%s", if(length(ipred1)) sprint(" %g=%s", ipred1, pred.names[ipred1]) else "", if(length(ipred2)) sprint(" %g=%s", ipred2, pred.names[ipred2]) else "") if(length(ipred1) == 1 && length(ipred2) == 1 && pair[1] != pair[2]) pairs <- c(pairs, ipred1, ipred2) } trace2(trace, "\n") } matrix(pairs, ncol=2, byrow=TRUE) } plotmo/R/call.dots.R0000644000176200001440000006706614663771205014025 0ustar liggesusers# call.dots.R: functions to handle prefixed dot arguments # # This file provides support for "prefixed" dot arguments. For example in # plotmo(), the user can specify predict.foo=3 as a dots argument. From # the prefix, plotmo recognizes that the argument is for predict, and # passes the argument to predict as foo=3. #----------------------------------------------------------------------------- # call.dots calls function FUNC with special processing of the dot arguments. # # It drops all args in dots matching DROP except those matching # PREFIX and FORMALS, then passes the remaining dot args to function FUNC. # By default FORMALS is the formal arguments of FUNC. # # If argname is prefixed with "force." then ignore any such arg in dots. # Any argname prefixed with "def." can be overridden by a user arg in dots. call.dots <- function( FUNC = NULL, # the function to call ..., PREFIX = NULL, # default NULL means no prefix DROP = "*", # default drops everything except args matching PREFIX KEEP = "PREFIX", TRACE = 0, # for debugging FNAME = if(is.character(FUNC)) FUNC else trunc.deparse(substitute(FUNC)), FORMALS = NULL, # formal args of FUNC (NULL means get automatically, but # can't always do that because because CRAN doesn't allow :::) SCALAR = FALSE, # see argument "scalar" in eval.dotlist CALLARGS = NULL, CALLER = NULL) { stopifnot(is.logical(TRACE) || is.numeric(TRACE), length(TRACE) == 1) TRACE <- as.numeric(TRACE) if(TRACE >= 2) { if(is.null(CALLER)) CALLER <- callers.name() printf("%s invoked call.dots\n", CALLER) } if(is.null(CALLARGS)) CALLARGS <- callargs(call.dots) args <- deprefix(FUNC=FUNC, PREFIX=PREFIX, ..., DROP=DROP, KEEP=KEEP, TRACE=TRACE, FNAME=FNAME, FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=CALLARGS) do.call.trace(FUNC, args, FNAME, trace=TRACE) } # A version of call.dots specialized for calling plotting functions. # This drops all args in dots except those matching PREFIX and PLOT.ARGS. call.plot <- function( FUNC = NULL, # same as call.dots ..., PREFIX = NULL, # if not specified, match only PLOT.ARGS TRACE = 0, # same as call.dots FORMALS = NULL, # same as call.dots SCALAR = FALSE) # same as call.dots { fname <- trunc.deparse(substitute(FUNC)) callargs <- callargs(call.plot) caller <- callers.name() # function that invoked call.plot call.dots(FUNC=FUNC, PREFIX=PREFIX, ..., DROP="*", # drop everything KEEP="PREFIX,PLOT.ARGS", # except args matching PREFIX and PLOT.ARGS TRACE=TRACE, FNAME=fname, FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=callargs, CALLER=caller) } deprefix <- function( FUNC = NULL, ..., PREFIX = NULL, DROP = NULL, KEEP = NULL, TRACE = 0, FNAME = if(is.character(FUNC)) FUNC else trunc.deparse(substitute(FUNC)), FORMALS = NULL, SCALAR = FALSE, CALLARGS = NULL) { stopifnot(is.logical(TRACE) || is.numeric(TRACE), length(TRACE) == 1) TRACE <- as.numeric(TRACE) if(!is.null(FUNC)) match.fun(FUNC) # check that FUNC is available and is a function FNAME <- init.fname(FNAME, FUNC, TRACE) higher.caller <- higher.caller.to.deprefix(..., FNAME=FNAME) PREFIX <- init.prefix(PREFIX, FUNC, FNAME) if(is.null(CALLARGS)) CALLARGS <- callargs(deprefix) DROP <- expand.drop(DROP, PREFIX, FUNC, FORMALS) KEEP <- expand.drop(KEEP, PREFIX, FUNC, FORMALS, namedrop="KEEP", callargs=CALLARGS, include.standard.prefixes=TRUE) dots <- match.call(expand.dots=FALSE)$... trace.prolog(TRACE, PREFIX, DROP, KEEP, dots, higher.caller) stopif.unnamed.dot(dots, higher.caller, ...) org.dots <- dots if(!is.null(DROP)) dots[grep(DROP, names(dots))] <- NULL stopifnot(!is.null(KEEP)) for(name in names(org.dots)) if(grepl(KEEP, name)) dots[[name]] <- org.dots[[name]] trace.after.dropkeep(TRACE, dots) args <- deprefix.aux(FUNC, dots, PREFIX, FNAME, FORMALS, TRACE) # workhorse eval.dotlist(args, n=2, scalar=SCALAR) # n=2 for caller of deprefix e.g. call.dots } deprefix.aux <- function(func, dots, prefix, fname, formals, trace) # workhorse { force <- "^force\\." # "force." as a regex def <- "^def\\." # "def." as a regex # change prefix to a regex, "plot." becomes "^plot\." prefix <- paste0("^", gsub(".", "\\.", prefix, fixed=TRUE)) groups <- list() # list with three elements: force, prefix, def args for(pref in c(force, prefix, def)) { # put args matching pref into group, with the prefix pre removed which <- grep(pref, names(dots)) # select only args matching pref group <- dots[which] # put them into the group group <- expand.dotnames(group, pref, func, fname, formals) names(group) <- sub(pref, "", names(group)) # remove prefix groups[[pref]] <- group dots[which] <- NULL # remove args in this group from dots } # dots is now just those arguments which did not have a special prefix dots <- expand.dotnames(dots, prefix="", func, fname) # "" matches anything args <- groups[[def]] # "def." args lowest precedence args <- merge.list(args, dots) # next come remaining dots args <- merge.list(args, groups[[prefix]]) args <- merge.list(args, groups[[force]]) # "force." args overrule all others args <- drop.args.prefixed.with.drop(args) order.args(args, trace) } # Argument names for plot functions. We exclude "overall" par() args like # mfrow that shouldn't be included when calling functions like plot(), # lines(), or text(). # # If specified in a DROP or KEEP string, the actual argument must exactly # match the PLOT.ARGS argument to be dropped or kept --- abreviated actual # args won't be matched (otherwise we would match too much, e.g. an actual # arg "s" would match "srt"). PLOT.ARGS <- c("add", "adj", "bty", "cex", "cex.axis", "cex.lab", "cex.main", "cex.sub", "col", "col.axis", "col.lab", "col.main", "col.sub", "crt", "family", "font", "font", "font.axis", "font.lab", "font.main", "font.sub", "lend", "ljoin", "lmitre", "lty", "lwd", "main", "pch", "srt", "xaxp", "xaxs", "xaxt", "xlab", "xlim", "xlog", "xpd", "yaxp", "yaxs", "yaxt", "ylab", "ylim", "ylog") # Arguments for par(). This list includes all par arguments except # readonly arguments (e.g. cin) and unimplemented arguments (e.g. err). # The actual argname must be an exact match to be recognized (no abbreviations). # Following omitted because they change too much: col, lwd PAR.ARGS <- c("adj", "ann", "ask", "bg", "bty", "cex", "cex.axis", "cex.lab", "cex.main", "cex.sub", "col.axis", "col.lab", "col.main", "col.sub", "crt", "err", "family", "fg", "fig", "fin", "font", "font.axis", "font.lab", "font.main", "font.sub", "lab", "las", "lend", "lheight", "ljoin", "lmitre", "lty", "mai", "mar", "mex", "mfcol", "mfg", "mfrow", "mgp", "mkh", "new", "oma", "omd", "omi", "pch", "pin", "plt", "ps", "pty", "srt", "tck", "tcl", "usr", "xaxp", "xaxs", "xaxt", "xlog", "xpd", "yaxp", "yaxs", "yaxt", "ylbias", "ylog") # Arguments for par() which take a vector value (i.e. length of value is not one). PAR.VEC <- c("fig", "fin", "lab", "mai", "mar", "mfcol", "mfg", "mfrow", "mgp", "oma", "omd", "omi", "pin", "plt", "usr", "xaxp", "yaxp") # Arguments that are used for subplots in plotmo and similar programs. # # Useful for dropping all args that could conceivably be plotting # arguments and will never(?) be a predict() or residuals() argument. # # When "PLOTMO.ARGS" is used in a DROP string, any actual arg _prefixed_ # with any of these is dropped (as opposed to PLOT.ARGS and PAR.ARGS we drop # actual argnames that _exactly_ match argnames in PLOT.ARGS and PAR.ARGS). # # "nresiduals", is for back compat with old versions of plot.earth PLOTMO.ARGS <- c( "caption.", "cex.", "col.", "contour.", "cum.", "degree1.", "degree2.", "density.", "filled.contour.", "font.", "func.", "grid.", "heatmap.", "image.", "jitter.", "legend.", "label.", "level.", "line.", "lines.", "lty.", "lty.", "lwd.", "main.", "mtext.", "nresiduals", "par.", "pch.", "persp.", "plot.", "plotmath.", "prednames.", "qq.", "qqline.", "pt.", "response.", "rug.", "smooth.", "text.", "title.", "vfont.") # from now on in this module function defs are in alphabetic order add.formals.to.drop <- function(drop, func, formals, namedrop) { stopifnot(grepl("FORMALS", drop)) if(is.null(func)) stop0("\"FORMALS\" specified in ", namedrop, ", but FUNC is NULL") formals <- merge.formals(func, formals, must.exist=TRUE) formals <- paste0(formals, collapse=",") # vector to string drop <- sub("FORMALS[,]", "", drop) # remove "FORMALS," from drop paste.drop(">FORMALS", formals, drop) # add the formal args } # Return the names of the actual args passed to the caller of this function, # ignoring args matching formals of the caller and ignoring dots. # # For example, for call.dots(foo, PREFIX="anything", x=1, y=1, ...), this # function returns c("x", "y"), because x and y are in the argument list # in the call to call.dots but don't match any of the formals of call.dots # (as PREFIX does). The "..." is ignored. # TODO if these were forced we wouldn't need the force.argument callargs <- function(func) { # names of arguments passed to the func that invoked callargs # args passed in dots will not appear in names names <- names(sys.call(-1)) names <- names[names != ""] # drop unnamed args # drop formal arguments (typically PREFIX, KEEP, etc.) names[!(names %in% names(formals(func)))] } # return string "a,b,c,d,e" if given c("a", "b,c", "d e") # i.e. white space converted to comma, c() collapsed to single string canonical.drop <- function(drop, namedrop) { drop <- gsub(" +|,+", ",", drop) # convert space or multi commas to comma drop <- gsub("^,+|,+$", "", drop) # drop leading and trailing commas drop <- unlist(strsplit(drop, split=",")) # convert to a vector drop <- paste0(drop, collapse=",") # collapse stopifnot.identifier(drop, namedrop, allow.specials=TRUE) drop } # TODO add this check elsewhere in earth and plotmo too check.regex <- function(s) # check for some common regex errors { if(grepl("||", s, fixed=TRUE)) stop0("\"||\" in following regex matches everything:\n", "\"", s, "\"") if(grepl("^\\|", s)) stop0("\"|\" at the start of the following regex matches everything:\n", "\"", s, "\"") if(grepl("\\|$", s)) stop0("\"|\" at the end of the following regex matches everything:\n", "\"", s, "\"") } # convert drop to a regex, "x,y*,prefix." becomes "^x|^y.*|^prefix\." convert.drop.to.regex <- function(drop) { drop <- gsub(",", "|", drop) # change comma to | drop <- gsub(".", "\\.", drop, fixed=TRUE) # escape period, "plot." becomes "plot\." drop <- gsub("*", ".*", drop, fixed=TRUE) # change * to .* # clean up, for example we now may have "||" in drop which must be changed to "|" for(iter in 1:2) { # two iterations seems sufficient in practice drop <- gsub(" +", "", drop) # delete spaces drop <- sub("^\\|", "", drop) # delete | at at start drop <- sub("^\\|", "", drop) # delete | at at end drop <- gsub("^^", "^", drop, fixed=TRUE) # change ^^ to single ^ drop <- gsub("||", "|", drop, fixed=TRUE) # change || to | } # prepend ^ to match prefixes only, "x|y" becomes "^x|^y" drop <- unlist(strsplit(drop, split="|", fixed=TRUE)) drop <- ifelse(substr(drop, 1, 1) == ">", drop, paste0("^", drop)) drop <- paste0(drop, collapse="|") check.regex(drop) # sanity check for some common regex errors drop } # TODO add to test suite (although this is tested implicitly in the plotmo tests) # what happens if the argname is abbreviated and no formals to match against? drop.args.prefixed.with.drop <- function(args) { for(name in names(args)) if(grepl("^drop\\.", name)) { check.integer.scalar(args[[name]], logical.ok=FALSE, object.name=name) if(args[[name]] != 1) stop0(name, "=1 is not TRUE") args[[name]] <- NULL # drop the drop.xxx argument itself name <- sub("drop.", "", name, fixed=TRUE) # delete "drop." from name # TODO allow dropping if just the prefix of name matches name <- paste0("^", name, "$") # turn it into a regex for exact matching args[grep(name, names(args))] <- NULL # drop args that exactly match name } args } # Only dot names that have the given prefix are considered. Expand the # suffix of each of those dot names to its full formal name using the # standard R argument matching rules. # # Example: with prefix = "persp." and func = persp.default, # "persp.sh" in dots gets expanded to "persp.shade", because # "shade" is the full name of an argument of persp.default. # # Among other things, This makes it possible for deprefix to properly # process two actual argument names that are different but both match # the same formal argument name. # # It also helps prevent downstream name aliasing issues, because here we # can pre-emptively check for argname matching problems, and issue clearer # error messages than the standard R arg matching error messages. expand.dotnames <- function( dots, prefix, # a regex, not a plain string func = NULL, # if NULL then we just check for duplicate args and go home fname, # used only in error messages formals = NULL) # manual additions to the formal arg list of func { stopifnot(is.list(dots)) dot.names <- names(dots) matches <- grep(prefix, dot.names) # indices of arg which match prefix if(length(matches) == 0) return(list()) if(is.null(func)) { duplicated <- which(duplicated(dot.names)) if(length(duplicated)) stop0("argument '", dot.names[duplicated[1]], "' for ", fname, "() is duplicated") return(dots[matches]) } # match against the formal arguments of func stopifnot(!is.null(dot.names)) unexpanded.names <- dot.names formals <- merge.formals(func, formals) for(idot in matches) { # for all arguments which match prefix dot.name <- dot.names[idot] stopifnot(nzchar(dot.name)) raw.prefix <- "" raw.dotname <- dot.name if(nzchar(prefix)) { # strip off the prefix substring in dot.name (we will put it back later) start <- regexpr(prefix, dot.name) stopifnot(start == 1) # prefix matches only prefixes stop <- start + attr(start, "match.length") stopifnot(stop > start) raw.prefix <- substr(dot.name, start=start, stop=stop-1) # as string not regex raw.dotname <- substring(dot.name, first=stop) # dotname with prefix removed } match <- charmatch(raw.dotname, formals) if(anyNA(match)) { # No match, not necessarily a problem assuming FUNC has a dots formal arg. # We will allow FUNC to check for itself later (if someone calls it). NULL } else if(match == 0) { # multiple matches matches <- grep(paste0("^", raw.dotname), formals) stopifnot(length(matches) >= 2) stop0("'", raw.dotname, "' matches both the '", formals[matches[1]], "' and '", formals[matches[2]], "' arguments of ", fname, "()") } else # single match, this is the ideal situation dot.names[idot] <- paste0(raw.prefix, formals[match]) # prepend prefix } stopifnot.expanded.dotnames.unique(dot.names, unexpanded.names, fname, formals, prefix) names(dots) <- dot.names dots } # returned the expanded the drop argument as a regex expand.drop <- function(drop, prefix, func, formals=NULL, # manual additions to the formal arg list of func namedrop="DROP", callargs=NULL, include.standard.prefixes=FALSE) { if(is.null(drop)) { if(include.standard.prefixes) return(paste0("^force.|^def.|^", prefix)) else return(NULL) } drop <- canonical.drop(drop, namedrop) if(drop == "*") return(".*") # regex to match everything # TODO following is helpful in the trace print only if # you put special identifiers AFTER the other identifiers drop <- paste.drop(">EXPLICIT", drop, "") if(length(callargs) > 0) drop <- paste.drop(">CALLARGS,", paste0(callargs, "$", collapse=","), drop) if(include.standard.prefixes) { drop <- sub("PREFIX", "", drop) # delete "PREFIX" from drop, if present drop <- paste.drop(">PREFIX,", prefix, drop) drop <- paste.drop(">STANDARDPREFIXES,", "force.,def.,drop.", drop) } else drop <- paste.drop(">PREFIX,", sub("PREFIX", prefix, drop), "") if(grepl("FORMALS", drop)) drop <- add.formals.to.drop(drop, func, formals, namedrop) temp <- paste.drop(">PLOT_ARGS,", paste0(PLOT.ARGS, "$", collapse=","), "") drop <- sub("PLOT.ARGS", temp, drop) temp <- paste.drop(">PAR_ARGS,", paste0(PAR.ARGS, "$", collapse=","), "") drop <- sub("PAR.ARGS", temp, drop) temp <- paste.drop(">PLOTMO_ARGS,", paste0(PLOTMO.ARGS, collapse=","), "") drop <- sub("PLOTMO.ARGS", temp, drop) convert.drop.to.regex(drop) # convert drop to a regex } higher.call.args <- function(..., CALLX, FNAME) { stopifnot(is.list(CALLX)) CALLX[1] <- NULL # remove fname from CALLX if(CALLX[length(CALLX)] == "...") # remove dots from CALLX CALLX[length(CALLX)] <- NULL args <- eval.dotlist(as.list(CALLX)) # add dots to args, if they are not already in args dots <- as.list(match.call(expand.dots=FALSE)$...) arg.names <- names(args) dot.names <- names(dots) for(i in seq_along(dots)) { if(!(dot.names[i] %in% arg.names)) { list <- list(eval(dots[[i]])) names(list) <- dot.names[i] args <- append(args, list) } } args[[1]] <- as.name(FNAME) list.as.char(args) } # used only for tracing and error messages # TODO simplify this and friends when match.call is working (R 3.2.0) higher.caller.to.deprefix <- function(..., FNAME=FNAME) { # search the stack looking for org caller of prefix e.g. call.plot sys.calls <- sys.calls() ncalls <- length(sys.calls) stopifnot(ncalls > 2) higher.fname <- "FUNC" try.was.used <- FALSE for(i in max(ncalls-10, 1) : ncalls) { fname <- paste(sys.calls[[i]][1]) # TODO is [1] in the correct position? if(grepl("^call\\.|^deprefix", fname)) break if(grepl("^doTry|^try", fname)) try.was.used <- TRUE else higher.fname <- fname } call <- as.list(sys.calls[[i]]) fname <- paste(call[[1]]) if(try.was.used) higher.fname <- paste0(higher.fname, " via try ") # use try here for paranoia args <- try(higher.call.args(..., CALLX=call, FNAME=FNAME), silent=TRUE) if(is.try.err(args)) args <- sprint("%s, ...", FNAME) sprint("%s called %s(%s)", higher.fname, fname, args) } init.fname <- function(FNAME, FUNC, TRACE) { # check deparse(substitute(FUNC)) issued a good function name # e.g. FNAME will be "NULL" if FUNC is NULL if(is.null(FNAME) || length(FNAME) != 1 || FNAME == "NULL") FNAME <- "FUNC" stopifnot.string(FNAME) FNAME <- sub(".*:+", "", FNAME) # graphics::lines becomes lines stopifnot.identifier(FNAME, "FNAME") FNAME } init.prefix <- function(PREFIX, FUNC, FNAME) { if(is.null(PREFIX)) { # automatic prefix, so check that we can generate it safely if(is.null(FUNC)) stop0("PREFIX must be specified when FUNC is NULL") PREFIX <- sub("\\..*$", "", FNAME) # lines.default becomes lines # Was deprefix invoked using FUNC=FUNC or in a try block? # This won't catch all cases of FUNC=unusable.name but it helps # The stopifnot.identifier() below also helps. if(PREFIX %in% c("FUNC", "doTryCatch")) stop0("PREFIX must be specified in this context ", "(because FNAME is \", fname, \")") PREFIX <- paste0(PREFIX, ".") # add a period stopifnot.identifier(PREFIX, "the automatically generated PREFIX") } stopifnot.identifier(PREFIX, "PREFIX", allow.empty=TRUE) if(PREFIX == "") PREFIX <- ">NOPREFIX" # no argname can match this PREFIX } # return a char vector: formal() of func plus names in manform # manform is manually specified formals merge.formals <- function(func, manform, must.exist=FALSE) { formals <- names(formals(func)) if(!is.null(manform)) formals <- c(formals, strsplit(canonical.drop(manform, "manform"), ",")[[1]]) if(must.exist) { if(length(formals) == 0) stop0("\"FORMALS\" specified but formals(FUNC) ", "returned no formal arguments") if(length(formals[formals != "..."]) == 0) stop0("\"FORMALS\" specified but formals(FUNC) returned only \"...\"") } formals <- formals[formals != "..."] # drop arg named "..." in formals, if any sapply(formals, stopifnot.identifier) # check that all names are valid unique(formals) } # Put the "anon" args first in the argument list. # Then put args named "object", "x", etc. at the front of the list # (after the anon args if any). This is necessary because all the # manipulation we have done has sadly done some reordering of the args # (meaning that the order of the args supplied to call.dots is only # partially retained). The names object, x, etc. are usually what we want # at the start for the predict and plot functions used with call.dots. order.args <- function(args, trace) { trace2(trace, "return dotnames ") if(length(args)) { # order anonymous args on their names, then delete their names which <- which(grepl("^anon", names(args))) anon <- args[which] # select args with "anon." prefix args[which] <- NULL # remove them from the arg list anon <- anon[order(names(anon))] # order them on their names trace2(trace, "%s", paste0(names(anon), collapse=" ")) names(anon) <- NULL # delete their names args1 <- anon # anon args go first in the arg list # Put arguments named "object", "x", etc. first (after anon args if any). # We want mfrow and mfcol early so subsequent args like cex have the last say. for(argname in c("object", "x", "y", "type", "main", "xlab", "ylab", "mfrow", "mfcol")) { args1[[argname]] <- args[[argname]] args[[argname]] <- NULL # remove from args } args <- append(args1, args) # append remaining args to the list if(trace >= 2) cat0(paste.collapse(names(args)), "\n") } trace2(trace, "\n") args } # paste.drop("prefix", "", drop) returns "prefix,DROP" # paste.drop("prefix", "x", drop) returns "prefix,x,DROP," # paste.drop("prefix", "x,y", drop) returns "prefix,x,y,DROP," # paste.drop("prefix", c("x","y"), drop) returns "prefix,x,y,DROP," paste.drop <- function(prefix, s, drop) { s <- paste(s, collapse=",") if(nzchar(s)) paste0(prefix, ",", s, ",", drop) else paste0(prefix, ",", drop) } stopif.unnamed.dot <- function(dots, higher.caller, ...) # called from deprefix() { which <- which(names(dots) == "") if(length(which)) { call <- sprint("\n %s\n", paste0(strwrap(higher.caller, width=getOption("width"), exdent=10), collapse="\n")) dot <- dots[[ which[1] ]] env <- parent.frame(2) arg <- try(eval(dot, envir=env, enclos=env), silent=TRUE) if(is.try.err(arg)) # fallback to weaker error message "(argument ..1 is unnamed)" stop0("Unnamed arguments are not allowed here", " (argument ", as.char(dot), " is unnamed)", call) else stop0("Unnamed arguments are not allowed here", "\n The argument's value is ", as.char(arg), call) } } stopifnot.expanded.dotnames.unique <- function(expanded.names, unexpanded.names, fname, formals, prefix) { duplicated <- which(duplicated(expanded.names)) if(length(duplicated) == 0) return() # no duplicates if(is.null(formals)) stop0("argument '", unexpanded.names[duplicated[1]], "' for ", fname, "() is duplicated") else { # a little processing is needed because we want to report the # error using the unexpanded.names, not the expanded names # get the index of the duplicated argument's twin duplicated <- duplicated[1] for(twin in 1:duplicated) if(expanded.names[twin] == expanded.names[duplicated]) break stopifnot(twin < duplicated) # get the formal argument matched by the duplicated arguments match <- charmatch(sub(prefix, "", expanded.names[duplicated]), formals) if(anyNA(match)) # Dot args are duplicated, but don't match any formal arg. Probably # because e.g. force.xlab is specified but force.xlab is also passed # in dots to call.dots (an error in the way call.dots is invoked). stop0("argument '", unexpanded.names[duplicated[1]], "' for ", fname, "() is duplicated") else if(unexpanded.names[twin] == unexpanded.names[duplicated]) # dot args are identical and they both match the formal stop0("argument '", unexpanded.names[duplicated[1]], "' for ", fname, "() is duplicated") else # dot args are not identical but both match the formal stop0("'", unexpanded.names[twin], "' and '", unexpanded.names[duplicated], "' both match the '", formals[match[1]], "' argument of ", fname, "()") } } trace.after.dropkeep <- function(trace, dots) { if(trace >= 2) printf("after DROP and KEEP %s\n", paste.collapse(names(dots))) } trace.prolog <- function(trace, prefix, drop, keep, dots, higher.caller) { if(trace >= 2) { printf.wrap("TRACE %s", higher.caller) printf("\nPREFIX %s\n", prefix) printf("DROP %s\n", if(is.null(drop)) "NULL" else gsub("\\|>", "\n >", drop)) printf("KEEP %s\n", if(is.null(keep)) "NULL" else gsub("\\|>", "\n >", keep)) names <- names(dots) names[which(names=="")] <- "UNNAMED" printf("input dotnames %s\n", paste.collapse(names)) } } plotmo/R/bx.R0000644000176200001440000000361614664207557012547 0ustar liggesusers# bx.R: plotres functions for accessing a model's basis matrix # TODO turn this into a method function plotmo_bx <- function(object, trace, msg, versus) { if(inherits(object, "mars") || inherits(object, "earth")) { if(inherits(object, "mars")) bx <- object[["x"]] else bx <- object[["bx"]] if(is.null(bx) || NCOL(bx) == 0) stopf("versus=\"b:\": no basis matrix for this %s object", class.as.char(object, quotify=TRUE)) else if(NCOL(bx) == 1) { # intercept only? bx <- bx icolumns <- 1 } else { bx <- bx[, -1, drop=FALSE] # drop the intercept if(is.null(colnames(bx))) # mars model? colnames(bx) <- paste0("bx", seq_len(NCOL(bx))) icolumns <- check.index(versus, "versus", seq_len(NCOL(bx)), colnames=colnames(bx)) } } else if(inherits(object, "Gam") || # package gam version 1.15 or higher # the additive.predictors check below is to ensure mda:gam (not mgcv:gam) # (applies only to package gam version less than 1.15) (inherits(object, "gam") && !is.null(object[["additive.predictors"]]))) { bx <- model.matrix(object) if(is.null(bx) || NCOL(bx) == 0) stopf("versus=\"b:\": model.matrix(object) for this %s object returned NULL", class.as.char(object, quotify=TRUE)) else if(NCOL(bx) == 1) { # intercept only? bx <- bx icolumns <- 1 } else { bx <- bx[, -1, drop=FALSE] # drop the intercept icolumns <- check.index(versus, "versus", seq_len(NCOL(bx)), colnames=colnames(bx)) } } else stopf("versus=\"b:\" is not supported for this %s object", class.as.char(object, quotify=TRUE)) list(bx=bx, icolumns=icolumns) } plotmo/R/plotres.R0000644000176200001440000002506214663771205013620 0ustar liggesusers# plotres.R: plot model residuals # values for which W1 <- 1 # model selection W2CUM <- 2 # cumulative distribution W3RESID <- 3 # residuals vs fitted W4QQ <- 4 # qq plot W5ABS <- 5 # abs residuals vs fitted W6SQRT <- 6 # sqrt abs residuals vs fitted W7VLOG <- 7 # abs residuals vs log fitted W8CUBE <- 8 # cube root of the squared residuals vs log fitted W9LOGLOG <- 9 # log abs residuals vs log fitted # values for vs V1FITTED <- 1 # fitted V2INDEX <- 2 # obs number V3RESPONSE <- 3 # response V4LEVER <- 4 # leverages plotres <- function(object = stop("no 'object' argument"), which = 1:4, info = FALSE, versus = 1, standardize = FALSE, delever = FALSE, level = 0, id.n = 3, labels.id = NULL, smooth.col = 2, grid.col = 0, jitter = 0, do.par = NULL, caption = NULL, trace = 0, npoints = 3000, center = TRUE, type = NULL, # passed to predict nresponse = NA, object.name = quote.deparse(substitute(object)), ...) # passed to predict { init.global.data() on.exit({init.global.data(); gc()}) # release memory on exit object # make sure object exists trace <- as.numeric(check.integer.scalar(trace, logical.ok=TRUE)) use.submodel <- dota("USE.SUBMODEL", DEF=TRUE, ...) # undoc arg (for parsnip models) use.submodel <- is.specified(use.submodel) # Associate the model environment with the object. # (This is instead of passing it as an argument to plotmo's data access # functions. It saves a few hundred references to model.env in the code.) object.env <- get.model.env(object, object.name, trace, use.submodel) ret <- plotmo_prolog(object, object.name, trace, ...) object <- ret$object # the original object or a submodel (parsnip) my.call <- ret$my.call attr(object, ".Environment") <- object.env if(!is.numeric(which) || !is.vector(which) || anyNA(which) || any(which != floor(which)) || any(which < 1) || any(which > W9LOGLOG)) { which.err() } info <- check.boolean(info) standardize <- check.boolean(standardize) delever <- check.boolean(delever) level <- check.level.arg(level, zero.ok=TRUE) smooth.col <- get.smooth.col(smooth.col, ...) grid.col <- dota("col.grid", DEF=grid.col, ...) if(is.specified(grid.col) && is.logical(grid.col) && grid.col) # grid.col=TRUE grid.col <- "lightgray" check.integer.scalar(nresponse, min=1, na.ok=TRUE, logical.ok=FALSE, char.ok=TRUE) temp <- get.plotres.data(object, object.name, which, standardize, delever, level, versus, id.n, labels.id, trace, npoints, type, nresponse, ..., must.get.rsq=info || trace >= 1) # get rsq only if necessary nresponse <- temp$nresponse # col index in the response (converted from NA if necessary) resp.name <- temp$resp.name # used only in automatic caption, may be NULL type <- temp$type # always a string (converted from NULL if necessary) rinfo <- temp$rinfo # resids, scale, name, etc. vinfo <- temp$vinfo # versus.mat, icolumns, nversus, etc. fitted <- temp$fitted # n x 1 numeric matrix, colname is "Fitted" which <- temp$vinfo$which # plots we don't want will have been removed id.n <- temp$id.n # forced to zero if row indexing changed npoints <- temp$npoints # special values have been converted rsq <- temp$rsq # r-squared on the training data possible.biglm.warning(object, trace) nfigs <- length(which) * length(vinfo$icolumns) if(nfigs == 0) { if(trace >= 0) warning0("plotres: nothing to plot") return(invisible(NULL)) } do.par <- check.do.par(do.par, nfigs) # do.par is 0, 1, or 2 # Prepare caption --- we need it now for do.par() but # can only display it later after at least one plot. caption <- get.caption(nfigs, do.par, caption, resp.name, type, getCall(object), object.name, my.call) if(do.par) { oldpar <- par(no.readonly=TRUE) do.par(nfigs = nfigs, caption=caption, main1=NA, # nlines.in.main below explicitly specified below xlab1 = dota("xlab", DEF=NULL, ...), # used only for margin spacing ylab1 = dota("ylab", DEF=NULL, ...), # ditto trace = trace, nlines.in.main = # nbr of lines in main is needed for margins nlines.in.plotres.main(object=object, which=which, versus=versus, standardize=standardize, delever=delever, level=level, ...), def.font.main = 1, # for compat with lm.plot ...) if(do.par == 1) on.exit(par(oldpar), add=TRUE) } else { # do.par=FALSE oldpar <- do.par.dots(..., trace=trace) if(length(oldpar)) on.exit(do.call(par, oldpar), add=TRUE) } # force.auto.resids.xlim is for back compat with old versions of earth. # To pass ylim to the w1 plot, use a w1. prefix, just like any other arg. # So plain ylim gets passed to the residuals plot not the w1 plot. # But for backwards compatibility when the w1 plot is # an earth model pass plain ylim to the w1 plot unless w1.ylim is set force.auto.resids.xlim <- length(which) > 1 && (W1 %in% which) && inherits(object, "earth") && !is.dot("w1.xlim", ...) force.auto.resids.ylim <- length(which) > 1 && (W1 %in% which) && inherits(object, "earth") && !is.dot("w1.ylim", ...) w1.retval <- list(plotted=FALSE, retval=NULL) w3.retval <- NULL attempted.w1.plot <- FALSE if(any(which == W1)) { w1.retval <- plot_w1(object=object, which=which, info=info, standardize=standardize, delever=delever, level=level, versus=versus, id.n=id.n, labels.id=rinfo$labs, smooth.col=smooth.col, grid.col=grid.col, do.par=do.par, # must do caption here if will not call plot1 later caption=if(all(which == W1)) caption else "", trace=trace, npoints=npoints, center=center, type=type, nresponse=nresponse, object.name=object.name, ...) attempted.w1.plot <- TRUE which <- which[which != W1] if(length(which) == 0 && !w1.retval$plotted && trace >= 0) warning0("plotres: nothing to plot") } if(length(which) == 0) # nothing more to plot? return(invisible(if(attempted.w1.plot) w1.retval$retval else w3.retval)) # we do this after the w1 call so we pass NULL to w1 if labels.id were NULL if(is.null(rinfo$labs)) rinfo$labs <- paste(1:length(rinfo$resids)) # We plot only the residuals in iresids, but use all the # residuals for calculating densities (where "all" actually means # a maximum of NMAX cases, see the previous call to get.isubset). # # The "use.all=(nversus == V4LEVER)" keeps things easier later # for leverage plots, but it would be nice to not have to use it. iresids <- get.isubset(rinfo$resids, npoints, id.n, use.all=(vinfo$nversus == V4LEVER), rinfo$scale) xlim <- dota("xlim", DEF=NULL, ...) # TODO what is this? for(icolumn in vinfo$icolumns) { for(iwhich in seq_along(which)) { if(which[iwhich] == W2CUM) plotmo_cum(rinfo=rinfo, info=info, nfigs=nfigs, add=FALSE, cum.col1=NA, grid.col=grid.col, jitter=0, ...) else if(which[iwhich] == W4QQ) plotmo_qq(rinfo=rinfo, info=info, nfigs=nfigs, grid.col=grid.col, smooth.col=smooth.col, id.n=id.n, iresids=iresids, npoints=npoints, force.auto.resids.ylim=force.auto.resids.ylim, ...) else w3.retval <- plotresids(object=object, which=which[iwhich], info=info, standardize=standardize, level=level, # versus1 is what we plot along the x axis, a vector versus1=vinfo$versus.mat[, icolumn], id.n=id.n, smooth.col=smooth.col, grid.col=grid.col, jitter=jitter, npoints=npoints, center=center, type=type, fitted=fitted, rinfo=rinfo, rsq=rsq, iresids=iresids, nversus=vinfo$nversus, colname.versus1=colnames(vinfo$versus.mat)[icolumn], force.auto.resids.xlim=force.auto.resids.xlim, force.auto.resids.ylim=force.auto.resids.ylim, ...) } } draw.caption(caption, ...) if(trace >= 1) printf("\ntraining rsq %.2f\n", rsq) invisible(if(attempted.w1.plot) w1.retval$retval else w3.retval) } which.err <- function() { stop0("Bad value for which\n", "Allowed values for which:\n", " 1 Model\n", " 2 Cumulative distribution\n", " 3 Residuals vs fitted\n", " 4 QQ plot\n", " 5 Abs residuals vs fitted\n", " 6 Sqrt abs residuals vs fitted\n", " 7 Abs residuals vs log fitted\n", " 8 Cube root of the squared residuals vs log fitted\n", " 9 Log abs residuals vs log fitted") } versus.err <- function() { stop0("versus must be an integer or a string:\n", " 1 fitted (default)\n", " 2 observation numbers\n", " 3 response\n", " 4 leverages\n", " \"\" predictors\n", " \"b:\" basis functions") } nlines.in.plotres.main <- function(object, which, versus, standardize, delever, level, ...) { w1.does.own.mar4 <- # these models do their own top margin spacing in w1 plot inherits(object, c("gbm", "GBMFit", "glmnet", "multnet")) auto.main.has.extra.line <- # conservative guess if main will have two lines standardize || delever || level || any(which %in% W6SQRT:W9LOGLOG) || (versus %in% V4LEVER) || is.character(versus) max(1 + auto.main.has.extra.line, nlines(dota("main", ...)), 1 + if(w1.does.own.mar4) 0 else nlines(dota("w1.main", ...))) } plotmo/R/spread.labs.R0000644000176200001440000000757214663771205014334 0ustar liggesusers# Copied from the orphaned package TeachingDemos version 2.12.1 on Feb 16, 2024. # ------------------------------------------------------------------------------ # # --Title-- # # Spread out close points for labeling in plots # # --Description-- # # This function takes as set of coordinates and spreads out the close # values so that they can be used in labeling plots without overlapping. # # --Usage-- # # spread.labs(x, mindiff, maxiter = 1000, stepsize = 1/10, min = -Inf, max = Inf) # # --Arguments-- # # x The coordinate values (x or y, not both) to spread out. # mindiff The minimum distance between return values # maxiter The maximum number of iterations # stepsize How far to move values in each iteration # min Minimum bound for returned values # max Maximum bound for returned values # # --Details-- # # Sometimes the desired locations for labels in plots results in the # labels overlapping. This function takes the coordinate values (x or #- y, not both) and finds those points that are less than mindiff # (usually a function of strheight or strwidth ) apart and # increases the space between them (by stepsize * mindiff ). # This may or may not be enough and moving some points # away from their nearest neighbor may move them too close to another # neighbor, so the process is iterated until either maxiter steps # have been tried, or all the values are at least mindiff apart. # # The min and max arguments prevent the values from going # outside that range (they should be specified such that the original # values are all inside the range). # # The values do not need to be presorted. # # --Return Value-- # # A vector of coordinates (order corresponding to the original x ) # that can be used as a replacement for x in placing labels. # # --Author-- # # Greg Snow email 538280@gmail.com # # --See Also-- # # The spread.labels function in the plotrix package. # # --Examples-- # # # overlapping labels # plot(as.integer(state.region), state.x77[,1], ylab='Population', # xlab='Region',xlim=c(1,4.75), xaxt='n') # axis(1, at=1:4, lab=levels(state.region) ) # # text( as.integer(state.region)+.5, state.x77[,1], state.abb ) # segments( as.integer(state.region)+0.025, state.x77[,1], # as.integer(state.region)+.375, state.x77[,1] ) # # # now lets redo the plot without overlap # # tmp.y <- state.x77[,1] # for(i in levels(state.region) ) { # tmp <- state.region == i # tmp.y[ tmp ] <- spread.labs( tmp.y[ tmp ], 1.2*strheight('A'), # maxiter=1000, min=0 ) # } # # plot(as.integer(state.region), state.x77[,1], ylab='Population', # xlab='Region', xlim=c(1,4.75), xaxt='n') # axis(1, at=1:4, lab=levels(state.region) ) # # text( as.integer(state.region)+0.5, tmp.y, state.abb ) # segments( as.integer(state.region)+0.025, state.x77[,1], # as.integer(state.region)+0.375, tmp.y ) # } spread.labs <- function(x, mindiff, maxiter=1000, stepsize=1/10, min=-Inf, max=Inf) { unsort <- order(order(x)) x <- sort(x) df <- x[-1] - x[ -length(x) ] stp <- mindiff * stepsize i <- 1 while( any( df < mindiff ) ) { tmp <- c( df < mindiff, FALSE ) if( tmp[1] && (x[1] - stp) < min ) { # don't move bottom set tmp2 <- as.logical( cumprod(tmp) ) tmp <- tmp & !tmp2 } x[ tmp ] <- x[ tmp ] - stp tmp <- c( FALSE, df < mindiff ) if( tmp[length(tmp)] && (x[length(x)] + stp) > max ) { # don't move top tmp2 <- rev( as.logical( cumprod( rev(tmp) ) ) ) tmp <- tmp & !tmp2 } x[ tmp ] <- x[ tmp] + stp df <- x[-1] - x[-length(x)] i <- i + 1 if( i > maxiter ) { warning("Maximum iterations reached") break } } x[unsort] } plotmo/R/stop.if.dots.R0000644000176200001440000000306514663771205014461 0ustar liggesusers# stop.if.dots.R: # stop.if.dots issues an an error message if any args in dots. # We use it to test if any dots arg of the calling function was used, for # functions that must have a dots arg (to match the generic method) but don't # actually use the dots. This helps the user catch mistyped or illegal args. stop.if.dots <- function(...) { dots <- match.call(expand.dots=FALSE)$... if(length(dots)) dots.used.err(STOPFUNC=base::stop, MSG=": unrecognized", ...) } warn.if.dots <- function(...) { dots <- match.call(expand.dots=FALSE)$... if(length(dots)) dots.used.err(STOPFUNC=base::warning, MSG=" ignored", ...) } dots.used.err <- function(..., STOPFUNC, MSG) # utility for stop.if.dots and friends { callers.name <- callers.name(n=2) dots <- match.call(expand.dots=FALSE)$... for(idot in seq_along(dots)) # STOPFUNC is either stop() or warning() { desc <- describe.dot(dots, idot) STOPFUNC(callers.name, MSG, desc, call.=FALSE) } } describe.dot <- function(dots, idot, n=4) # utility for dots.used.err { nchar <- nchar(names(dots)[idot]) if(length(nchar) && nchar > 0) return(sprint(" argument '%s'", names(dots[idot]))) # the argument that was passed in dots is unnamed call <- call.as.char(n=4) # n=4 to describe call to caller of stop.if.dots sprint(" unnamed argument\n The call was %s", paste0(strwrap(call, width=max(40, max(25, getOption("width")-20)), exdent=25), collapse="\n")) } plotmo/R/plot_glmnet.R0000644000176200001440000002773214663771205014462 0ustar liggesusers# plot_glmnet.R: # # This code is based on code in glmnet version 2.0-5 (march 2016). plot_glmnet <- function(x=stop("no 'x' argument"), xvar=c("rlambda", "lambda", "norm", "dev"), label=10, nresponse=NA, grid.col=NA, s=NA, ...) { check.classname(x, "x", c("glmnet", "multnet")) obj <- x beta <- get.beta(obj$beta, nresponse) ibeta <- nonzeroCoef(beta) # ibeta is a vector of coefficient indices if(length(ibeta) == 0) { plot(0:1, 0:1, col=0) # dummy plot legend("topleft", legend="all glmnet coefficients are zero", bty="n") return(invisible(NULL)) } # following was in original plot.glmnet code but seems unnecessary # if(length(ibeta) == 1) { # warning("1 or less nonzero coefficients; glmnet plot is not meaningful") # plot(0:1, 0:1, col=0) # legend("topleft", legend="only one coefficient is nonzero", bty="n") # return() # } beta <- as.matrix(beta[ibeta, , drop=FALSE]) xlim <- dota("xlim", ...) # get xlim from dots, NA if not in dots xvar <- match.arg1(xvar) switch(xvar, "norm"= { if(inherits(obj, "multnet") || inherits(obj, "mrelnet")) { # we don't (yet) precalc norm or support type.coef, so have to stop here stop0("xvar=\"norm\" is not supported by plot_gbm for ", "multiple responses (use plot.glmnet instead)") } x <- apply(abs(beta), 2, sum) if(!is.specified(xlim)) xlim <- c(min(x), max(x)) xlab <- "L1 Norm" approx.f <- 1 }, "lambda"= { x <- log(obj$lambda) if(!is.specified(xlim)) xlim <- c(min(x), max(x)) xlab <- "Log Lambda" approx.f <- 0 }, "rlambda"= { x <- log(obj$lambda) if(!is.specified(xlim)) xlim <- c(max(x), min(x)) # backwards xlab <- "Log Lambda" approx.f <- 0 }, "dev"= { x <- obj$dev.ratio if(!is.specified(xlim)) xlim <- c(min(x), max(x)) xlab <- "Fraction Deviance Explained" approx.f <- 1 }) xlim <- fix.lim(xlim) if(xvar != "rlambda") stopifnot(xlim[1] < xlim[2]) else if(xlim[2] >= xlim[1]) # backwards stop0("xlim[1] must be bigger than xlim[2] for xvar=\"rlambda\"") iname <- get.iname(beta, ibeta, label) # index of varnames on rhs of plot old.par <- par("mar", "mgp", "cex.axis", "cex.lab") on.exit(par(mar=old.par$mar, mgp=old.par$mgp, cex.axis=old.par$cex.axis, cex.lab=old.par$cex.lab)) mar4 <- old.par$mar[4] # right hand margin if(length(iname)) { cex.names <- min(1, max(.5, 2.5 / sqrt(length(iname)))) # seems ok # ensure right margin is big enough for the varnames # can't use strwidth because no plot yet, so just estimate mar4 <- max(old.par$mar[4] + 1, .75 * cex.names * par("cex") * max(nchar(names(iname)))) } # set mar[3] with space for top axis and maybe main, and mar[4] for rhs labels main <- dota("main", ...) # get main from dots, NA if not in dots nlines.needed.for.main <- if(is.specified(main)) nlines(main) + .5 else 0 par(mar=c(old.par$mar[1], old.par$mar[2], max(old.par$mar[3], nlines.needed.for.main + 2.6), mar4)) par(mgp=c(1.5, .4, 0)) # squash axis annotations par(cex.axis=.8) ylab <- "Coefficients" if(is.list(obj$beta)) # multiple response model? ylab <- paste0(ylab, ": Response ", rownames(obj$dfmat)[nresponse]) coef.col <- get.coef.col(..., beta=beta) # color of coef lines # discard lines with color NA or 0 keep <- which((coef.col != "NA") & (coef.col != "0")) iname <- iname[iname %in% keep] beta[-keep,] <- NA # Call graphics::matplot but drop args in dots that aren't graphics args # or formal args of graphics::matplot. # If argname below is prefixed with force. then ignore any such arg in dots. # Any argname below prefixed with def. can be overridden by a user arg in dots. # force.main="" because we later manually add a top axis and possibly main. call.plot(graphics::matplot, force.x=x, force.y=t(beta), force.main="", force.col=coef.col, def.xlim=xlim, def.xlab=xlab, def.ylab=ylab, def.lty=1, def.lwd=1, def.type="l", ...) abline(h=0, col="gray", lty=3) # zero axis line maybe.grid(x=x, beta=beta, grid.col=grid.col, coef.col=coef.col, ...) if(xvar == "rlambda") { # args are named below to prevent potential clash with argnames in dots annotate.rlambda(lambda=obj$lambda, x=x, beta=beta, s=s, grid.col=grid.col, coef.col=coef.col, ...) toplab <- "Lambda" } else { top.axis(obj, x, nresponse, approx.f) toplab <- "Degrees of Freedom" } mtext(toplab, side=3, line=1.5, cex=par("cex") * par("cex.lab")) if(is.specified(main)) mtext(main, side=3, line=3, , cex=par("cex")) # above top axis if(length(iname)) right.labs(beta, iname, cex.names, coef.col) invisible(NULL) } get.beta <- function(beta, nresponse) { if(is.list(beta)) { # multiple response model? check.integer.scalar(nresponse, min=1, max=length(beta), na.ok=TRUE, logical.ok=FALSE) if(is.na(nresponse)) stop0( "Use the nresponse argument to specify a response for this multiple response model.\n", " Example: nresponse=", length(beta)) check.index(nresponse, "nresponse", beta) beta <- beta[[nresponse]] } beta } get.coef.col <- function(..., beta) { # default colors are distinguishable yet harmonious (at least to my eye) # adjacent colors are as different as easily possible def.col <- c("black", "red", "gray50", "orangered3", "darkorange", "magenta2") col <- dota("col", DEF=def.col, ...) # get col from dots, def.col if not in dots # the colors must stay in the above order as we move down rhs of plot order <- order(beta[, ncol(beta)], decreasing=TRUE) coef.col <- vector(mode="character", nrow(beta)) coef.col[order] <- rep_len(col, nrow(beta)) coef.col } # named index of varnames to be printed on right of plot, NULL if none get.iname <- function(beta, ibeta, label) { iname <- NULL check.integer.scalar(label, min=0, logical.ok=TRUE, na.ok=TRUE) if(!is.na(label) && label) { # allow label=NA, treat as FALSE names <- if(is.null(rownames(beta))) paste(ibeta) else rownames(beta) names[!nzchar(names)] <- paste(ibeta)[!nzchar(names)] iname <- order(abs(beta[, ncol(beta)]), decreasing=TRUE) if(is.logical(label)) # label=TRUE is special meaning all iname <- iname[1:length(iname)] else if(length(iname) > label) iname <- iname[1:label] names(iname) <- abbreviate(names[iname], minlength=8) } iname # named index of varnames to be printed, NULL if none } maybe.grid <- function(x, beta, grid.col, coef.col, ...) { if(is.specified(grid.col[1])) { grid(col=grid.col[1], lty=1) # replot over the grid (using add=TRUE) call.plot(graphics::matplot, force.x=x, force.y=t(beta), force.add=TRUE, force.main="", force.col=coef.col, def.lty=1, def.lwd=1, def.type="l", ...) } } right.labs <- function(beta, iname, cex.names, coef.col) # varnames on right of plot { usr <- par("usr") text(x=usr[2] + .01 * (usr[2] - usr[1]), y=spread.labs(beta[iname, ncol(beta)], mindiff=1.2 * cex.names * strheight("X")), labels=names(iname), cex=cex.names, col=coef.col[iname], adj=0, xpd=NA) } top.axis <- function(obj, x, nresponse, approx.f) { at <- pretty(x) # use is.list(obj$beta) to determine if multiple response model df <- if(is.list(obj$beta)) obj$dfmat[nresponse,] else obj$df # compute df by interpolating to df at next smaller lambda # thanks to Yunyang Qian prettydf <- approx(x=x, y=df, xout=at, rule=2, method="constant", f=approx.f)$y axis(3, at=at, labels=prettydf) } # Draw the top axis of an rlambda plot. # Also draw a labeled vertical line at lambda=s, if s isn't NA. # Dot arguments prefixed with "s". can be used to set the annotation # attributes e.g. s.col=NA or s.col=0 for no vertical line. # This is achieved with call.plot(text.on.white, PREFIX="s.", ...) below. annotate.rlambda <- function(lambda, x, beta, s, grid.col, coef.col, ...) { check.numeric.scalar(s, na.ok=TRUE, null.ok=TRUE, logical.ok=FALSE) s.col <- dota("s.col", DEF=1, ...) # get s.col from dots, 1 if not in dots add.s.line <- !is.null(s) && !is.na(s) && is.specified(s.col) # top axis at <- pretty(x) labs <- signif(exp(at), digits=2) # hack: delete confusing rightmost lab (if any) with a value greater # than s but drawn to the right of the vertical line at s if(add.s.line && s <= labs[1]) labs[1] <- "" axis(3, at=at, labels=labs) if(add.s.line) # add vertical line showing s? add.s.line(lambda=lambda, x=x, beta=beta, s=s, grid.col=grid.col, coef.col=coef.col, s.col=s.col, ...) } add.s.line <- function(lambda, x, beta, s, grid.col, coef.col, s.col, ...) { line.col <- "gray" line.lty <- 1 if(is.specified(grid.col)) { line.col <- 1 line.lty <- 3 } log.s <- log(max(lambda[length(lambda)], s)) abline(v=log.s, col=line.col, lty=line.lty) # vertical line at s # replot over the vertical line (using add=TRUE) call.plot(graphics::matplot, force.x=x, force.y=t(beta), force.add=TRUE, force.main="", force.col=coef.col, def.lty=1, def.lwd=1, def.type="l", ...) # add s label on vertical line # to minimize overplotting, y coord of label is biggest gap between matplot lines usr <- par("usr") # xmin, xmax, ymin, ymax col.index <- which.min(abs(lambda-s)) # lambda column corresponding to s y <- sort(c(usr[3], beta[, col.index], usr[4])) # include plot edges, and sort which <- which.max(diff(y)) # call graphics::matplot() but drop args in dots that aren't graphics args # or argnames prefixed with "s." or formal args of text.on.white call.plot(text.on.white, PREFIX="s.", force.x=log.s, force.y=(y[which]+y[which+1]) / 2, force.label= # gsub below drops leading and trailing zeros for compactness if(s == 0) "s=0" else paste0("s=", gsub("^0|0$|\\.0*$", "", signif(s,2))), force.col=s.col, force.cex=.8, def.srt=90, def.xpd=NA, ...) } # Return NULL or an integer vector # Reproduced here (from glmnet version 2.0-16, nov 2018) # so don't have to import glmnet into plotmo. nonzeroCoef = function (beta, bystep = FALSE) { ### bystep = FALSE means which variables were ever nonzero ### bystep = TRUE means which variables are nonzero for each step nr=nrow(beta) if (nr == 1) {#degenerate case if (bystep) apply(beta, 2, function(x) if (abs(x) > 0) 1 else NULL) else { if (any(abs(beta) > 0)) 1 else NULL } } else { beta=abs(beta)>0 # this is sparse which=seq(nr) ones=rep(1,ncol(beta)) nz=as.vector((beta%*%ones)>0) which=which[nz] if (bystep) { if(length(which)>0){ beta=as.matrix(beta[which,,drop=FALSE]) nzel = function(x, which) if (any(x)) which[x] else NULL which=apply(beta, 2, nzel, which) if(!is.list(which))which=data.frame(which)# apply can return a matrix!! which } else{ dn=dimnames(beta)[[2]] which=vector("list",length(dn)) names(which)=dn which } } else which } } plotmo/R/dot.R0000644000176200001440000001724114663771205012716 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/plotmo.R0000644000176200001440000023111214664454620013435 0ustar liggesusers# plotmo.R: plot the model response when varying one or two predictors # # Stephen Milborrow Sep 2006 Cape Town plotmo <- function(object = stop("no 'object' argument"), type = NULL, nresponse = NA, pmethod = "plotmo", pt.col = 0, jitter = .5, smooth.col = 0, level = 0, func = NULL, inverse.func = NULL, nrug = 0, grid.col = 0, type2 = "persp", degree1 = TRUE, all1 = FALSE, degree2 = TRUE, all2 = FALSE, do.par = TRUE, clip = TRUE, ylim = NULL, caption = NULL, trace = 0, grid.func = NULL, grid.levels = NULL, extend = 0, ngrid1 = 50, ngrid2 = 20, ndiscrete = 5, npoints = 3000, center = FALSE, xflip = FALSE, yflip = FALSE, swapxy = FALSE, int.only.ok = TRUE, ...) { init.global.data() on.exit({init.global.data(); gc()}) # release memory on exit object.name <- quote.deparse(substitute(object)) object # make sure object exists trace <- as.numeric(check.integer.scalar(trace, logical.ok=TRUE)) use.submodel <- dota("USE.SUBMODEL", DEF=TRUE, ...) # undoc arg (for parsnip models) use.submodel <- is.specified(use.submodel) # Associate the model environment with the object. # (This is instead of passing it as an argument to plotmo's data access # functions. It saves a few hundred references to model.env in the code.) object.env <- get.model.env(object, object.name, trace, use.submodel) ret <- plotmo_prolog(object, object.name, trace, ...) object <- ret$object # the original object or a submodel (parsnip) my.call <- ret$my.call attr(object, ".Environment") <- object.env # We will later make two passes through the plots if we need to # automatically determine ylim (see get.ylim.by.dummy.plots). # The trace2 variable is used for disabling tracing on the second pass. trace2 <- trace # trace=100 to 103 are special values used for development # (they are for tracing just plotmo_x with no plotting) special.trace <- FALSE if(trace >= 100 && trace <= 103) { special.trace <- TRUE trace <- trace - 100 } pmethod <- match.choices(pmethod, c("plotmo", "partdep", "apartdep"), "pmethod") clip <- check.boolean(clip) all1 <- check.boolean(all1) all2 <- check.integer.scalar(all2, min=0, max=2) center <- check.boolean(center) swapxy <- check.boolean(swapxy) xflip <- check.boolean(xflip) yflip <- check.boolean(yflip) type2 <- match.choices(type2, c("persp", "contour", "image"), "type2") level <- get.level(level, ...) pt.col <- get.pt.col(pt.col, ...) jitter <- get.jitter(jitter, ...) smooth.col <- get.smooth.col(smooth.col, ...) check.integer.scalar(ndiscrete, min=0) extend <- check.numeric.scalar(extend) stopifnot(extend > -.3, extend <= 10) # .3 prevents shrinking to nothing, 10 is arb if(!is.specified(degree1)) degree1 <- 0 if(!is.specified(degree2)) degree2 <- 0 if(!is.specified(nresponse)) nresponse <- NA if(!is.specified(clip)) clip <- FALSE if(center && clip) { clip <- FALSE # otherwise incorrect clipping (TODO revisit) warning0("forcing clip=FALSE because center=TRUE ", "(a limitation of the current implementation)") } # get x so we can get the predictor names and ux.list x <- plotmo_x(object, trace) if(NCOL(x) == 0 || NROW(x) == 0) stop("x is empty") # seen with an intercept only model for some model classes (not earth) if(special.trace) # special value of trace was used? return(invisible(x)) meta <- plotmo_meta(object, type, nresponse, trace, msg.if.predictions.not.numeric= if(level > 0) "the level argument is not allowed" else NULL, ...) y <- meta$y.as.numeric.mat # y as a numeric mat, only the nresponse column nresponse <- meta$nresponse # column index resp.name <- meta$resp.name # used only in automatic caption, may be NULL resp.levs <- meta$resp.levs # to convert predicted strings to factors, may be NULL type <- meta$type # always a string (converted from NULL if necessary) ngrid1 <- get.ngrid1(ngrid1, y, ...) ngrid2 <- get.ngrid2(ngrid2, y, ...) n.apartdep <- ngrid1 # following prevents aliasing on nrow(data) to ensure we catch the following: # "warning: predict(): newdata' had 31 rows but variable(s) found have 30 rows" if(ngrid1 == length(y)) { trace2(trace, "changed ngrid1 from %g to %g\n", ngrid1, ngrid1+1) ngrid1 <- ngrid1 + 1 } temp <- get.unique.xyvals(x, y, npoints, trace) ux.list <- temp$ux.list # list, each elem is unique vals in a column of x uy <- temp$uy # unique y vals npoints <- temp$npoints y <- apply.inverse.func(inverse.func, y, object, trace) if(center) y <- my.center(y, trace) # get iresponse ncases <- nrow(x) iresponse <- NULL if(is.specified(pt.col)) { iresponse <- get.iresponse(npoints, ncases) if(is.null(iresponse)) pt.col <- 0 } # singles is a vector of indices of predictors for degree1 plots singles <- plotmo_singles(object, x, nresponse, trace, degree1, all1) nsingles <- length(singles) # each row of pairs is the indices of two predictors for a degree2 plot pairs <- plotmo_pairs(object, x, nresponse, trace, all2, degree2) npairs <- NROW(pairs) temp <- get.pred.names(colnames.x=colnames(x), nfigs=nsingles + npairs, ...) pred.names <- temp$pred.names abbr.pred.names <- temp$abbr.pred.names def.cex.main <- temp$def.cex.main is.int.only <- FALSE # is intercept only model? if(nsingles == 0 && npairs == 0) { # is this an intercept only model? (which causes nsingles == 0 && npairs == 0) # if so, we plot it anyway (unless degree1=0) trace2(trace, "\n----plotmo_singles for %s object, all1=FALSE %s \n", class.as.char(object), "(determine if is.int.only)") sing <- plotmo.singles(object=object, x=x, nresponse=nresponse, trace=trace, all1=FALSE) # note that all1=FALSE is.int.only <- length(sing) == 0 trace2(trace, if(is.int.only) "intercept-only model\n\n" else "model has an intercept\n\n") } if(is.int.only && int.only.ok && !all(degree1 == 0)) { singles <- 1 # plot the first predictor nsingles <- 1 } if(nsingles > 64 && trace >= 0) { cat0("More than 64 degree1 plots.\n", "Consider using plotmo's degree1 argument to limit the number of plots.\n", "For example, degree1=1:10 or degree1=c(\"", pred.names[singles[1]], "\", \"", pred.names[singles[2]], "\")\n", "Call plotmo with trace=-1 to make this message go away.\n\n") } else if(nsingles > 200) { # 220 is arb, 15 * 15 warning0("Will plot only the first 200 degree1 plots (of ", nsingles, " degree1 plots)") singles <- singles[1:200] nsingles <- length(singles) } if(npairs > 64 && trace >= 0) { cat0("More than 64 degree2 plots.\n", "Consider using plotmo's degree2 argument to limit the number of plots.\n", "For example, degree2=1:10 or degree2=\"", pred.names[singles[1]], "\"\n", "Call plotmo with trace=-1 to make this message go away.\n\n") } else if(npairs > 200) { warning0("Will plot only the first 200 degree2 plots (of ", npairs, " degree2 plots)") pairs <- pairs[1:200,] npairs <- NROW(pairs) } if(extend != 0 && npairs) { warning0("extend=", extend, ": will not plot degree2 plots ", "(extend is not yet implemented for degree2 plots)") pairs <- NULL npairs <- 0 } nfigs <- nsingles + npairs if(nfigs == 0) { if(trace >= 0) warning0("plotmo: nothing to plot") return(invisible()) } do.par <- check.do.par(do.par, nfigs) # do.par is 0, 1, or 2 # Prepare caption --- we need it now for do.par() but # can only display it later after at least one plot. # nfigs=2 (any number greater than 1) because by default we do.par in plotmo. caption <- get.caption(nfigs=2, do.par, caption, resp.name, type, getCall(object), object.name, my.call) if(do.par) { # TODO document what happens here and in plotres if only one plot oldpar <- par(no.readonly=TRUE) # need xlab etc. so so we can figure out margin sizes in do.par xlab <- dota("xlab", DEF="", ...) ylab <- dota("ylab", DEF="", ...) main <- dota("main", ...) do.par(nfigs=nfigs, caption=caption, main1=main, xlab1=xlab, ylab1=ylab, trace=trace, def.cex.main=def.cex.main, ...) if(do.par == 1) on.exit(par(oldpar), add=TRUE) } else { # do.par=FALSE oldpar <- do.par.dots(..., trace=trace) if(length(oldpar)) on.exit(do.call(par, oldpar), add=TRUE) } trace2(trace, "\n----Figuring out ylim\n") is.na.ylim <- !is.null(ylim) && anyNA(ylim) jittered.y <- apply.jitter(as.numeric(y), jitter) # get.ylim will do dummy plots if necessary temp <- get.ylim(object=object, type=type, nresponse=nresponse, pmethod=pmethod, pt.col=pt.col, jitter=jitter, smooth.col=smooth.col, level=level, func=func, inverse.func=inverse.func, nrug=nrug, grid.col=grid.col, type2=type2, degree1=degree1, all1=all1, degree2=degree2, all2=all2, do.par=do.par, clip=clip, ylim=ylim, caption=caption, trace=trace, grid.func=grid.func, grid.levels=grid.levels, extend=extend, ngrid1=ngrid1, ngrid2=ngrid2, npoints=npoints, ndiscrete=ndiscrete, int.only.ok=int.only.ok, center=center, xflip=xflip, yflip=yflip, swapxy=swapxy, def.cex.main=def.cex.main, x=x, y=y, singles=singles, resp.levs=resp.levs, ux.list=ux.list, pred.names=pred.names, abbr.pred.names=abbr.pred.names, nsingles=nsingles, npairs=npairs, nfigs=nfigs, uy=uy, is.na.ylim=is.na.ylim, is.int.only=is.int.only, trace2=trace2, pairs=pairs, iresponse=iresponse, jittered.y=jittered.y, n.apartdep=n.apartdep, ...) ylim <- temp$ylim trace2 <- temp$trace2 if(nsingles) plot_degree1(object=object, degree1=degree1, all1=all1, center=center, ylim=if(is.na.ylim) NULL else ylim, # each graph has its own ylim? type=type, nresponse=nresponse, pmethod=pmethod, trace=trace, trace2=trace2, pt.col=pt.col, jitter=jitter, iresponse=iresponse, smooth.col=smooth.col, grid.col=grid.col, inverse.func=inverse.func, grid.func=grid.func, grid.levels=grid.levels, extend=extend, ngrid1=ngrid1, is.int.only=is.int.only, level=level, func=func, nrug=nrug, draw.plot=TRUE, x=x, y=y, singles=singles, resp.levs=resp.levs, ux.list=ux.list, ndiscrete=ndiscrete, pred.names=pred.names, abbr.pred.names=abbr.pred.names, nfigs=nfigs, uy=uy, xflip=xflip, jittered.y=jittered.y, n.apartdep=n.apartdep, ...) if(npairs) plot_degree2(object=object, degree2=degree2, all2=all2, center, ylim=if(is.na.ylim) NULL else ylim, # each graph has its own ylim? type=type, nresponse=nresponse, pmethod=pmethod, clip=clip, trace=trace, trace2=trace2, pt.col=pt.col, jitter=jitter, iresponse=iresponse, inverse.func=inverse.func, grid.func=grid.func, grid.levels=grid.levels, extend=extend, type2=type2, ngrid2=ngrid2, draw.plot=TRUE, do.par=do.par, x=x, y=y, pairs=pairs, resp.levs=resp.levs, ux.list=ux.list, ndiscrete=ndiscrete, pred.names=pred.names, abbr.pred.names=abbr.pred.names, nfigs=nfigs, nsingles=nsingles, npairs=npairs, xflip=xflip, yflip=yflip, swapxy=swapxy, def.cex.main=def.cex.main, n.apartdep=n.apartdep, ...) draw.caption(caption, ...) invisible(x) } # plotmo.retval <- function(x, singles, pairs, pred.names) # plotmo's return value # { # degree1 <- vector("list", length(singles)) # names <- vector("character", length(singles)) # for(isingle in seq_along(singles)) { # ipred <- singles[isingle] # ipred is the predictor index i.e. col in model mat # temp <- degree1.data(isingle) # stopifnot(!is.null(temp)) # stopifnot(nrow(temp$xframe) == length(temp$yhat)) # data <- data.frame(temp$xframe[[ipred]], temp$yhat) # names[isingle] <- pred.names[ipred] # colnames(data) <- c(pred.names[ipred], "PLOTMO") # degree1[[isingle]] <- data # } # names(degree1) <- names # # npairs <- NROW(pairs) # degree2 <- vector("list", npairs) # names <- vector("character", npairs) # for(ipair in seq_len(npairs)) { # ipred1 <- pairs[ipair,1] # index of first predictor # ipred2 <- pairs[ipair,2] # index of second predictor # temp <- degree2.data(ipair) # stopifnot(!is.null(temp)) # # TODO this fails if blockify.degree2.frame kicks in # stopifnot(nrow(temp$xframe) == length(temp$yhat)) # data <- data.frame(temp$xframe[ipred1], temp$xframe[ipred2], as.vector(temp$yhat)) # names[ipair] <- paste0(pred.names[ipred1], ":", pred.names[ipred1]) # colnames(data) <- c(pred.names[ipred1], pred.names[ipred2], "PLOTMO") # degree2[[ipair]] <- data # } # names(degree2) <- names # # list(x=x, degree1=degree1, degree2=degree2) # } plotmo_prolog <- function(object, object.name, trace, ...) { object <- plotmo.prolog(object, object.name, trace, ...) my.call <- call.as.char(n=2) SHOWCALL <- dota("SHOWCALL", ...) if(!is.specified(SHOWCALL)) my.call <- NULL list(object=object, my.call=my.call) } get.pred.names <- function(colnames.x, nfigs, ...) { # numbers below are somewhat arb nrows <- ceiling(sqrt(nfigs)) # nrows in plot grid minlength <- 20; def.cex.main <- 1.2 if (nrows >= 9) { minlength <- 6; def.cex.main <- .7 } else if(nrows >= 8) { minlength <- 7; def.cex.main <- .8 } else if(nrows >= 7) { minlength <- 7; def.cex.main <- .8 } else if(nrows >= 6) { minlength <- 7; def.cex.main <- .8 } else if(nrows >= 5) { minlength <- 8; def.cex.main <- 1 } else if(nrows >= 4) { minlength <- 9; def.cex.main <- 1.1 } stopifnot(!is.null(colnames.x)) # plotmo_x always returns colnames (unless no columns) minlength <- dota("prednames.minlength", DEF=minlength, ...) prednames.abbreviate <- dota("prednames.abbreviate", DEF=TRUE, ...) prednames.abbreviate <- check.boolean(prednames.abbreviate) abbr.pred.names <- if((prednames.abbreviate)) abbreviate(strip.space(colnames.x), minlength=minlength, method="both.sides") else colnames.x list(pred.names = colnames.x, abbr.pred.names = abbr.pred.names, def.cex.main = def.cex.main) } # always returns a vector of 2 elems, could be c(-Inf, Inf) get.ylim <- function(object, type, nresponse, pmethod, pt.col, jitter, smooth.col, level, func, inverse.func, nrug, grid.col, type2, degree1, all1, degree2, all2, do.par, clip, ylim, caption, trace, grid.func, grid.levels, extend=extend, ngrid1, ngrid2, npoints, ndiscrete, int.only.ok, center, xflip, yflip, swapxy, def.cex.main, x, y, singles, resp.levs, ux.list, pred.names, abbr.pred.names, nsingles, npairs, nfigs, uy, is.na.ylim, is.int.only, trace2, pairs, iresponse, jittered.y, n.apartdep, ...) { get.ylim.by.dummy.plots <- function(..., trace) { # call the plotting functions with draw.plot=FALSE to get the ylim trace2(trace, "--get.ylim.by.dummy.plots\n") all.yhat <- NULL if(nsingles) { # get all.yhat by calling with draw.plot=FALSE # have to use explicit arg names to prevent alias probs # with dots, because the user can pass in any name with dots all.yhat <- c(all.yhat, plot_degree1(object=object, degree1=degree1, all1=all1, center=center, ylim=ylim, type=type, nresponse=nresponse, pmethod=pmethod, trace=trace, trace2=trace2, pt.col=pt.col, jitter=jitter, iresponse=iresponse, smooth.col=smooth.col, grid.col=grid.col, inverse.func=inverse.func, grid.func=grid.func, grid.levels=grid.levels, extend=extend, ngrid1=ngrid1, is.int.only=is.int.only, level=level, func=func, nrug=nrug, draw.plot=FALSE, x=x, y=y, singles=singles, resp.levs=resp.levs, ux.list=ux.list, ndiscrete=ndiscrete, pred.names=pred.names, abbr.pred.names=abbr.pred.names, nfigs=nfigs, uy=uy, xflip=xflip, jittered.y=jittered.y, n.apartdep=n.apartdep, ...)) } if(npairs) { all.yhat <- c(all.yhat, plot_degree2(object=object, degree2=degree2, all2=all2, center=center, ylim=ylim, type=type, nresponse=nresponse, pmethod=pmethod, clip=clip, trace=trace, trace2=trace2, pt.col=pt.col, jitter=jitter, iresponse=iresponse, inverse.func=inverse.func, grid.func=grid.func, grid.levels=grid.levels, extend=extend, type2=type2, ngrid2=ngrid2, draw.plot=FALSE, do.par=do.par, x=x, y=y, pairs=pairs, resp.levs=resp.levs, ux.list=ux.list, ndiscrete=ndiscrete, pred.names=pred.names, abbr.pred.names=abbr.pred.names, nfigs=nfigs, nsingles=nsingles, npairs=npairs, xflip=xflip, yflip=yflip, swapxy=swapxy, def.cex.main=def.cex.main, n.apartdep=n.apartdep, ...)) } # 1 2 3 4 5 q <- quantile(all.yhat, probs=c(0, .25, .5, .75, 1), names=FALSE) ylim <- c(q[1], q[5]) # all the data check.vec(ylim, "automatic ylim", expected.len=2) # iqr test to prevent clipping in some pathological cases iqr <- q[4] - q[2] # middle 50% of the data (inter-quartile range) if(clip && !is.na(iqr) && iqr > .05 * (max(y) - min(y))) { median <- q[3] ylim[1] <- max(ylim[1], median - 10 * iqr) ylim[2] <- min(ylim[2], median + 10 * iqr) } if(is.specified(pt.col) || is.specified(smooth.col) || is.specified(level)) ylim <- range1(ylim, jittered.y) # ensure ylim big enough for resp points else if(is.specified(smooth.col)) ylim <- range1(ylim, y) # binary or ternary reponse? # the range(uy) test is needed for binomial models specified using counts else if(length(uy) <= 3 || all(range(y) == c(0,1))) ylim <- range1(ylim, y) if(is.specified(nrug)) # space for rug ylim[1] <- ylim[1] - .1 * (ylim[2] - ylim[1]) trace2(trace, "--done get.ylim.by.dummy.plots\n\n") # have called the plot functions, minimize tracing in further calls to them trace2 <<- 0 # note <<- not <- ylim } #--- get.ylim starts here if(!(is.null(ylim) || is.na(ylim[1]) || length(ylim) == 2)) stop0("ylim must be one of:\n", " NULL all graphs have same vertical axes\n", " NA each graph has its own vertical axis\n", " c(min,max) ylim for all graphs") if(length(ylim) == 2 && ylim[2] <= ylim[1]) stop0("ylim[2] ", ylim[2], " is not greater than ylim[1] ", ylim[1]) if(is.na.ylim) ylim <- c(NA, NA) # won't be used else if(is.null(ylim)) # auto ylim ylim <- if(is.yaxis.a.probability(object, type, trace)) { if(is.specified(pt.col)) c(-0.1, 1.1) # leave space for possibly jittered points else c(0, 1) } else if(is.int.only) range(y, na.rm=TRUE) else get.ylim.by.dummy.plots(trace=trace, ...) if(!anyNA(ylim)) ylim <- fix.lim(ylim) if(trace >= 2) printf("ylim c(%.4g, %.4g) clip %s\n\n", ylim[1], ylim[2], if(clip) "TRUE" else "FALSE") list(ylim=ylim, trace2=trace2) } do.persp.auto.par <- function(simple.ticktype) # want small margins for bigger persp plots { # persp ignores both the global mgp and any mgp passed as arguments # directly to persp so we must adjust margins using par() old.mar <- par("mar") axis.space <- max(par("mgp")) mar <- old.mar if(simple.ticktype) { # Reduce bottom and left margins so we get a bigger persp plot. # This puts the bottom corner of the perp plot at same height at the # bottom of the axis labels on the degree1 plots. mar[1] <- max(mar[1] - axis.space - .5, .5) # bottom margin mar[2] <- max(mar[2] - axis.space - .5, .5) # left margin } else { # detailed mar[1] <- min(mar[1], 1) # enough space for axes mar[2] <- min(mar[2], 1) } par(mar=mar) } do.degree2.auto.par <- function(type2, nfigs, simple.ticktype) { if(type2 == "persp") # perspective plot do.persp.auto.par(simple.ticktype) else { # contour or image plot nrows <- ceiling(sqrt(nfigs)) if(nrows >= 5) mar <- c(2, 2, 1.2, .5) # space for bottom and left axis labels else mar <- c(3, 3, 2, .5) par(mar=mar) cex <- par("cex") # TODO would be better to use nfigs here? mgp <- # compact title and axis annotations if (cex < .7) c(1.2, 0.2, 0) else if(cex < .8) c(1.3, 0.3, 0) else c(1.5, 0.4, 0) par(mgp=mgp) } } plotmo_singles <- function(object, x, nresponse, trace, degree1, all1) { trace2(trace, "\n----plotmo_singles for %s object\n", class.as.char(object)) singles <- plotmo.singles(object=object, x=x, nresponse=nresponse, trace=trace, all1=all1) if(is.character(degree1)) # get all singles, not just those used in the model? singles <- seq_len(NCOL(x)) if(!is.null(singles) && any(is.na(singles))) { # !is.null required only for old R # Following occurs when plotting # train(Petal.Length ~ ., data=iris, method="rpart", tuneLength=4) # because caret converts factor predictors to indicator columns and # thus creates new variable names e.g. Speciesversicolor warning0("NA in singles, will plot all variables (as if all1=TRUE)") singles <- seq_len(NCOL(x)) } if(length(singles)) singles <- sort_unique(singles) # this will drop NAs if any nsingles <- length(singles) if(length(singles)) { degree1 <- check.index(degree1, "degree1", singles, colnames=colnames(x), allow.empty=TRUE, is.degree.spec=TRUE) singles <- singles[degree1] } else if(is.degree.specified(degree1) && degree1[1] != 0 && trace >= 0) warning0("'degree1' specified but no degree1 plots (maybe use all1=TRUE?)") if(trace >= 2) { if(length(singles)) cat("singles:", paste0(singles, " ", colnames(x)[singles], collapse=", "), "\n") else cat("no singles\n") } singles # a vector of indices of predictors for degree1 plots } plotmo_pairs <- function(object, x, nresponse, trace, all2, degree2) { trace2(trace, "\n----plotmo_pairs for %s object\n", class.as.char(object)) pairs <- NULL if(is.character(degree2) && length(degree2) == 2) { # degree2 is a two element character vector # treat as a special case (intentional inconsistency) singles <- seq_len(NCOL(x)) # get all singles, not just those used in the model i1 <- check.index(degree2[1], "degree2", singles, colnames=colnames(x)) if(length(i1) > 0) { i2 <- check.index(degree2[2], "degree2", singles, colnames=colnames(x)) if(length(i2) > 0) { if(i1[1] == i2[1]) warning0("both elements of degree2 are the same") pairs <- matrix(c(i1[1], i2[1]), nrow=1, ncol=2) } } } else { pairs <- if(all2) get.all.pairs.from.singles(object, x, trace, all2) else plotmo.pairs(object, x, nresponse, trace, all2) if(NROW(pairs)) { # put lowest numbered predictor first and remove duplicate pairs pairs <- unique(t(apply(pairs, 1, sort))) # order the pairs on the predictor order order <- order(pairs[,1], pairs[,2]) pairs <- pairs[order, , drop=FALSE] i <- check.index(degree2, "degree2", pairs, colnames=colnames(x), allow.empty=TRUE, is.degree.spec=TRUE) pairs <- pairs[i, , drop=FALSE] # length(i) will be 0 if check.index not ok } else if(is.degree.specified(degree2) && degree2[1] != 0 && trace >= 0) warning0("'degree2' specified but no degree2 plots (maybe use all2=TRUE?)") } if(trace >= 2) { if(NROW(pairs)) { cat("pairs:\n") print(matrix(paste(pairs, colnames(x)[pairs]), ncol=2)) } else cat("no pairs\n") } pairs } # pt.col is a formal arg, but for back compat we also support col.response get.pt.col <- function(pt.col, ...) { pt.col <- pt.col if(!is.specified(pt.col) && !is.dot("col", ...)) pt.col <- dota("col.response", EX=0, ...) # partial match, "col" excluded above # if any other response argument is specified, set the response color if(!is.specified(pt.col) && is.dot("pch cex.response pch.response pt.cex pt.pch", EX=c(1,1,1,0,0), ...)) pt.col <- "slategray4" if(!is.specified(pt.col)) pt.col <- 0 pt.col } get.jitter <- function(jitter, ...) { if(anyNA(jitter)) # allow jitter=NA jitter <- 0 check.numeric.scalar(jitter, logical.ok=TRUE) jitter <- as.numeric(jitter) if(jitter < 0 || jitter > 100) stop0("jitter=", jitter, " is illegal") jitter } get.smooth.col <- function(smooth.col, ...) { smooth.col <- dota("col.smooth", DEF=smooth.col, ...) # back compat # if any other smooth argument is specified, set the smooth color if(!is.specified(smooth.col) && is.dot("lty.smooth lwd.smooth lwd.loess smooth.lty smooth.lwd", EX=c(1,1,1,0,0), ...)) smooth.col <- 2 if(!is.specified(smooth.col)) smooth.col <- 0 smooth.col } get.ngrid1 <- function(ngrid1, y, ...) { check.integer.scalar(ngrid1) if(ngrid1 < 2) stop0("illegal ngrid1 ", ngrid1) if(ngrid1 > 1000) { warning0("clipped ngrid1=", ngrid1, " to 1000") ngrid1 <- 1000 } ngrid1 } get.ngrid2 <- function(ngrid2, y, ...) { check.integer.scalar(ngrid2) if(ngrid2 < 2) stop0("illegal ngrid2 ", ngrid2) if(ngrid2 > 500) { warning0("clipped ngrid2=", ngrid2, " to 500") ngrid2 <- 500 } ngrid2 } get.level <- function(level, ...) { if(anyNA(level) || is.null(level)) # treat NA and NULL as 0 level <- 0 check.numeric.scalar(level) # some code for backward compatibility (se is now deprecated) se <- 0 if(is.dot("se", ...)) se <- dota("se", ...) check.numeric.scalar(se, logical.ok=TRUE) if(se && level) # both specified? stop0("plotmo's 'se' argument is deprecated, please use 'level' instead") if(identical(se, TRUE)) { level <- .95 warning0( "plotmo's 'se' argument is deprecated, please use 'level=.95' instead") } else if(se < 0 || se > 5) # 5 is arb stop0("plotmo's 'se' argument is deprecated, please use 'level=.95' instead") else if(se > 0 && se < 1) # e.g. se=.95 stop0("plotmo's 'se' argument is deprecated, please use 'level=.95' instead") else if(se > 0) { level <- 1 - 2 * (1 - pnorm(se)) # se=2 becomes level=.954 warning0(sprint( "plotmo's 'se' argument is deprecated, please use 'level=%.2f' instead", level)) } else if(level != 0 && (level < .5 || level >= 1)) stop0("level=", level, " is out of range, try level=.95") level } get.unique.xyvals <- function(x, y, npoints, trace) { # convert special values of npoints ncases <- nrow(x) check.integer.scalar(npoints, min=-1, null.ok=TRUE, logical.ok=TRUE) npoints.was.neg <- FALSE if(is.null(npoints)) npoints <- 0 else if(is.logical(npoints)) npoints <- if(npoints) ncases else 0 else if(npoints == -1) { npoints.was.neg <- TRUE npoints <- ncases } else if(npoints > ncases) npoints <- ncases # Use a maximum of NMAX cases for calculating ux.list and uy # (unless npoints is bigger or TRUE or negative). # Allows plotmo to be fast even on models with millions of cases. NMAX <- 1e4 nmax <- max(NMAX, npoints) if(!npoints.was.neg && ncases > nmax) { trace2(trace, "using %g of %g cases to calculate unique x and y values\n", npoints, ncases) isubset <- get.isubset(y, npoints) y <- y[isubset] x <- x[isubset, , drop=FALSE] } list(ux.list = get.ux.list(x, trace), uy = unique(y), npoints = npoints) } # return a list, each element is the unique levels for corresponding column of x # TODO this is where we spend a lot of time in plotmo for big data get.ux.list <- function(x, trace) { ux.list <- list(colnames(x)) for(i in seq_len(ncol(x))) ux.list[[i]] <- if(is.factor(x[,i])) levels(x[,i]) else sort_unique(x[,i]) trace2(trace, "number of x values: %s\n", paste.trunc(colnames(x), sapply(ux.list, length))) ux.list } points.or.text <- function(..., x, y, pt.col, iresponse) { stopifnot(!is.na(pt.col)) cex <- dota("pt.cex cex.response", DEF=1, EX=c(0,1), NEW=1, ...) cex <- cex * pt.cex(NROW(x)) pch <- dota("pt.pch pch.response pch", DEF=20, EX=c(0,1,1), NEW=1, ...) # recycle then select only iresponse points n <- length(y) col <- repl(pt.col, n)[iresponse] pch <- repl(pch, n)[iresponse] cex <- repl(cex, n)[iresponse] x <- x[iresponse] y <- y[iresponse] if(is.character(pch) && pch[1] != ".") call.plot(graphics::text.default, PREFIX="pt.", force.x = x, force.y = y, force.labels = pch, force.col = col, force.cex = pmax(.1, .9 * cex), def.xpd = NA, # allow writing beyond plot area ...) else call.plot(graphics::points.default, PREFIX="pt.", force.x = x, force.y = y, force.pch = pch, force.col = col, force.cex = cex, # commented out because looks messy in image plots # def.xpd = NA, # allow writing beyond plot area ...) } # TODO Following handling of global variables is unpleasant. # I would prefer to have two namespace level variables, # degree1.data.global and degree2.data.global (similar to # degree1.xgrid.global etc.) # But CRAN check won't allow # unlockBinding(degree1.data.global, asNamespace("plotmo")) # so we can update those variables. # Also, we can't directly use assignInMyNamespace for these # variables because we need to update individual list elements. make.static.list <- function() { data <- list() func <- function(i, newdata=NULL) { if(is.null(i)) # init the data? data <<- list() else if(!missing(newdata)) # assign to the data? data[[i]] <<- newdata else if(i <= length(data)) # return the data element data[[i]] else # return the element, but it's NULL NULL } func } # The following global variables are for efficiency when we make two # passes through the plot. We store the data from the first pass so we # don't have to regenerate it. (We make two passes if we need to # precalculate ylim before doing the actual plotting.) # NULL is used here to indicate uninitialized. degree1.xgrid.global <- NULL degree2.xgrid.global <- NULL partdep.x.global <- NULL # dataframe of background vars we integrate over degree1.data <- make.static.list() degree2.data <- make.static.list() # the following global variables are for communicating across functions trace.call.global <- 0 # nonzero to trace call to predict, residuals, etc init.global.data <- function() { assignInMyNamespace("trace.call.global", 0) assignInMyNamespace("degree1.xgrid.global", NULL) assignInMyNamespace("degree2.xgrid.global", NULL) assignInMyNamespace("partdep.x.global", NULL) degree1.data(NULL) # clear the degree1 data by passing NULL degree2.data(NULL) } plot_degree1 <- function( # plot all degree1 graphs # copy of args from plotmo, some have been tweaked slightly object, degree1, all1, center, ylim, type, nresponse, pmethod, trace, trace2, pt.col, jitter, iresponse, smooth.col, grid.col, inverse.func, grid.func, grid.levels, extend, ngrid1, is.int.only, level, func, nrug, # the following args are generated in plotmo draw.plot, # draw.plot=FALSE means get predictions but don't actually plot x, y, singles, resp.levs, ux.list, ndiscrete, pred.names, abbr.pred.names, nfigs, uy, xflip, jittered.y, n.apartdep, ...) { get.degree1.data <- function(isingle) { # check if plot_degree1 was already called by get.ylim.by.dummy.plots data <- degree1.data(isingle) if(!is.null(data)) # data is already initialized? return(data) # yes, use it intervals <- NULL # prediction intervals, NULL if level argument not used # create data.frame of predictor values to be plotted, # by updating xgrid for this predictor (one column gets updated) xframe <- get.degree1.xframe(xgrid, x, ipred, ngrid1, ndiscrete, ux.list, extend) trace2(trace, "degree1 plot%d (pmethod \"%s\") variable %s\n", isingle, pmethod, pred.names[ipred]) if(pmethod == "partdep" || pmethod == "apartdep") { # following commented out because causes warning in R 4.2.0: length(x) = 64 > 1' in coercion to 'logical(1)' # stopifnot(!is.na(partdep.x) && !is.null(partdep.x)) yhat <- degree1.partdep.yhat(object, type, nresponse, pmethod, inverse.func, trace2, partdep.x, xframe, ipred, pred.names, resp.levs, ...) if(level > 0) { # get prediction intervals? warning0( "ignoring the 'level' argument because plotmo pmethod=\"", pmethod, "\"") level <- 0 } } else { # classic plotmo plot yhat <- plotmo_predict(object, xframe, nresponse, type, resp.levs, trace2, inverse.func, ...)$yhat if(level > 0) # get prediction intervals? intervals <- plotmo_pint(object, xframe, type, level, trace2, ipred, inverse.func) } temp <- blockify.degree1.frame(xframe, yhat, intervals, ipred, ux.list, ndiscrete) xframe <- temp$xframe yhat <- temp$yhat intervals <- temp$intervals if(center) { yhat <- my.center(yhat, trace2) intervals$fit <- my.center(intervals$fit, trace2) intervals$lwr <- my.center(intervals$lwr, trace2) intervals$upr <- my.center(intervals$upr, trace2) intervals$cint.lwr <- my.center(intervals$cint.lwr, trace2) intervals$cint.upr <- my.center(intervals$cint.upr, trace2) } all.yhat <- c(all.yhat, yhat, intervals$lwr, intervals$upr, intervals$cint.lwr, intervals$cint.upr) data <- list(xframe=xframe, yhat=yhat, intervals=intervals, all.yhat=all.yhat) if(!draw.plot) # save the data, if there is going to be a next time degree1.data(isingle, data) data } draw.degree1 <- function(...) { draw.degree1.fac <- function(...) { draw.grid(grid.col, nx=NA, ...) # nx=NA for horiz-only grid draw.fac.intervals(xframe[,ipred], intervals, ...) if(is.specified(pt.col)) points.or.text(x=jittered.x, y=yscale * (yshift + jittered.y), pt.col=pt.col, iresponse=iresponse, ...) draw.smooth1(smooth.col, x, ipred, yscale * (yshift + y), ux.list, ndiscrete, center, ...) # formal args for plot.factor, needed because "CRAN check" # doesn't allow ":::" and plot.factor isn't public plot.factor.formals <- c("x", "y", "legend.text") call.plot(graphics::plot, # calls plot.factor PREFIX = "degree1.", FORMALS = plot.factor.formals, TRACE = if(isingle == 1 && trace >= 2) trace-1 else 0, force.x = xframe[,ipred], force.y=yhat, force.add = TRUE, def.xaxt = if(xaxis.is.levs) "n" else "s", def.yaxt = if(yaxis.is.levs) "n" else "s", force.lty = 1, # else lty=2 say is printed weirdly force.lwd = 1, ...) if(xaxis.is.levs) # plot x level names along the x axis mtext(xlevnames, side=1, at=1:length(xlevnames), cex=par("cex") * cex.lab, line=.5, las=get.las(xlevnames)) if(yaxis.is.levs) # plot y level names along the y axis mtext(ylevnames, side=2, at=1:length(ylevnames), cex=par("cex") * cex.lab, line=.5, las=get.las(ylevnames)) } draw.degree1.numeric <- function(...) { draw.grid(grid.col, ...) draw.numeric.intervals(xframe[,ipred], intervals, ...) draw.func(func, object, xframe, ipred, center, trace, ...) if(is.specified(pt.col)) points.or.text(x=jittered.x, y=yscale * (yshift + jittered.y), pt.col=pt.col, iresponse=iresponse, ...) draw.smooth1(smooth.col, x, ipred, yscale * (yshift + y), ux.list, ndiscrete, center, ...) call.plot(graphics::lines.default, PREFIX="degree1.", force.x = xframe[,ipred], force.y = yhat, force.col = dota("degree1.col col.degree1 col", EX=c(0,1,1), DEF=1, NEW=1, ...), force.lty = dota("degree1.lty lty.degree1 lty", EX=c(0,1,1), DEF=1, NEW=1, ...), force.lwd = dota("degree1.lwd lwd.degree1 lwd", EX=c(0,1,1), DEF=1, NEW=1, ...), ...) draw.degree1.numeric.rug(nrug, numeric.x, jittered.x, ...) } #--- draw.degree1 starts here x1 <- x[,ipred] numeric.x <- jittered.x <- as.numeric(x1) jittered.x <- apply.jitter(numeric.x, jitter) xlim <- get.degree1.xlim(ipred, xframe, ux.list, ndiscrete, pt.col, jittered.x, xflip, ...) # title of the current plot main <- dota("main", ...) main <- if(is.specified(main)) repl(main, isingle)[isingle] else { main <- "" if(nfigs > 1 && !is.degree.specified(degree1)) main <- paste0(isingle, " ") # show plot number in headers paste(main, abbr.pred.names[ipred]) } xlevnames <- abbreviate(levels(xframe[,ipred]), minlength=6, strict=TRUE) xaxis.is.levs <- is.factor(x1) && length(xlevnames) <= 12 yaxis.is.levs <- length(resp.levs) >= 1 && length(resp.levs) <= 12 if(yaxis.is.levs) ylevnames <- abbreviate(resp.levs, minlength=6, strict=TRUE) yaxis.is.levs <- FALSE # TODO should only do this if response is a string or a factor xlab <- dota("xlab", ...) xlab <- if(is.null(xlab)) abbr.pred.names[ipred] else if(is.specified(xlab)) repl(xlab, isingle)[isingle] else "" ylab <- dota("ylab", DEF=NULL, ...) ylab <- if(is.specified(ylab)) repl(ylab, isingle)[isingle] else "" call.plot(graphics::plot.default, PREFIX="degree1.", TRACE = if(isingle == 1 && trace >= 2) trace-1 else 0, force.x = xframe[,ipred], force.y = yhat, force.type = "n", # nothing in interior of plot yet force.main = main, force.xlab = xlab, force.ylab = ylab, force.xlim = xlim, force.ylim = ylim, def.xaxt = if(xaxis.is.levs) "n" else "s", def.yaxt = if(yaxis.is.levs) "n" else "s", ...) if(yaxis.is.levs) # plot y level names along the y axis mtext(ylevnames, side=2, at=1:length(ylevnames), cex=par("cex") * cex.lab, line=.5, las=get.las(ylevnames)) if(center && !is.specified(grid.col) && !is.specified(dota("col.grid", ...))) abline(h=0, col="gray", lwd=.6) # gray line at y=0 temp <- get.y.shift.scale(pt.col, ylim, uy, ndiscrete, trace) yshift <- temp$yshift yscale <- temp$yscale if(is.factor(x1)) draw.degree1.fac(...) else draw.degree1.numeric(...) if(is.int.only) # make it obvious that this is an intercept-only model legend("topleft", "intercept-only model", bg="white") } #--- plot_degree1 starts here trace2(trace, "--plot.degree1(draw.plot=%s)\n", if(draw.plot) "TRUE" else "FALSE") # get the x matrix we will plot, will be updated later for each predictor one by one if(!is.null(degree1.xgrid.global)) # already have the data? xgrid <- degree1.xgrid.global # yes, use it else { xgrid <- get.degree1.xgrid(x, grid.func, grid.levels, pred.names, ngrid1) if(!draw.plot) # save the data, if there is going to be a next time assignInMyNamespace("degree1.xgrid.global", xgrid) } if(!is.null(partdep.x.global)) # already have partdep.x? partdep.x <- partdep.x.global # yes use it else { partdep.x <- get.partdep.x(pmethod, x, y, n.apartdep, grid.levels, pred.names) if(!draw.plot) # save the data, if there is going to be a next time assignInMyNamespace("partdep.x.global", partdep.x) } if(pmethod == "plotmo" && draw.plot && trace >= 0 && ncol(xgrid) > 1) print_grid_values(xgrid, trace) cex.lab <- dota("cex.lab", DEF=.8 * par("cex.main"), ...) all.yhat <- NULL for(isingle in seq_along(singles)) { if(isingle == 2 && trace2 == 2) { trace2 <- 1 printf("Reducing trace level for subsequent degree1 plots\n") } ipred <- singles[isingle] # ipred is the predictor index i.e. col in model mat # following happens with lm if you do e.g. ozone1$doy <- NULL after using ozone1 # this won't catch all such errors if(ipred > NCOL(x)) stop0("illegal index=", ipred, " (missing column in x?) NCOL(x)=", NCOL(x)) temp <- get.degree1.data(isingle) xframe <- temp$xframe yhat <- temp$yhat intervals <- temp$intervals all.yhat <- temp$all.yhat if(draw.plot) draw.degree1(...) } all.yhat # numeric vector of all predicted values } # When we are predicting a probability (0 to 1), we want the displayed # points to be on the plot, even if factor levels are say 1 and 2. # In that situation, we scale the displayed points into range 0...1. get.y.shift.scale <- function(pt.col, ylim, uy, ndiscrete, trace) { yshift <- 0 yscale <- 1 if(is.specified(pt.col)) { # for efficiency, only calculate if necessary ymin <- min(uy) ymax <- max(uy) if(is.specified(ylim[1]) && round(ylim[1]) >= 0 && is.specified(ylim[2]) && round(ylim[2]) <= 1 && # check that y is a factor (or factor-like) round(ymax) == ymax && length(uy) <= ndiscrete && min(uy) >= 0) { yshift <- -ymin yscale <- 1 / (yshift + ymax) trace2(trace, "Will shift and scale displayed points specified by pt.col: yshift %g yscale %g\n", yshift, yscale) } } list(yshift=yshift, yscale=yscale) } get.degree1.xlim <- function(ipred, xframe, ux.list, ndiscrete, pt.col, jittered.x, xflip, ...) { xlim <- dota("xlim", ...) if(is.specified(xlim)) stopifnot(is.numeric(xlim), length(xlim) == 2) else { x1 <- xframe[,ipred] xlim <- range1(x1) if(is.factor(x1)) { xlim[1] <- xlim[1] - .4 xlim[2] <- xlim[2] + .4 } else if(length(ux.list[[ipred]]) <= ndiscrete) xlim <- c(xlim[1] - .1, xlim[2] + .1) if(is.specified(pt.col)) xlim <- range1(xlim, jittered.x) } xlim <- fix.lim(xlim) if(xflip) { temp <- xlim[1] xlim[1] <- xlim[2] xlim[2] <- temp } xlim } apply.jitter <- function(x, jitter, adjust=1) { if(jitter == 0) return(x) jitter(x, factor=adjust * jitter) } get.iresponse <- function(npoints, ncases) # get indices of xrows { check.integer.scalar(npoints) if(npoints == 0) return(NULL) if(npoints == 1) npoints <- -1 if(npoints <= 1 || npoints > ncases) # -1 or TRUE means all cases npoints <- ncases if(npoints == ncases) seq_len(ncases) else sample(seq_len(ncases), size=npoints, replace=FALSE) } draw.smooth1 <- function(smooth.col, x, ipred, y, ux.list, ndiscrete, center, ...) { if(!is.specified(smooth.col)) return(NULL) x1 <- x[,ipred] is.discrete.x <- FALSE if(is.factor(x1)) { is.discrete.x <- TRUE levels <- sort_unique(as.numeric(x1)) } else if(length(ux.list[[ipred]]) <= ndiscrete) { is.discrete.x <- TRUE levels <- ux.list[[ipred]] } if(is.discrete.x) { # x1 has discrete levels, display the mean y at each value of x1 smooth <- sapply(split(y, x1), mean) if(center) smooth <- my.center(smooth) else smooth call.plot(graphics::lines.default, PREFIX="smooth.", drop.f=1, force.x = levels, force.y = smooth, force.col = smooth.col, force.lty = dota("smooth.lty lty.smooth", EX=c(0,1), DEF=1, NEW=1, ...), force.lwd = dota("smooth.lwd lwd.smooth lwd.loess", EX=c(0,1,1), DEF=1, NEW=1, ...), force.pch = dota("smooth.pch", DEF=20, EX=0, ...), def.type = "b", ...) } else { # For less smoothing (so we can better judge earth inflection points), # we use a default value for f lower than the default 2/3. smooth.f <- dota("smooth.f loess.f", DEF=.5, NEW=1, ...) check.numeric.scalar(smooth.f) stopifnot(smooth.f > .01, smooth.f < 1) smooth <- lowess(x1, y, f=smooth.f) y <- if(center) my.center(smooth$y) else smooth$y call.plot(graphics::lines.default, PREFIX="smooth.", drop.f=1, force.x = smooth$x, force.y = y, force.col = smooth.col, force.lty = dota("smooth.lty lty.smooth", EX=c(0,1), DEF=1, NEW=1, ...), force.lwd = dota("smooth.lwd lwd.smooth lwd.loess", EX=c(0,1,1), DEF=1, NEW=1, ...), force.pch = dota("smooth.pch", DEF=20, EX=0, ...), ...) } } draw.degree1.numeric.rug <- function(nrug, numeric.x, jittered.x, ...) { if(is.character(nrug)) draw.density.along.the.bottom(numeric.x, ...) else { # must be numeric nrug check.integer.scalar(nrug, logical.ok=TRUE) rug.x <- # nrug < 0 is for backwards compat if(nrug == 1 || nrug < 0 || nrug > length(numeric.x)) jittered.x else if(nrug > 0) quantile(numeric.x, probs=seq(from=0, to=1, length.out=nrug+1), na.rm=TRUE, names=FALSE) else NA if(length(rug.x) > 1) { stopifnot(length(jittered.x) == length(numeric.x)) call.plot(graphics::rug, force.x=rug.x, def.quiet=TRUE, ...) } } } draw.grid <- function(grid.col, nx=NULL, ...) { if(is.specified(grid.col) || is.specified(dota("col.grid", ...))) { if(is.specified(grid.col) && is.logical(grid.col) && grid.col) grid.col <- "lightgray" grid.col <- if(is.specified(grid.col)) grid.col else dota("col.grid", DEF="lightgray", ...) # grid() doesn't have a dots arg so we invoke call.plot without dots call.plot(graphics::grid, force.nx = dota("grid.nx", DEF=nx, ...), force.ny = dota("grid.ny", DEF=NULL, ...), force.col = grid.col, force.lty = dota("grid.lty", DEF=1, ...), force.lwd = dota("grid.lwd", DEF=1, ...)) } } get.level.shades <- function(intervals, ...) { level.shade <- dota("level.shade shade.pints", DEF="mistyrose2", ...) if(is.null(intervals$lwr) || is.null(intervals$cint.lwr)) c(level.shade, level.shade) else { # use level.shade2 only if two kinds of intervals # use exact match here because level.shade2 is also matched by level.shade level.shade2 <- dota("level.shade2 shade2.pints", DEF="mistyrose4", ...) c(level.shade, level.shade2) } } # draw std err bars for a numeric predictor draw.numeric.intervals <- function(x, intervals, ...) { if(!is.null(intervals)) { level.shades <- get.level.shades(intervals, ...) if(!is.null(intervals$lwr)) polygon1(x=x, lwr=intervals$lwr, upr=intervals$upr, shade=level.shades[1], ...) if(!is.null(intervals$cint.lwr)) polygon1(x=x, lwr=intervals$cint.lwr, upr=intervals$cint.upr, shade=level.shades[2]) if(!is.null(intervals$lwr) || !is.null(intervals$cint.lwr)) box() # replot the box because intervals sometimes drawn over it } } # TODO you can't get just the confidence lines with no shading, following looks not ok: # plotmo(a, level=.8, level.lty=1, level.border=1, level.shade=2, level.density=0) polygon1 <- function(x, lwr, upr, shade, ...) { call.plot(graphics::polygon, PREFIX="level.", drop.shade=1, drop.shade2=1, force.x = c(x[1], x, rev(x)), force.y = c(lwr[1], lwr, rev(upr)), force.col = shade, def.border = shade, def.lty = 0, ...) } # draw std err bands for a factor predictor draw.fac.intervals <- function(x, intervals, ...) { draw.intervals <- function(lwr, upr, shade) { for(ilev in seq_along(levels(x))) { min <- min(lwr[[ilev]]) max <- max(upr[[ilev]]) polygon(c(ilev - .4, ilev - .4, ilev + .4, ilev + .4), c(min, max, max, min), col=shade, border=shade, lty=0) } } if(!is.null(intervals)) { level.shades <- get.level.shades(intervals, ...) if(!is.null(intervals$lwr)) draw.intervals(split(intervals$lwr, x), split(intervals$upr, x), level.shades[1]) if(!is.null(intervals$cint.lwr)) draw.intervals(split(intervals$cint.lwr, x), split(intervals$cint.upr, x), level.shades[2]) if(!is.null(intervals$lwr) || !is.null(intervals$cint.lwr)) box() # replot the box because intervals sometimes drawn over it } } # draw the func arg, if specified draw.func <- function(func, object, xframe, ipred, center, trace, ...) { if(!is.null(func)) { print_summary(xframe, "Data for func", trace) if(!is.function(func)) stop0("'func' is not a function"); y <- process.y(func(xframe), object, type="response", nresponse=1, nrow(xframe), expected.levs=NULL, trace, "func returned")$y if(center) y <- my.center(y, trace) call.plot(graphics::lines.default, PREFIX="func.", force.x = xframe[,ipred], force.y = y, def.type = "l", force.col = dota("func.col col.func", EX=c(0,1), DEF="lightblue3", NEW=1, ...), force.lty = dota("func.lty lty.func", EX=c(0,1), DEF=1, NEW=1, ...), force.lwd = dota("func.lwd lwd.func", EX=c(0,1), DEF=2, NEW=1, ...), ...) } } get.def.nticks <- function(x, ipred1, ipred2) # for persp plot { # nticks is just a suggestion for persp, so we don't fret over it too much nticks <- 5 # default nticks if both axes numeric (no factors) if(is.factor(x[[ipred1]])) # use number of factor levels to nticks <- length(levels(x[[ipred1]])) # avoid e.g. "1.5" on factor axes if(is.factor(x[[ipred2]])) nticks <- max(nticks, length(levels(x[[ipred2]]))) nticks <- max(nticks, 2) # must be at least 2 min(nticks, 6) # but not more than 6 (not enough space) } plot_degree2 <- function( # plot all degree2 graphs # copy of args from plotmo, some have been tweaked slightly object, degree2, all2, center, ylim, type, nresponse, pmethod, clip, trace, trace2, pt.col, jitter, iresponse, inverse.func, grid.func, grid.levels, extend, type2, ngrid2, # the following args are generated in plotmo draw.plot, # draw.plot=FALSE means get and return all.yhat but don't actually plot do.par, x, y, pairs, resp.levs, ux.list, ndiscrete, pred.names, abbr.pred.names, nfigs, nsingles, npairs, xflip, yflip, swapxy, def.cex.main, n.apartdep, ...) { get.degree2.data <- function(ipair) { data <- degree2.data(ipair) if(!is.null(data)) # data is already initialized? return(data) # yes, use it # create data.frame of x values to be plotted, # by updating xgrid for this predictor (two columns get updated) # (but for partdep plots, xframe isn't used, we use just x1grid and x2grid) temp <- get.degree2.xframe(xgrid, x, ipred1, ipred2, ngrid2, xranges, ux.list, ndiscrete) xframe <- temp$xframe # data frame of medians x1grid <- temp$x1grid # vec of values for the first predictor x2grid <- temp$x2grid # vec of values for the second predictor trace2(trace, "degree2 plot%d (pmethod \"%s\") variables %s:%s\n", ipair, pmethod, pred.names[ipred1], pred.names[ipred2]) if(pmethod == "partdep" || pmethod == "apartdep") { # following commented out because causes warning in R 4.2.0: length(x) = 91 > 1' in coercion to 'logical(1)' # stopifnot(!is.na(partdep.x) && !is.null(partdep.x)) yhat <- degree2.partdep.yhat(object, type, nresponse, pmethod, inverse.func, trace, partdep.x, x1grid, ipred1, x2grid, ipred2, pred.names, resp.levs, ...) } else { # classic plotmo plot yhat <- plotmo_predict(object, xframe, nresponse, type, resp.levs, trace2, inverse.func, ...)$yhat } x1grid <- as.numeric(x1grid) x2grid <- as.numeric(x2grid) # image plots for factors look better if not blockified if(type2 != "image") { temp <- blockify.degree2.frame(x, yhat, x1grid, x2grid, ipred1, ipred2, ux.list, ndiscrete) yhat <- temp$yhat x1grid <- temp$x1grid x2grid <- temp$x2grid } if(center) yhat <- my.center(yhat, trace2) data <- list(xframe=xframe, x1grid=x1grid, x2grid=x2grid, yhat=matrix(yhat, nrow=length(x1grid), ncol=length(x2grid)), def.nticks=get.def.nticks(x, ipred1, ipred2)) if(!draw.plot) # save the data, if there is going to be a next time degree2.data(ipair, data) data } draw.degree2 <- function(type2 = c("persp", "contour", "image"), def.nticks, ...) { name1 <- abbr.pred.names[ipred1] name2 <- abbr.pred.names[ipred2] # title of the current plot main <- dota("main", ...) main <- if(is.specified(main)) repl(main, nsingles+ipair)[nsingles+ipair] else { main <- "" if(nfigs > 1 && !is.degree.specified(degree2)) main <- paste0(ipair, " ") # show plot number in headers if(swapxy) paste0(main, name2, ": ", name1) else paste0(main, name1, ": ", name2) } if(clip) { yhat[yhat < ylim[1]] <- NA # we don't clip upper values for persp plot because its own clipping is ok # (whereas its own clipping for lower values tends to allow overwrite of axes). if(type2 != "persp") yhat[yhat > ylim[2]] <- NA } switch(type2, persp=plot.persp( x=x, x1grid=x1grid, x2grid=x2grid, yhat=yhat, name1=name1, name2=name2, ipred1=ipred1, ipred2=ipred2, ipair=ipair, nsingles=nsingles, trace=trace, ylim=ylim, xflip=xflip, yflip=yflip, swapxy=swapxy, ngrid2=ngrid2, main2=main, ticktype2=ticktype, def.cex.main=def.cex.main, def.nticks=def.nticks, ...), contour=plot.contour( x=x, x1grid=x1grid, x2grid=x2grid, yhat=yhat, name1=name1, name2=name2, ipred1=ipred1, ipred2=ipred2, xflip=xflip, yflip=yflip, swapxy=swapxy, main2=main, pt.col=pt.col, jitter=jitter, ux.list=ux.list, ndiscrete=ndiscrete, iresponse=iresponse, ...), image=plot.image( x=x, x1grid=x1grid, x2grid=x2grid, yhat=yhat, name1=name1, name2=name2, ipred1=ipred1, ipred2=ipred2, xflip=xflip, yflip=yflip, swapxy=swapxy, main2=main, pt.col=pt.col, jitter=jitter, ux.list=ux.list, ndiscrete=ndiscrete, iresponse=iresponse, ...)) } #--- plot_degree2 starts here trace2(trace, "--plot.degree2(draw.plot=%s)\n", if(draw.plot) "TRUE" else "FALSE") stopifnot(npairs > 0) # need ticktype to determine degree2 margins ticktype <- dota("persp.ticktype", DEF="simple", EX=0, ...) ticktype <- match.choices(ticktype, c("simple", "detailed"), "ticktype") simple.ticktype <- substr(ticktype, 1, 1) == "s" if(draw.plot) { if(do.par) { opar=par("mar", "mgp") on.exit(par(mar=opar$mar, mgp=opar$mgp)) do.degree2.auto.par(type2, nfigs, simple.ticktype) } else if(nsingles && type2 == "persp") { # persp needs smaller margins than degree1 plots # the nsingles check above prevents us from modifying margins # if the user is simply plotting one or more degree2 plots opar=par("mar", "mgp") on.exit(par(mar=opar$mar, mgp=opar$mgp)) do.persp.auto.par(simple.ticktype) } } # get the x matrix we will plot, will be updated later for each pair of predictors xranges <- get.degree2.xranges(x, extend, ux.list, ndiscrete) if(!is.null(degree2.xgrid.global)) # already have the data? xgrid <- degree2.xgrid.global # yes, use it else { xgrid <- get.degree2.xgrid(x, grid.func, grid.levels, pred.names, ngrid2) if(!draw.plot) # save the data, if there is going to be a next time assignInMyNamespace("degree2.xgrid.global", xgrid) } if(!is.null(partdep.x.global)) # already have partdep.x? partdep.x <- partdep.x.global # yes use it else { partdep.x <- get.partdep.x(pmethod, x, y, n.apartdep, grid.levels, pred.names) if(!draw.plot) # save the data, if there is going to be a next time assignInMyNamespace("partdep.x.global", partdep.x) } all.yhat <- NULL for(ipair in seq_len(npairs)) { ipred1 <- pairs[ipair,1] # index of first predictor ipred2 <- pairs[ipair,2] # index of second predictor if(ipair == 2 && trace2 == 2) { trace2 <- 1 printf("Reducing trace level for subsequent degree2 plots\n") } temp <- get.degree2.data(ipair) xframe <- temp$xframe x1grid <- temp$x1grid x2grid <- temp$x2grid yhat <- temp$yhat all.yhat <- c(all.yhat, yhat) if(draw.plot) draw.degree2(type2, temp$def.nticks, ...) } all.yhat } get.degree2.xranges <- function(x, extend, ux.list, ndiscrete) { # we use a data.frame for xranges so columns can have different types (e.g. Dates) xranges <- as.data.frame(matrix(NA, ncol=ncol(x), nrow=2)) colnames(xranges) <- colnames(x) for(icol in seq_len(ncol(x))) { x1 <- x[,icol] xrange <- range1(x1, na.rm=TRUE) nxvals <- length(ux.list[[icol]]) # TODO this extends xrange correctly but that doesn't suffice # because get.degree2.xframe doesn't necessarily use xranges if(extend != 0 && nxvals > ndiscrete && !is.factor(x1)) { stopifnot(xrange[2] >= xrange[1]) ext <- extend * (xrange[2] - xrange[1]) xrange[1] <- xrange[1] - ext xrange[2] <- xrange[2] + ext } xranges[,icol] <- xrange } xranges } draw.response.sites <- function(x, ipred1, ipred2, pt.col, jitter, ux.list, ndiscrete, iresponse, swapxy, ...) { if(swapxy) { x1 <- x[,ipred2] x2 <- x[,ipred1] } else { x1 <- x[,ipred1] x2 <- x[,ipred2] } points.or.text( x=apply.jitter(as.numeric(x1), jitter, adjust=1.5), y=apply.jitter(as.numeric(x2), jitter, adjust=1.5), pt.col=pt.col, iresponse=iresponse, ...) } get.diag.val <- function(yhat, diag1, diag2) # return first non NA along diag { vals <- yhat[diag1, diag2] (vals[!is.na(vals)])[1] # return first non NA in vals, length zero if all NA } plot.persp <- function(x, x1grid, x2grid, yhat, name1, name2, ipred1, ipred2, ipair, nsingles, trace, ylim, xflip, yflip, swapxy, ngrid2, main2, ticktype2, def.cex.main, def.nticks, ...) { get.theta <- function(...) # theta arg for persp() { theta <- dota("persp.theta theta", EX=c(0,1), ...) if(anyNA(theta)) { # theta not specified by the user? # rotate graph so highest point is farthest (this can swap axes) # imax corner numbering with theta=-35 # 1 # 2 /\ 4 # \/ # 3 theta <- -35 nr <- nrow(yhat) nc <- ncol(yhat) imax <- which.max(c( get.diag.val(yhat, nr:1, nc:1), get.diag.val(yhat, 1:nr, nc:1), get.diag.val(yhat, 1:nr, 1:nc), get.diag.val(yhat, nr:1, 1:nc))) if(length(imax)) # length>0 unless entire diag is NA theta <- theta + switch(imax, 0, 90, 180, 270) } theta } #--- plot.persp starts here # following needed because persp() rejects a reversed xlim or ylim if(xflip) warning0("ignoring xflip=TRUE for persp plot") if(yflip) warning0("ignoring yflip=TRUE for persp plot") theta <- get.theta(...) cex1 <- par("cex") # persp needs an explicit cex arg, doesn't use par("cex") trace2(trace, "persp(%s:%s) theta %.3g\n", name1, name2, theta) if(swapxy) { temp <- x1grid; x1grid <- x2grid; x2grid <- temp # swap x1grid and x2grid temp <- ipred1; ipred1 <- ipred2; ipred2 <- temp # swap ipred1 and ipred2 temp <- name1; name1 <- name2; name2 <- temp # swap name1 and name2 yhat <- t(yhat) } zlab <- dota("ylab", DEF="", ...) # use ylab as zlab if specified zlab <- repl(zlab, nsingles+ipair)[nsingles+ipair] # zlab <- paste0("\n", zlab) # else zlab is too close to axis labels cex.lab <- dota("persp.cex.lab", # make the labels small if multiple figures DEF=if(def.cex.main < 1) .8 * def.cex.main else 1, ...) # persp ignores mgp so prefix a newline to space the axis label # we also prepend spaces else bottom of label tends to get cut off if(theta < 0) theta <- theta + 360 theta <- theta %% 360 if((0 < theta && theta <= 90) || (180 < theta && theta <= 270)) { xlab <- paste0("\n", name1, " ") ylab <- paste0("\n ", name2) } else { xlab <- paste0("\n ", name1) ylab <- paste0("\n", name2, " ") } # We use deprefix directly (and not call.plot) because # we have to do a bit of manipulation of the args for nticks. # Also we cannot use graphics:::persp.default because CRAN check complains # about ":::". Instead we explicitly pass the formal argnames with formals. persp.def.formals <- c( # formal args for persp.default (R version 3.2.0) "x", "y", "z", "xlim", "zlim", "xlab", "ylab", "zlab", "main", "sub", "theta", "phi", "r", "d", "scale", "expand", "col", "border", "ltheta", "lphi", "shade", "box", "axes", "nticks", "ticktype") args <- deprefix(graphics::persp, # calls persp.default FNAME = "persp", KEEP = "PREFIX,PLOT.ARGS", FORMALS = persp.def.formals, TRACE = if(ipair == 1 && trace >= 2) trace-1 else 0, force.x = x1grid, force.y = x2grid, force.z = yhat, force.xlim = range(x1grid), # prevent use of user specified xlim and ylim force.ylim = range(x2grid), # persp won't accept zlim=NULL force.zlim = if(is.null(ylim)) ylim <- range(yhat) else ylim, force.xlab = xlab, force.ylab = ylab, force.theta = theta, force.phi = dota("persp.phi phi", EX=c(0,1), DEF=30, ...), force.d = dota("persp.d dvalue", EX=c(0,1), DEF=1, ...), force.main = main2, def.cex.lab = cex.lab, def.cex.axis = cex.lab, def.zlab = zlab, def.ticktype = "simple", def.nticks = def.nticks, def.cex = cex1, force.col = dota("persp.col col.persp", EX=c(0,1), DEF="lightblue", NEW=1, ...), def.border = NULL, def.shade = .5, ...) # if ticktype="simple" we must call persp without the nticks arg # else persp emits confusing error messages if(substr(ticktype2, 1, 1) == "s") args["nticks"] <- NULL # We use suppressWarnings below to suppress the warning # "surface extends beyond the box" that was introduced in R 2.13-1. # This warning may be issued multiple times and may be annoying to the plotmo user. # (Unfortunately this also suppress any other warnings in persp.) # TODO Want to use lab=c(2,2,7) or similar in persp but persp ignores it suppressWarnings( do.call.trace(graphics::persp, args, fname="graphics::persp", trace=0)) } plot.contour <- function(x, x1grid, x2grid, yhat, name1, name2, ipred1, ipred2, xflip, yflip, swapxy, main2, pt.col, jitter, ux.list, ndiscrete, iresponse, ...) { get.lim <- function(xflip, x1grid, ipred) { # contour() automatically extends ylim, so we don't need to do it here xrange <- range(x1grid) if(xflip) c(xrange[2], xrange[1]) else c(xrange[1], xrange[2]) } #--- plot.contour starts here x1 <- x[,ipred1] x2 <- x[,ipred2] levnames1 <- levels(x1) levnames2 <- levels(x2) is.fac1 <- is.factor(x1) && length(levnames1) <= 12 is.fac2 <- is.factor(x2) && length(levnames2) <= 12 xlab <- if(is.fac1) "" else name1 # no lab if fac else on top of lev name ylab <- if(is.fac2) "" else name2 if(swapxy) { temp <- levnames2; levnames2 <- levnames1; levnames1 <- temp temp <- is.fac2; is.fac2 <- is.fac1; is.fac1 <- temp temp <- ylab; ylab <- xlab; xlab <- temp } xlim <- get.lim(xflip, x1grid, ipred1) ylim <- get.lim(yflip, x2grid, ipred2) if(swapxy) { temp <- xlim; xlim <- ylim; ylim <- temp } levels <- get.contour.levs(yhat) labels <- signif(levels, 2) # else contour prints labels like 0.0157895 cex.lab <- par("cex") * dota("cex.lab", DEF=1, ...) # We use suppressWarnings below to suppress the warning "all z values are # equal" This warning may be issued multiple times and may be annoying to # the plotmo user. (Unfortunately this also suppress any other warnings # in contour.default.) suppressWarnings( call.plot(graphics::contour.default, force.x = if(swapxy) x2grid else x1grid, force.y = if(swapxy) x1grid else x2grid, force.z = if(swapxy) t(yhat) else yhat, force.xlim = xlim, force.ylim = ylim, force.xlab = xlab, force.ylab = ylab, def.xaxt = if(is.fac1) "n" else "s", def.yaxt = if(is.fac2) "n" else "s", def.main = main2, def.levels = levels, def.labels = labels, def.labcex = par("cex") * cex.lab, ...)) if(is.fac1) { levnames1 <- abbreviate(levnames1, minlength=6, strict=TRUE) mtext(levnames1, side=1, at=1:length(levnames1), cex=cex.lab, line=.5, las=get.las(levnames1)) } if(is.fac2) mtext(abbreviate(levnames2, minlength=6, strict=TRUE), side=2, at=1:length(levnames2), cex=cex.lab, line=.5, las=2) if(is.specified(pt.col)) draw.response.sites(x=x, ipred1=ipred1, ipred2=ipred2, pt.col=pt.col, jitter=jitter, ux.list=ux.list, ndiscrete=ndiscrete, iresponse=iresponse, swapxy=swapxy, ...) } get.contour.levs <- function(yhat) { # the default, as calculated internally by plot.contour levs <- pretty(range(yhat, finite=TRUE), 10) # reduce the default if the number of unique yhat values is less # this is mainly for factors unique.yhat <- sort_unique(yhat) if(length(unique.yhat) > 1 && length(unique.yhat) < length(levs)) levs <- unique.yhat levs } plot.image <- function(x, x1grid, x2grid, yhat, name1, name2, ipred1, ipred2, xflip, yflip, swapxy, main2, pt.col, jitter, ux.list, ndiscrete, iresponse, ...) { # like image but fill the plot area with lightblue first so NAs are obvious image.with.lightblue.na <- function(x1grid, x2grid, yhat, ...) { if(anyNA(yhat)) { image(x1grid, x2grid, matrix(0, nrow(yhat), ncol(yhat)), col="lightblue", xlab="", ylab="", xaxt="n", yaxt="n", bty="n", main="") par(new=TRUE) # so next plot is on top of this plot } call.plot(graphics::image.default, force.x=x1grid, force.y=x2grid, force.z=yhat, ...) box() # image() tends to overwrite the borders of the box } get.lim <- function(xflip, x1grid, is.discrete) { xrange <- range(x1grid) if(is.discrete) { xrange[1] <- xrange[1] - .5 xrange[2] <- xrange[2] + .5 } else { range <- xrange[2] - xrange[1] # .025 seems the max we can use without getting unsightly # gaps at the edges of the plot xrange[1] <- xrange[1] - .025 * range xrange[2] <- xrange[2] + .025 * range } if(xflip) c(xrange[2], xrange[1]) else c(xrange[1], xrange[2]) } #--- plot.image starts here x1 <- x[,ipred1] x2 <- x[,ipred2] levnames1 <- levels(x1) levnames2 <- levels(x2) use.fac.names1 <- is.factor(x1) && length(levnames1) <= 12 use.fac.names2 <- is.factor(x2) && length(levnames2) <= 12 xlab <- if(use.fac.names1) "" else name1 # no lab if fac else on top of lev name ylab <- if(use.fac.names2) "" else name2 if(swapxy) { temp <- levnames2; levnames2 <- levnames1; levnames1 <- temp temp <- use.fac.names2; use.fac.names2 <- use.fac.names1; use.fac.names1 <- temp temp <- ylab; ylab <- xlab; xlab <- temp } xlim <- get.lim(xflip, x1grid, use.fac.names1 || length(ux.list[[ipred1]]) <= ndiscrete) ylim <- get.lim(yflip, x2grid, use.fac.names2 || length(ux.list[[ipred2]]) <= ndiscrete) # default col: white high values (snowy mountain tops), dark low values (dark depths) if(swapxy) image.with.lightblue.na(x1grid=x2grid, x2grid=x1grid, yhat=t(yhat), force.col = dota("image.col col.image", EX=c(0,1), DEF=grDevices::gray((0:10)/10), NEW=1, ...), force.main = main2, force.xlim = ylim, force.ylim = xlim, force.xaxt = if(use.fac.names1) "n" else "s", force.yaxt = if(use.fac.names2) "n" else "s", force.xlab = xlab, force.ylab = ylab, ...) else image.with.lightblue.na(x1grid=x1grid, x2grid=x2grid, yhat=yhat, force.col = dota("image.col col.image", EX=c(0,1), DEF=grDevices::gray((0:10)/10), NEW=1, ...), force.main = main2, force.xlim = xlim, force.ylim = ylim, force.xaxt = if(use.fac.names1) "n" else "s", force.yaxt = if(use.fac.names2) "n" else "s", force.xlab = xlab, force.ylab = ylab, ...) cex.lab <- par("cex") * dota("cex.lab", DEF=1, ...) if(use.fac.names1) { levnames1 <- abbreviate(levnames1, minlength=6, strict=TRUE) mtext(levnames1, side=1, at=1:length(levnames1), cex=cex.lab, line=.5, las=get.las(levnames1)) } if(use.fac.names2) mtext(abbreviate(levnames2, minlength=6, strict=TRUE), side=2, at=1:length(levnames2), cex=cex.lab, line=.5, las=2) if(is.specified(pt.col)) draw.response.sites(x=x, ipred1=ipred1, ipred2=ipred2, pt.col=pt.col, jitter=jitter, ux.list=ux.list, ndiscrete=ndiscrete, iresponse=iresponse, swapxy=swapxy, ...) } apply.inverse.func <- function(inverse.func, y, object, trace) { if(!is.null(inverse.func)) { if(!is.numeric(y[1])) stopf("inverse.func cannot be used on \"%s\" values", class(y[1])[1]) y <- process.y(inverse.func(y), object, type="response", nresponse=1, length(y), NULL, trace, "inverse.func")$y } y } # should the factor labels on the x axis be printed horizontally or vertically? get.las <- function(labels) { if(length(labels) * max(nchar(labels)) <= 20) # 20 is arbitrary 0 # horizontal else 2 # vertical } # true if a plot was selected by the user (excluding the default setting) is.degree.specified <- function(degree) { !is.logical(degree) || length(degree) > 1 } my.center <- function(x, trace=FALSE) { if(!is.null(x) && !is.factor(x)) { x <- x - mean(x[is.finite(x)], na.rm=TRUE) if(trace >= 2) { name <- paste0("centered ", trunc.deparse(substitute(x))) cat(name, "length ", length(x)) print_first_few_elements_of_vector(x, trace, name) } } x } plotmo/R/caret.R0000644000176200001440000000640014664434456013226 0ustar liggesusers# caret.R: plotmo functions for caret objects # # TODO Currently only caret "train" objects have explicit support. # sanity check that object a caret train object # (since "train" is a quite generic name) check.is.caret.train.object <- function(object) { class <- class(object)[1] stopifnot.string(class) mod <- object[["finalModel"]] # S3 models are lists, S4 models aren't lists. # Plotmo support S4 models only if they are wrapped in a caret model. # Example S4 model: kernlab::ksvm created with train(..., method="svmRadial", ...). if(class != "train" || is.null(mod) || (!is.list(mod) && !isS4(mod))) stop0("unrecognized \"train\" object ", "(was expecting a train object from the caret package)") } plotmo.prolog.train <- function(object, object.name, trace, ...) { check.is.caret.train.object(object) # call plotmo.prolog for the finalModel for its side effects # (e.g. may attach plotmo.importance to the finalModel) finalModel <- try(plotmo.prolog(object$finalModel, object.name, trace, ...), silent=trace < 2) is.err <- is.try.err(finalModel) trace1(trace, "plotmo.prolog(object$finalModel) %s\n", if(is.err) "failed, continuing anyway" else "succeeded (caret model)") if(!is.err) object$finalModel <- finalModel object } plotmo.singles.train <- function(object, x, nresponse, trace, all1, ...) { check.is.caret.train.object(object) singles <- try(plotmo.singles(object$finalModel, x, nresponse, trace, all1, ...), silent=trace < 2) is.err <- is.try.err(singles) trace2(trace, "plotmo.singles(object$finalModel) %s\n", if(is.err) "failed" else "succeeded") if(is.err) plotmo.singles.default(object, x, nresponse, trace, all1, ...) else singles } plotmo.pairs.train <- function(object, x, nresponse, trace, all2, ...) { check.is.caret.train.object(object) pairs <- try(plotmo.pairs(object$finalModel, x, nresponse, trace, all2, ...), silent=trace < 2) is.err <- is.try.err(pairs) trace2(trace, "plotmo.pairs(object$finalModel) %s\n", if(is.err) "failed" else "succeeded") if(is.err) plotmo.pairs.default(object, x, nresponse, trace, all2, ...) else pairs } # determine "type" arg for predict() plotmo.type.train <- function(object, ..., TRACE) { "raw" # check.is.caret.train.object(object) # trace <- TRACE # type <- try(plotmo.type(object$finalModel, ..., TRACE=TRACE), silent=trace < 2) # is.err <- is.try.err(type) # trace2(trace, "plotmo.type(object$finalModel) %s\n", # if(is.err) "failed" else "succeeded") # if(is.err) # "raw" # else # type } # determine "type" arg for residuals() plotmo.residtype.train <- function(object, ..., TRACE) { "raw" # check.is.caret.train.object(object) # trace <- TRACE # type <- try(plotmo.residtype(object$finalModel, ...), silent=trace < 2) # is.err <- is.try.err(type) # trace2(trace, "plotmo.residtype(object$finalModel) %s\n", # if(is.err) "failed" else "succeeded") # if(is.err) # "raw" # else # type } plotmo/R/mlr.R0000644000176200001440000001417114663771205012721 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/R/response.R0000644000176200001440000001570114663771205013765 0ustar liggesusers# response.R: plotmo functions to get the response column from the given newdata # mostly used for calculating RSq on newdata # # TODO overall structure here needs a bit of work plotmo_rsq <- function(object, newdata=NULL, trace=0, nresponse=NA, type=NULL, ...) { init.global.data() # needed if plotmo has never been invoked object.name <- quote.deparse(substitute(object)) use.submodel <- dota("USE.SUBMODEL", DEF=TRUE, ...) # undoc arg (for parsnip models) use.submodel <- is.specified(use.submodel) # TODO revisit, not really reliable because it may use parent.frame attr(object, ".Environment") <- get.model.env(object, object.name, trace, use.submodel) meta <- plotmo_meta(object, type, nresponse, trace, ...) plotmo_rsq1(object=object, newdata=newdata, trace=trace, meta=meta, ...) } plotmo_rsq1 <- function(object, newdata, trace, meta, ...) { trace2(trace, "--plotmo_response for plotmo_rsq1\n") ynew <- plotmo_response(object=object, newdata=newdata, trace=max(0, trace), nresponse=meta$nresponse, type=meta$type, meta=meta, ...) trace2(trace, "--plotmo_predict for plotmo_rsq1\n") yhat <- plotmo_predict(object=object, newdata=newdata, nresponse=meta$nresponse, type=meta$type, expected.levs=meta$expected.levs, trace=trace, inverse.func=NULL, ...)$yhat if(ncol(yhat) != 1 || ncol(ynew) != 1 || nrow(yhat) != nrow(ynew)) { if(trace > -1) { printf("\n") print_summary(ynew, "response", trace=2) printf("\n") print_summary(yhat, "predicted values", trace=2) printf("\n") } stopf("response or predicted values have the wrong dimensions%s", if(trace > -1) " (see above)" else "") } get.weighted.rsq(ynew, yhat) } # If newdata is null, return the fitted response (same as plotmo_y). # # Else extract the response column from newdata. # Use the model object to figure out which column is the response column. plotmo_response <- function(object, newdata=NULL, trace=0, nresponse=NA, type=NULL, meta=NULL, ...) { print_summary(newdata, "--plotmo_response for newdata", trace) object.name <- quote.deparse(substitute(object)) # TODO revisit, not really reliable because it may use parent.frame attr(object, ".Environment") <- get.model.env(object, object.name, trace) if(is.null(meta)) meta <- plotmo_meta(object, type, nresponse, trace, msg.if.predictions.not.numeric="RSq is not available", ...) expected.len <- if(is.null(newdata)) NROW(meta$fitted) else NROW(newdata) y <- NULL if(is.null(newdata)) y <- plotmo_y(object, meta$nresponse, trace, expected.len=expected.len, resp.levs=meta$resp.levs)$y else if(length(dim(newdata)) != 2) stop0("plotmo_response: newdata must be a matrix or data.frame") else { terms <- try(terms(object), silent=TRUE) if(is.try.err(terms) || is.null(terms)) # model doesn't have terms? y <- response.from.xy.model(object, newdata, trace, meta$resp.name) else # model has terms, presumably it was created with a formula y <- get.x.or.y.from.model.frame(object, field="y", trace, naked=FALSE, na.action=na.pass, newdata)$x } if(!is.good.data(y, "response", trace, check.colnames=FALSE)) stop0("response with newdata", format_err_field(y, "response", trace)) y <- cleanup.x.or.y(object, y, "y", trace, check.naked=FALSE) if(!is.good.data(y, check.colnames=FALSE)) stop0("response with newdata", format_err_field(y, "response", trace)) y <- convert.glm.response(object, y, trace) # TODO test this and factor responses # TODO following will sometimes give the wrong results? if(!is.null(meta$nresponse) && meta$nresponse > NCOL(y)) { trace2(trace, "plotmo_response: forcing meta$nresponse=%g to 1 because response has one column\n", nresponse) meta$nresponse <- 1 } process.y(y, object, meta$type, meta$nresponse, expected.len=expected.len, meta$resp.levs, trace, "plotmo_response")$y } # the model was created with the x,y interface (no formula) response.from.xy.model <- function(object, newdata, trace, resp.name) { if(!is.character(resp.name) || length(resp.name) != 1 || !nzchar(resp.name)) { if(trace > 2) { printf("\nresp.name:\n") print(resp.name) printf("\n") } stop0("could not get the response name") } trace2(trace, "response.from.xy.model: resp.name \"%s\"\n", resp.name) # following is for e.g. trees$Volume to Volume in earth(trees[,1:2], trees$Volume) resp.name <- sub(".*\\$", "", resp.name) # Hackery: look for responses of the form trees[,3] or trees[,3,drop=FALSE] # This happens if you build a model like lm(trees[,1:2], trees[,3]) if(grepl("\\[.*,.+\\]", resp.name)) { col.name <- sub("[^,]*,", "", resp.name) # delete up to the comma and the comma col.name <- gsub(",.*", "", col.name) # delete (2nd) comma if any, and all after col.name <- gsub("\\]", "", col.name) # delete final ] if above gsub didn't do it # print a message because we don't always get this right if(trace >= 0) printf("Assuming response %s implies that the response column is %s\n", resp.name, paste(col.name)) # the following will do something like eval(3, env) col.index <- try.eval(parse(text=col.name), model.env(object), trace=trace, expr.name=col.name) if(is.try.err(col.index)) stopf("could not parse the response name %s", resp.name) if(is.null(colnames(newdata))) resp.name <- paste0("newdata[,", col.index, "]") else # TODO is the following correct? resp.name <- paste0(colnames(newdata)[col.index]) y <- newdata[, col.index, drop=FALSE] } else { # resp.name doesn't have [] in it, hopefully it's just a name colnames.newdata <- colnames(newdata) if(is.null(colnames.newdata)) stop0("cannot get response from newdata because newdata has no column names") which <- which(colnames.newdata == resp.name) if(length(which) == 0) stop0("no column names in newdata match the original response name\n", sprint(" Response name: %s\n", resp.name), " Column names in newdata: ", paste.collapse(colnames.newdata)) if(length(which) > 1) stopf("multiple column names in newdata match the original response name %s", resp.name) y <- newdata[, colnames.newdata[which], drop=FALSE] } y } plotmo/R/meta.R0000644000176200001440000004533714663771205013065 0ustar liggesusers# meta.R: plotmo function to get the "metadata" from the model plotmo_type <- function(object, trace, fname="plotmo", type, ...) { if(is.null(type)) # get default type for this object class? type <- plotmo.type(object, ..., TRACE=trace) else { stopifnot.string(type) if(pmatch(type, "terms", nomatch=0)) stop0("type=\"terms\" is not supported by ", fname) } type } plotmo_residtype <- function(object, trace, fname="plotmo", type, ..., TRACE) { if(is.null(type)) # get default type for this object class? type <- plotmo.residtype(object, ..., TRACE=TRACE) else stopifnot.string(type) type } # In plotmo and plotres there is some general data we need about the # model. For example, the response name. This routine provides that # data, which we call "metadata". # # Also, plotmo and plotres should work automatically, as much as possible, # without requiring the user to specify arguments. This routine # facilitates that. # # For example, it converts the default nresponse=NA to a sensible column # number in the response. It will issue an error message if it can't do # that. # # It also converts the default type=NULL into an appropriate # model-specific type for predict(). It can't always do that, and we will # only know for sure later when we call predict with the calculated type. # In this routine we call plotmo_predict with type=NULL to get all the # response columns. The dots are passed on to predict. # # If you don't need the response, set get.y=FALSE to reduce the amount of processing. plotmo_meta <- function(object, type, nresponse, trace, avoid.predict=FALSE, residtype=type, msg.if.predictions.not.numeric=NULL, ...) { type <- plotmo_type(object, trace, "plotmo", type, ...) residtype <- plotmo_residtype(object, trace, "plotmo", residtype, ...) assignInMyNamespace("trace.call.global", trace) # trace call to resids, etc if(avoid.predict) { trace2(trace, "\n----Metadata: plotmo_resids(object, type=\"%s\", nresponse=NULL)\n", type) plotmo_resids <- plotmo_resids(object, type, residtype, nresponse=NULL, trace, ...)$resids if(is.null(plotmo_resids)) { if(trace >= 1) printf("residuals() was unsuccessful, will use predict() instead\n") avoid.predict <- FALSE # fall back to using predict } else { # trace2(trace, # "got residuals using residuals(object, type=\"%s\", ...)\n", type) # use fitted rather than predict (TODO not right but ok for plotres) trace2(trace, "\n----Metadata: plotmo_fitted with nresponse=NULL\n") # nresponse=NULL so this returns multiple columns if a mult respe model plotmo_fitted <- plotmo_fitted(object, trace, nresponse=NULL, type, ...) yhat <- plotmo_fitted$fitted if(!inherits(object, "earth")) colnames(fitted) <- NULL # ensure get.resp.name.from.metadata doesn't use this } } if(!avoid.predict) { trace2(trace, "\n----Metadata: plotmo_predict with nresponse=NULL and newdata=NULL\n") # newdata=3 for efficiency plotmo_predict <- plotmo_predict(object, newdata=3, nresponse=NULL, type, expected.levs=NULL, trace, inverse.func=NULL, ...) yhat <- plotmo_predict$yhat if(!is.null(msg.if.predictions.not.numeric)) { if(!is.null(plotmo_predict$resp.levs)) stopf("%s when the predicted response is a factor", msg.if.predictions.not.numeric) if(plotmo_predict$resp.class[1] == "character") stopf("%s when the predicted values are strings", msg.if.predictions.not.numeric) } trace2(trace, "\n----Metadata: plotmo_fitted with nresponse=NULL\n") # nresponse=NULL so this returns multiple columns if a multiple response model plotmo_fitted <- plotmo_fitted(object, trace, nresponse=NULL, type, ...) } assignInMyNamespace("trace.call.global", 0) yfull <- NULL # plotmo_y with nresponse=NULL trace2(trace, "\n----Metadata: plotmo_y with nresponse=NULL\n") # nresponse=NULL so this returns multiple columns if a multi response model yfull <- plotmo_y(object, nresponse=NULL, trace, expected.len=nrow(plotmo_fitted$fitted))$y nresponse.org <- nresponse nresponse <- plotmo_nresponse(yhat, object, nresponse, trace, sprint("predict.%s", class.as.char(object)), type) stopifnot(!is.na(nresponse)) trace2(trace, "nresponse=%g%s ncol(fitted) %d ncol(predict) %d ncol(y) %s\n", nresponse, if(identical(nresponse, nresponse.org)) "" else sprint(" (was %s)", if(is.character(nresponse.org)) paste0("\"", nresponse.org, "\"") else paste(nresponse.org)), NCOL(plotmo_fitted$fitted), NCOL(predict), sprint("%d", NCOL(yfull))) y.as.numeric.mat <- NULL # y as single column numeric mat, only the nresponse column nresponse.y <- nresponse trace2(trace, "\n----Metadata: plotmo_y with nresponse=%g\n", nresponse) if(ncol(yfull) == 1 && nresponse.y > 1) { # e.g. lda(survived~., data=etitanic) with predict(..., type="post") nresponse.y <- 1 trace1(trace, "nresponse=%d but for plotmo_y using nresponse=1 because ncol(y) == 1\n", nresponse) } assignInMyNamespace("trace.call.global", trace) # trace how we get the response y.as.numeric.mat <- plotmo_y(object, nresponse.y, trace, nrow(plotmo_fitted$fitted))$y assignInMyNamespace("trace.call.global", 0) resp.name <- get.resp.name.from.metadata(nresponse, trace, yhat, plotmo_fitted$fitted, yfull, nresponse.y) resp.levs <- plotmo_resplevs(object, plotmo_fitted, yfull, trace) trace2(trace, "\n----Metadata: done\n\n") fitted <- plotmo_fitted$fitted list( yfull = yfull, # response as a data.frame, all columns y.as.numeric.mat = y.as.numeric.mat, # response as a single col numeric mat # only the nresponse column fitted = fitted, # fitted response as a data.frame (all columns) type = type, # type for predict() # always a string (converted from NULL if necesssary) residtype = residtype, # type for residuals() # always a string (converted from NULL if necesssary) nresponse = nresponse, # col index in the response (converted from NA if necessary) resp.name = resp.name, # our best guess for the response name (may be NULL) resp.levs = resp.levs) # levels of y before conversion to numeric (may be NULL) # necessary to convert predicted strings to factors } get.resp.name.from.metadata <- function(nresponse, trace, yhat, fitted, yfull, nresponse.y) { # the order we look for the response name below seems to work but is not cast in stone if(is.factor(yhat[,1])) { # this prevents us putting a misleading first level name in plot headings resp.name <- NULL trace2(trace, "response name is NULL because is.factor(yhat[,1])\n") } else if(!is.null(colnames(yhat)) && nresponse <= length(colnames(yhat))) { # e.g. earth model resp.name <- colnames(yhat)[nresponse] trace2(trace, "got response name \"%s\" from yhat\n", resp.name) } else if(!is.null(yfull) && !is.null(colnames(yfull))) { # e.g. lm model resp.name <- colnames(yfull)[nresponse.y] trace2(trace, "got response name \"%s\" from yfull\n", resp.name) } else if(nresponse < length(colnames(fitted))) { resp.name <- colnames(fitted)[nresponse] trace2(trace, "got response name \"%s\" from plotmo_fitted\n", resp.name) } else { resp.name <- NULL trace2(trace, "response name is NULL\n") } resp.name } # Init resp.levs (the factor levels of the original response, may be NULL). # The resp.levs is used if predict() returns strings (and therefore # we must convert to them to a factor with the correct levels). plotmo_resplevs <- function(object, plotmo_fitted, yfull, trace) { levels.yfull <- if(is.null(yfull)) NULL else if(length(dim(yfull)) == 2) levels(yfull[,1]) else levels(yfull[1]) if(!is.null(object[["levels"]])) { resp.levs <- object[["levels"]] # levels stored with earth trace2(trace, "got resp.levs from object$levels\n") } else if(!is.null(levels.yfull)) { resp.levs <- levels.yfull trace2(trace, "got resp.levs from yfull\n") } else if(!is.null(plotmo_fitted$resp.levs)) { resp.levs <- plotmo_fitted$resp.levs trace2(trace, "got resp.levs from plotmo_fitted$resp.levs\n") } else { resp.levs <- NULL trace2(trace, "resp.levs is NULL\n") } if(trace >= 2 && !is.null(resp.levs)) printf("response levels: %s\n", paste.trunc(resp.levs)) resp.levs } # This is used for processing "model response" variables such as the # return value of predict(), fitted(), and residuals(). # # # If nresponse=NULL, return a data.frame but with y otherwise unchanged. # # Else return a numeric 1 x n matrix (regardless of the original class of y). # If nresponse is an integer, return only the specified column. # If nresponse=NA, try to convert it to a column index, error if cannot # # If !is.null(nresponse) and y is character vector then convert it to a factor. # expected.levs is used to do this (and not for anything else). # # returns list(y, resp.levs, resp.class) process.y <- function(y, object, type, nresponse, expected.len, expected.levs, trace, fname) { if(is.null(y)) stop0(fname, " NULL") if(length(y) == 0) stop0(fname, " zero length") print_summary(y, sprint("%s returned", fname), trace) if(is.list(y) && !is.data.frame(y)) # data.frames are lists, hence must check both stop0(fname, " list, was expecting a vector, matrix, or data.frame\n", " list(", list.as.char(y), ")") returned.resp.levs <- if(length(dim(y)) == 2) levels(y[,1]) else levels(y[1]) resp.class <- class(y[1]) colnames <- NULL resp.name <- NA dimy <- dim(y) if(length(dimy) == 3 && dimy[3] == 1) # hack for glmnet multnet objects y <- y[,,1] if(is.null(nresponse)) y <- my.data.frame(y, trace, stringsAsFactors=FALSE) else { check.integer.scalar(nresponse, min=1, na.ok=TRUE, logical.ok=FALSE, char.ok=TRUE) nresponse <- plotmo_nresponse(y, object, nresponse, trace, fname, type) stopifnot(!is.na(nresponse), nresponse >= 1) if(nresponse > NCOL(y)) stopf("nresponse is %d but the number of columns is only %d", nresponse, NCOL(y)) resp.name <- colname(y, nresponse, fname) y <- get.specified.col.and.force.numeric(y, nresponse, resp.name, expected.levs, trace, fname) if(!is.na(nresponse) && nresponse > 1) print_summary(y, sprint("%s returned", fname), trace, sprint(" after selecting nresponse=%d", nresponse)) } any.nas <- anyNA(y) any.non.finites <- FALSE # we use apply below because is.finite doesn't work for dataframes any.non.finites <- !any.nas && any(apply(y, 2, function(x) is.numeric(x) && !all(is.finite(x)))) if(any.nas) { trace2(trace, "\n") warning0("NAs returned by ", fname) } if(any.non.finites) { trace2(trace, "\n") warning0("non-finite values returned by ", fname) } # Error message for the aftermath of: # "Warning: 'newdata' had 100 rows but variable(s) found have 30 rows" if(!is.null(expected.len) && expected.len != nrow(y)) stopf("%s returned the wrong length (got %d but expected %d)", fname[1], nrow(y), expected.len[1]) print_summary(y, sprint("%s after processing with nresponse=%s is ", fname, if(is.null(nresponse)) "NULL" else format(nresponse)), trace) list(y = y, # n x 1 numeric, column name is original y column name resp.levs = returned.resp.levs, resp.class = resp.class) } # always returns a one column numeric matrix get.specified.col.and.force.numeric <- function(y, nresponse, resp.name, expected.levs, trace, fname) { # nresponse=NA is not allowed at this point stopifnot(is.numeric(nresponse), length(nresponse) == 1, !is.na(nresponse)) if(length(dim(y)) == 2) y <- y[, nresponse] else stopifnot(nresponse == 1) if(is.factor(y[1])) { trace2(trace, "converted to numeric from factor with levels %s\n", quotify.trunc(levels(y))) # plotmo 3.1.5 (aug 2016): Use as.vector to drop attributes, # else all.equal fails when expected.levs has "ordered" attribute. all.equal <- isTRUE(all.equal(as.vector(expected.levs), levels(y[1]))) # TODO this may be a bogus warning if(!is.null(expected.levs) && !all.equal) warning0(fname, " returned a factor with levels ", quotify.trunc(levels(y[1])), " (expected levels ", quotify.trunc(expected.levs), ")") } else if(is.character(y[1])) { # convert strings to factor old.y <- y y <- if(is.null(expected.levs)) factor(y) else factor(y, levels=expected.levs) trace2(trace, "converted to numeric from strings using factor levels %s\n", quotify.trunc(expected.levs)) which <- (1:length(y))[is.na(y)] if(length(which)) { cat("\n") print_summary(old.y, fname, trace=2) cat("\n") printf("%s[%d] was %s and was converted to \"%s\"\n", fname, which[1], old.y[which[1]], if(is.na(y[which[1]])) "NA" else paste0("\"", y[which[1]], "\"")) cat("\n") stopf("could not convert strings returned by %s to a factor (see above)", fname) } } if(any(!is.double(y))) # convert logical or factor to double y <- as.vector(y, mode="numeric") y <- as.matrix(y) colnames(y) <- resp.name y } plotmo_nresponse <- function(y, object, nresponse, trace, fname, type="response") { check.integer.scalar(nresponse, min=1, na.ok=TRUE, logical.ok=FALSE, char.ok=TRUE) colnames <- safe.colnames(y) nresponse.org <- nresponse if(is.na(nresponse)) { nresponse <- plotmo.convert.na.nresponse(object, nresponse, y, type) if(!is.na(nresponse)) { if(trace > 0 && nresponse != 1) printf("set nresponse=%s\n", paste(nresponse)) } else { # nresponse is NA # fname returned multiple columns (see above) but nresponse is not specified cat("\n") print_summary(y, fname, trace=2) cat("\n") colnames <- NULL if(is.null(colnames) && !is.null(dim(y))) colnames <- colnames(y) icol <- min(2, NCOL(y)) if(is.null(colnames)) msg1 <- sprint("%s\n Example: nresponse=%d", "Use the nresponse argument to specify a column.", icol) else msg1 <- sprint( "%s\n Example: nresponse=%d\n Example: nresponse=%s", "Use the nresponse argument to specify a column.", icol, quotify(if(is.na(colnames(y)[icol])) colname(y, 1) else colname(y, icol))) printf( "%s returned multiple columns (see above) but nresponse is not specified\n %s\n\n", fname, msg1) warning0("Defaulting to nresponse=1, see above messages"); nresponse <- 1 } } else if(is.character(nresponse)) { # convert column name to column index stopifnot.string(nresponse) if(is.vector(y)) stop0("nresponse=\"", nresponse, "\" cannot be used because the predicted response is a vector (it has no columns)") if(is.factor(y)) stop0("nresponse=\"", nresponse, "\" cannot be used because the predicted response is a factor (it has no columns)") if(is.null(colnames)) stop0("nresponse=\"", nresponse, "\" cannot be used because the predicted response has no column names") # TODO investigate [1] e.g. for plotmo(a1h.update2, nresponse="numd") nresponse <- imatch.choices(nresponse, colnames, errmsg.has.index=TRUE)[1] } check.integer.scalar(nresponse, min=1, na.ok=TRUE, logical.ok=FALSE, char.ok=TRUE) # note that msg is inhibited for trace<0, see trace1 in plotmo_rinfo # TODO this causes a spurious trace message with cv.glmnet models with nresponse=2 # message is plotmo_y[500,1] with no column names. So I changed the if statement. # if(nresponse > NCOL(y) && trace >= 0) { if(nresponse > NCOL(y) && trace > 0) { cat("\n") print_summary(y, fname, trace=2) cat("\n") check.index(nresponse, "nresponse", y, is.col.index=1, allow.negatives=FALSE, treat.NA.as.one=TRUE) } if(trace >= 2 && (is.na(nresponse.org) || nresponse.org != nresponse)) cat0("converted nresponse=", if(is.character(nresponse.org)) paste0("\"", nresponse.org, "\"") else nresponse.org, " to nresponse=", nresponse, "\n") nresponse } plotmo.convert.na.nresponse <- function(object, nresponse, yhat, type="response", ...) { UseMethod("plotmo.convert.na.nresponse") } plotmo.convert.na.nresponse.default <- function(object, nresponse, yhat, type, ...) { stopifnot(is.na(nresponse)) if(NCOL(yhat) == 1) 1 else if(NCOL(yhat) == 2 && substr(type, 1, 1) == "p") 2 # probability (also works for posterior as in lda models) else NA } plotmo/R/elegend.R0000644000176200001440000002700114663771205013526 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/as.char.R0000644000176200001440000002257014663771205013450 0ustar liggesusers# as.char.R: brief description of an object as a string e.g. "c(1,2)" # this file also includes print_summary for matrices and data.frames as.char <- function(object, maxlen=20) { check.integer.scalar(maxlen, min=1) if(is.null(object)) "NULL" else if(is.name(object)) paste.trunc(object, maxlen=maxlen) # e.g. "..3" for unforced dot args else if(is.environment(object)) environment.as.char(object) else if(is.call(object)) { # e.g. x is a call object in foo(x=1:3) s <- strip.space.collapse(format(object)) if(nchar(s) > maxlen) s <- paste0(substr(s, 1, maxlen), "...)") s } else if(NCOL(object) == 1 && is.character(object)) paste.c(paste0("\"", object, "\"")) else if(NCOL(object) == 1 && is.logical(object)) paste.c(object) else if(NCOL(object) == 1 && is.numeric(object)) { # digits=4 is arb but seems about right, and zapsmall means more can # be displayed in limited space if just one val is say 3.553e-15 paste.c(signif(zapsmall(object, digits=4), digits=4)) } else if(length(dim(object)) == 2) sprint("%s[%g,%g]", class(object)[1], NROW(object), NCOL(object)) else if(class(object)[1] == "list") # not is.list() because e.g. lm objects are lists paste0("list(", paste.trunc(list.as.char(object), maxlen=maxlen+12), ")") else if(inherits(object, "Date")) paste0("Date:", paste.trunc(object, maxlen=maxlen+12)) else paste0(class.as.char(object), ".object") } # compact description of an object's class # typically quotify=TRUE for error messages (full class name with quotes), # and quotify=FALSE for trace messages (just first field of class name, no quotes) class.as.char <- function(object, quotify=FALSE) { if(quotify) quotify(paste.trunc(class(object), collapse=",", maxlen=60)) else class(object)[1] } # compact description of a list # maxlen is max length of each list element (not of the entire list) list.as.char <- function(object, maxlen=20) { stopifnot(is.list(object) || is.pairlist(object)) s <- "" names <- names(object) for(i in seq_along(object)) { if(i != 1) s <- sprint("%s, ", s) name.ok <- length(names) >= i && !is.na(names[i]) && nzchar(names[i]) if(name.ok && names[i] == "...") s <- sprint("%s...", s) # print dots as ... not as ...=pairlist.object else { if(name.ok) s <- sprint("%s%s=", s, names(object)[i]) s <- sprint("%s%s", s, as.char(object[[i]], maxlen=maxlen)) } } s # one element character vector e.g "x=1, 2" } environment.as.char <- function(env, maxlen=60) # compact description { if(is.null(env)) # illegal, but we still want to format it return("env(NULL)") stopifnot(is.environment(env)) # format(env) returns "" stripped.env <- gsub("", "", format(env)[1]) # if it's a standard environment return the environment's name if(grepl("^namespace:|^R_[[:alnum:]]+Env", stripped.env)) stripped.env # something like "namespace:stats" or "R_GlobalEnv" else # return the names of the objects in the environment sprint("env(%s)", paste.trunc(paste0(ls(env, all.names=TRUE), collapse=", "), maxlen=maxlen)) } # The main purpose of this routine is to summarize matrices and data.frames, # but it will also (semi)gracefully handle any object that is passed to it. # # Note that this only does anything if trace >= 2. # # If x is a matrix or dataframe or similar, print first few rows and last row. # If trace >= 4, then print all rows and cols, up to 1000 rows and 100 cols. # # the details argument: # 0=don't print data, print the colnames truncated to one line of output # 1=don't print data, print all colnames # -1=like print data but don't prefix the output with spaces # 2=print the data print_summary <- function(x, xname=trunc.deparse(substitute(x)), trace=2, msg="", prefix="", details=2) { check.numeric.scalar(trace) if(trace < 2) return() if(is.null(x)) { printf("%s: NULL\n", xname) return() } if(length(x) == 0) { printf("%s: length zero\n", xname) return() } # try(data.frame(), silent=TRUE) is not actually silent # for language objects, so handle them specially if(is.language(x)) { x$na.action <- NULL # don't want to print the na.action if there is one s <- try(format(x)) max <- if(trace <= 2) 8 else 1000 if(length(s) > max) { s <- s[1:max] s[max] <- paste(s[max], "\n...") } s <- gsub("[ \t\n]", "", s) # remove white space s <- gsub(",", ", ", s) # replace comma with comma space s <- paste(s, collapse="\n ", sep="") printf("%s%s%s:\n%s\n", prefix, xname, msg, s) return() } if(is.list(x) && !is.data.frame(x)) { # data.frames are lists, hence must check both if(details < 2 && trace < 4) { printf("%s: list with elements %s\n", xname, quotify.trunc(paste(names(x)))) return() } printf("%s ", xname) str(x) return() } df <- try(my.data.frame(x, trace, stringsAsFactors=FALSE), silent=TRUE) if(is.try.err(df)) { # be robust for whatever gets passed to this function printf("print_summary: cannot convert class \"%s\" to a data.frame (%s)\n", class(x)[1], cleantry(df)) printf("%s%s%s:\n", prefix, xname, msg) if(length(dim(x)) == 2) { # it's a matrix or other 2D object? if(trace >= 4) { try(print_with_strings_quoted(x)) try(print(summary(x))) } else { try(print_with_strings_quoted(head(x))) printf("...\n") } } else try(print_with_strings_quoted(x)) return() } if(details < 2 && trace < 4) { # don't print the data, just the dimensions and colnames if(details != -1) printf(" ") printf("%s%s[%d,%d]%s ", prefix, xname, nrow(df), ncol(df), msg) print_colnames(x, full=details == 2, newline="") if(NCOL(x) == 1 || NROW(x) == 1) # if a vector, print first few values cat0(", and values ", # if double, print 4 significant digits paste.trunc(if(is.double(x)) sprint("%.4g", x) else x, collapse=", ", maxlen=32)) cat0("\n") return() } colnames <- safe.colnames(x) printf("%s%s[%d,%d]%s%s:\n", prefix, xname, nrow(df), ncol(df), msg, if(is.null(colnames)) " with no column names" else "") df.short <- df maxrows <- if(trace >= 4) 1000 else 5 if(maxrows < nrow(df)) { df.short <- df[c(1:(maxrows-1), nrow(df)), , drop=FALSE] if(is.null(rownames(df.short))) rownames(df.short) <- c(1:(maxrows-1), nrow(df)) rownames(df.short)[maxrows-2+1] <- "..." } maxcols <- if(trace >= 4) 100 else 10 if(maxcols < ncol(df)) { df.short[,maxcols] <- "..." df.short <- df.short[, 1:maxcols, drop=FALSE] if(!is.null(colnames)) colnames(df.short)[maxcols] <- "..." } try(print_with_strings_quoted(df.short)) is.fac <- sapply(df, is.factor) if(is.null(colnames)) colnames(df) <- sprint("[,%d]", seq_len(NCOL(x))) if(any(is.fac)) { names <- paste0(colnames(df), ifelse(sapply(df, is.ordered), "(ordered)", "")) if(sum(is.fac) == 1) # only one fac, so enough space to print levels too printf(" %s is a factor with levels: %s\n", paste.trunc(names[is.fac]), paste.trunc(levels(df[,is.fac]))) else printf(" factors: %s\n", paste.trunc(names[is.fac])) } if(trace >= 4) try(print(summary(df))) } print_colnames <- function(x, full=FALSE, newline="\n") { colnames <- safe.colnames(x) if(is.null(colnames)) printf("with no column names%s", newline) else { colnames[which(colnames == "")] <- "\"\"" if(full) # full colnames (up to 1000 characters) printf("with colname%s %s%s", if(length(colnames(x)) > 1) "s" else "", paste.trunc(colnames, maxlen=max(25, getOption("width")-20)), newline) else # short version of colnames printf.wrap("with colname%s %s%s", if(length(colnames(x)) > 1) "s" else "", paste.trunc(colnames), newline) } } # Like print but puts quotes around strings. # Useful for disambiguating strings from factors. # # "..." is not quoted because it is used as a # "something was deleted" indicator in print_summary print_with_strings_quoted <- function(x) { if(length(dim(x)) == 2) for(j in seq_len(NCOL(x))) if(is.character(x[,j])) for(i in seq_along(x[,j])) if(x[i,j] != "...") x[i,j] <- paste0("\"", x[i,j], "\"") print(x) } plotmo/R/w1.R0000644000176200001440000002145514663771205012461 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/check.index.R0000644000176200001440000001724214663771205014314 0ustar liggesusers# check.index.R # Check that an index vector specified by the user is ok to index an object. # We want to preclude confusing R messages or behaviour later. # An example is when max(index) > length(object) which quietly # returns NA and can cause confusing downstream behaviour. # This returns a vector suitable for indexing into object (will # be identical to index unless index is a character vector). # # If index is a character vector, then matching (regex if is.col.index != 2) # is used against the names in the object, and an integer vector is returned. check.index <- function(index, index.name, object, colnames = NULL, is.col.index = 0, # 0=row index, 1=col index, 2=exact non-regex col name if char allow.empty = FALSE, # if index is char will warn if necessary regardless of allow.empty allow.zeros = FALSE, allow.negatives = TRUE, allow.dups = FALSE, treat.NA.as.one = FALSE, is.degree.spec = FALSE) # special handling for degree1 and degree2 specs { index.name <- quotify.short(index.name, "index", quote="'") # check that the given index and object can be evaluated try <- try(eval(index)) if(is.try.err(try)) stop0("illegal ", index.name) try <- try(eval(object)) if(is.try.err(try)) stop0("illegal ", quotify.short(object, quote="'")) is.col.index <- check.integer.scalar(is.col.index, min=0, max=2) allow.empty <- check.boolean(allow.empty) allow.zeros <- check.boolean(allow.zeros) allow.negatives <- check.boolean(allow.negatives) allow.dups <- check.boolean(allow.dups) treat.NA.as.one <- check.boolean(treat.NA.as.one) if(is.null(index)) { if(!allow.empty) stop0(index.name, " is NULL and cannot be used as an index") return(NULL) } if(treat.NA.as.one && (length(index) == 1 && is.na(index)[1])) index <- 1 if(anyNA(index)) stop0("NA in ", index.name) if(NROW(index) != 1 && NCOL(index) != 1) stop0(index.name, " must be a vector not a matrix (", index.name, " has dimensions ", NROW(index), " x ", NCOL(index), ")") len <- get.len(object, is.col.index) if(is.character(index)) # currently only works for column names of object check.character.index(index, index.name, object, colnames, len, is.fixed=(is.col.index==2), allow.empty, is.degree.spec) else if(is.logical(index)) check.logical.index(index, index.name, len, allow.empty) else if(is.numeric(index)) check.numeric.index(index, index.name, len, allow.empty, allow.negatives, allow.dups, allow.zeros, treat.NA.as.one) else stop0(index.name, " must be an index vector (numeric, logical, or character)") } get.len <- function(object, is.col.index) { if(is.col.index) len <- NCOL(object) # index is for columns of object else if(is.null(dim(object))) len <- length(object) else len <- NROW(object) # index is for rows of object # NROW also works for lists stopifnot(length(len) == 1) stopifnot(len > 0) len } matchmult <- function(x, tab) # like match but return multiple matches if present { matches <- integer(0) for(i in seq_along(x)) { xi <- x[i] for(itab in 1:length(tab)) if(xi == tab[itab]) matches <- c(matches, itab) } matches } # This does regex matching of index and returns an integer vector # index arg must be character # if names arg is NULL, use colnames(object) check.character.index <- function(index, index.name, object, names, len, is.fixed, allow.empty, is.degree.spec) { stopifnot(is.character(index)) is.fixed <- check.boolean(is.fixed) # certain regular expressions match everything, even if names not avail if(!is.fixed && length(index) == 1 && index %in% c("", ".", ".*")) return(1:len) if(is.null(names)) names <- colnames(object) if(length(names) == 0 || !is.character(names)) stop0(index.name, " specifies names but the names are unavailable") matches <- integer(0) warning.names <- integer(0) # these regexs don't match any column names for(i in seq_along(index)) { name <- index[i] if(!is.fixed) # regex match igrep <- grep(name, names) else { # exact match if(nchar(name) == 0) warning0(unquote(index.name), "[", i, "] is an empty string \"\"") igrep <- which(name == names) } if(length(igrep)) matches <- c(matches, igrep) else warning.names <- c(warning.names, name) } if(is.degree.spec) { if(is.null(dim(object))) # vector, degree1 matches <- matchmult(matches, object) else if(length(dim(object)) == 2) # 2D matrix, degree2 matches <- c(matchmult(matches, object[,1]), matchmult(matches, object[,2])) else stop0("that kind of object is not yet supported for ", index.name) } new.index <- unique(matches[!is.na(matches)]) for(name in warning.names) warning0("\"", name, "\" in ", unquote(index.name), " does not ", if(is.fixed) "" else "regex-", "match any names\n", " Available names are ", paste.trunc(quotify(names))) new.index } check.logical.index <- function(index, index.name, len, allow.empty) { stopifnot(is.logical(index)) if(!allow.empty) { if(length(index) == 0) stop0("length(", unquote(index.name), ") == 0") if(length(index[index == TRUE]) == 0) stop0(index.name, " is all FALSE") } # note that a single FALSE or TRUE is ok regardless of length(object) if(length(index) > len && length(index) != 1) { stop0("logical index ", index.name, " is too long.\n", " Its length is ", length(index), " and the max allowed length is ", len) } index } check.numeric.index <- function(index, index.name, len, allow.empty, allow.negatives, allow.dups, allow.zeros, treat.NA.as.one) { stopifnot(is.numeric(index)) if(!allow.empty) { if(length(index) == 0) stop0(index.name, " is empty, (its length is 0)") else if(all(index == 0)) if(length(index) == 1) stop0(index.name, " is 0") else stop0(index.name, " is all zeros") } if(!is.integral(index)) stop0(index.name, " is not an integer") if(any(index < 0) && any(index > 0)) stop0("mixed negative and positive values in ", index.name) if(!allow.zeros && any(index == 0) && length(index) != 1) warning0("zero in ", index.name) if(!allow.negatives && any(index < 0)) stop0("negative value in ", index.name) if(!allow.dups && any(duplicated(index))) warning0("duplicates in ", index.name) if(any(abs(index) > len)) { if(length(index) == 1) prefix <- paste0(unquote(index.name), "=", index, " but ") else prefix <- paste0(index.name, " is out of range, ") if(len != 1) stop0(prefix, "allowed values are 1 to ", len) else if(treat.NA.as.one) stop0(prefix, "the only allowed value is 1 (or NA)") else stop0(prefix, "the only allowed value is 1") } index } plotmo/R/xy.R0000644000176200001440000014776414663771205012606 0ustar liggesusers# xy.R: get a model's x or y (the plotmo_x and plotmo_y functions) # # Tracing is verbose and error messages are detailed throughout this # file, to facilitate diagnosis when a model doesn't work with plotmo. #------------------------------------------------------------------------------ # Return the "x" matrix for a model. This returns a data.frame which # always has column names. It tries hard to get x regardless of the model. # It can be used for models without a formula, provided that getCall(object) # or model$x is available. # # The returned columns are for the "naked" predictors e.g. "x3" instead of # "ns(x3,4)". Column names are manufactured when necessary, as "x1", # "x2", etc. This is needed for example for rpart(x,y) where x does not # have column names. # # It can handle sparse matrices from the Matrix package. These get # returned as a (non sparse) data.frame. # # If stringsAsFactors=FALSE, strings do not get converted to factors. plotmo_x <- function(object, trace, stringsAsFactors=TRUE) { trace2(trace, "--plotmo_x for %s object\n", class.as.char(object)) x <- plotmo.x(object, trace) do.subset <- TRUE # plotmo.x.default returns list(field, do.subset), so handle that if(is.list(x) && !is.data.frame(x) && !is.null(x$do.subset)) { do.subset <- check.boolean(x$do.subset) x <- x$field } # Following are mainly for when plotmo.x didn't invoke plotmo.x.default. # It shouldn't be needed but is included here to make sure. x <- cleanup.x.or.y(object, x, "x", trace, check.naked=FALSE) stopifnot(is.good.data(x, "plotmo_x", check.colnames=FALSE)) x <- my.data.frame(x, trace, stringsAsFactors) if(do.subset) { subset <- get.and.check.subset(x, object, trace) if(!is.null(subset)) { trace2(trace, "subset applied to x[%d,%d] ", NROW(x), NCOL(x)) x <- x[subset, , drop=FALSE] trace2(trace, "to yield x[%d,%d]\n", NROW(x), NCOL(x)) } } colnames(x) <- gen.colnames(x, "x", "x", trace) print_summary(x, "plotmo_x returned", trace) x } plotmo.x <- function(object, trace, ...) { # returns x or list(field=x, do.subset=do.subset) UseMethod("plotmo.x") } plotmo.x.default <- function(object, trace, ...) { # returns list(field=x, do.subset=do.subset) get.x.or.y(object, "x", trace, naked=TRUE) } # plotmo_y is similar to model.response but can handle models # that were created without a formula. # # For more details on the args and return value, see process.y. # If nresponse is not NULL we return the naked response variables # e.g. Volume not log(Volume). # # If convert.glm.response=TRUE and the model is a glm model we may # convert the response. See convert.glm.response() for details. plotmo_y <- function(object, nresponse=NULL, trace=0, expected.len=NULL, resp.levs=NULL, convert.glm.response=!is.null(nresponse)) { trace2(trace, "--plotmo_y with nresponse=%s for %s object\n", if(is.null(nresponse)) "NULL" else format(nresponse), class.as.char(object)) y <- plotmo.y(object, trace, naked=FALSE, expected.len, nresponse) do.subset <- TRUE # plotmo.y.default returns list(field, do.subset), so handle that if(is.list(y) && !is.data.frame(y) && !is.null(y$do.subset)) { do.subset <- check.boolean(y$do.subset) y <- y$field } if(convert.glm.response) y <- convert.glm.response(object, y, trace) if(do.subset) { subset <- get.and.check.subset(y, object, trace) if(!is.null(subset)) { trace2(trace, "subset applied to y[%d,%d] ", NROW(y), NCOL(y)) y <- if(is.null(dim(y))) y[subset] else y[subset, , drop=FALSE] trace2(trace, "to yield y[%d,%d]\n", NROW(y), NCOL(y)) } } process.y(y, object, type="response", nresponse, expected.len, resp.levs, trace, "plotmo_y") } # Note that the naked argument is irrelevant unless the response was # specified with a wrapper function like log(Volume) instead of plain Volume. # # The default for nresponse allows this to work with old versions of earth # (old plotmo.y.earth doesn't have a nresponse argument). plotmo.y <- function(object, trace, naked, expected.len, nresponse=1, ...) { # returns y or list(field=y, do.subset=do.subset) UseMethod("plotmo.y") } plotmo.y.default <- function(object, trace, naked, expected.len, ...) { # returns list(field=y, do.subset=do.subset) get.x.or.y(object, "y", trace, try.object.x.or.y=TRUE, argn=2, nrows.argn=expected.len, naked) } # Get x or y from the given model object # Returns list(field=x, do.subset=do.subset) where x is "x" or "y". get.x.or.y <- function( object, # the model field, # "x" or "y" trace, try.object.x.or.y=TRUE, # FALSE if object[[field]] should be ignored argn=0, # if nonzero, consider argument nbr argn of the model call nrows.argn=NULL, # expected NROWS of argument argn naked=TRUE) # TRUE to return colnames like "x3" not "ns(x3,4)" { ret.good.field <- function(x, do.subset=TRUE, source) { if(trace.call.global >= 1 && field == "y") { field <- if(field == "x") "predictors" else "response" if(grepl("model.frame(", source, fixed=TRUE)) source <- sub(",", # insert newline after first comma if(field == "response") ",\n " else ",\n ", source) printf("got model %s from %s\n", field, source) } list(field=x, do.subset=do.subset) } stopifnot(is.list(object)) stopifnot(field == "x" || field == "y") # try using object$x (where x is actually x or y throughout this file) object.x <- get.object.x.or.y.field(object, field, trace, try.object.x.or.y, naked) # object.x is object$x or NULL or an err msg if(is.good.data(object.x)) return(ret.good.field(object.x, FALSE, sprint("object$%s", field))) call <- getCall(object) if(!is.null(call)) trace2(trace, "\nobject call is %s\n", trunc.deparse(call, maxlen=80)) # try getting x or y from the model formula and model frame temp <- get.x.or.y.from.model.frame(object, field, trace, naked) model.frame.x <- temp$x do.subset <- temp$do.subset # TRUE when newdata is NULL source <- temp$source # model.frame.x is now x or y or NULL or an err msg if(is.good.data(model.frame.x)) { formula.as.char <- paste.collapse(format(temp$formula)) if(naked && grepl("\`", formula.as.char)) { # exception for hinge funcs etc trace2(trace, "setting check.naked=FALSE because backtick in formula\n") naked <- FALSE } model.frame.x <- cleanup.x.or.y(object, model.frame.x, field, trace, check.naked=naked && field != "y") if(!is.errmsg(model.frame.x)) return(ret.good.field(model.frame.x, do.subset, source)) } # try getCall(object)$x call.x <- get.data.from.object.call.field(object, field, trace) # call.x is getCall(object)$x or an error message if(is.good.data(call.x)) return(ret.good.field(call.x, TRUE, sprint("getCall(object)$%s", field))) # else { # TODO may not want to do this if x is ok except for no colnames # # try getCall(object)$X (note upper case "X") # upfield <- toupper(field) # call.x <- get.data.from.object.call.field(object, upfield, trace) # # call.x is getCall(object)$X or an error message # if(is.good.data(call.x)) { # # paranoia, check that argument number is correct # ifield <- if(field == "x") 2 else 3 # ok <- names(getCall(object))[ifield] == upfield # if(!is.na(ok) && length(ok == 1) && ok) # return(ret.good.field(call.x, TRUE, # sprint("getCall(object)$%s", upfield))) # else if(trace >= 2) # printf("ignoring getCall(object)$%s because it isn't arg number %d\n", # upfield, ifield) # } # } trace2(trace, "\n") # consider argument number argn of the model call (ignoring its name) temp <- get.argn.from.call(argn, object, field, trace, nrows.argn) argn.x <- temp$x argn <- temp$argn # may clear argn (for uncluttered errmsg later) # argn.x is the evaluated n'th arg or NULL or an err msg argn.name <- sprint("argument %g of the model call", argn) if(is.good.data(argn.x)) return(ret.good.field(argn.x, TRUE, argn.name)) # We don't have an x with colnames, so see if we have one without colnames. # We re-call is.errmsg() below to prevent re-issuing messages # in is.good.data() which we have already issued previously. if(try.object.x.or.y && !is.errmsg(object.x) && is.good.data(object.x, sprint("object$%s", field), trace, check.colnames=FALSE)) return(ret.good.field(object.x, FALSE, sprint("object$%s", field))) if(!is.errmsg(call.x) && is.good.data(call.x, sprint("call$%s", field), trace, check.colnames=FALSE)) return(ret.good.field(call.x, TRUE, sprint("getCall(object)$%s", field))) if(argn && !is.errmsg(argn.x) && is.good.data(argn.x, argn.name, trace, check.colnames=FALSE)) return(ret.good.field(argn.x, TRUE, sprint("object$%s", field))) # unsuccessful errmsg.for.get.x.or.y(field, trace, try.object.x.or.y, argn, object.x, model.frame.x, call.x, argn.x) is.earth.cv.model <- is.null(object.x) && !is.null(object$ifold) && inherits(object, "earth") stopf("cannot get the original model %s%s", if(field == "x") "predictors" else "response", if(is.earth.cv.model) " (use keepxy=2 in the call to earth)" else "") } is.errmsg <- function(x) { is.try.err(x) || (is.character(x) && length(x) == 1) } # Is the x argument a valid x or y for a model? # This returns TRUE or FALSE, silently unless trace >= 2. is.good.data <- function(x, xname="field", trace=0, check.colnames=TRUE) { good <- !is.null(x) && !is.try.err(x) && NROW(x) >= 3 has.colnames <- good && !is.null(colnames(x)) && !any(colnames(x) == "") if(trace >= 2) trace.data(good, has.colnames, x, xname, trace, check.colnames) good && (!check.colnames || has.colnames) } trace.data <- function(good, has.colnames, x, xname, trace, check.colnames) { stopifnot.string(xname) colnames.msg <- if(good && has.colnames) { sprint(" and has column name%s %s", if(length(colnames(x)) == 1) "" else "s", paste.trunc(colnames(x), maxlen=100)) } else if(good) sprint(" but without colnames %s", if(check.colnames) "so we will keep on searching" else "but we will use it anyway") else "" if(good) printf("%s is usable%s\n", xname, colnames.msg) else if(is.null(x)) printf("%s is NULL%s\n", xname, if(check.colnames) " (and it has no colnames)" else "") else if(!is.character(x) && NROW(x) < 3) printf("%s has less than three rows\n", xname, if(check.colnames) " (and it has no colnames)" else "") else printf("%s is not usable%s\n", xname, colnames.msg) # print bad data, but only on the first go around for this data # (use check.colnames as an indicator of first go around) if(!is.null(x) && check.colnames) { if(!good) printf("%s:%s\n", xname, format_err_field(x, xname, trace)) else if(trace >= 4) { printf("trace>=4: ") print_summary(x, xname, trace=2) } } } errmsg.for.get.x.or.y <- function(field, trace, try.object.x.or.y, argn, object.x, model.frame.x, call.x, argn.x) { printf("\nLooked unsuccessfully for the original %s in the following places:\n", if(field == "x") "predictors" else "response") ifield <- 1 if(try.object.x.or.y) { printf("\n(%d) object$%s:%s\n", ifield, field, format_err_field(object.x, field, trace)) ifield <- ifield + 1 } printf("\n(%d) model.frame:%s\n", ifield, format_err_field(model.frame.x, field, trace)) ifield <- ifield + 1 printf("\n(%d) getCall(object)$%s:%s\n", ifield, field, format_err_field(call.x, field, trace)) ifield <- ifield + 1 if(argn) printf("\n(%d) argument %d of the model call:%s\n", ifield, argn+1, format_err_field(argn.x, field, trace)) printf("\n") } format_err_field <- function(x, xname, trace=0) { if(is.try.err(x)) { errmsg <- sub(".* : *", "", x[1]) # strip prefix "Error in xxx : " errmsg <- gsub("\n *\\^", "", errmsg) # strip " ^" in some err msgs errmsg <- gsub("[\n\t ]+", " ", errmsg) # collapse newlines and multiple spaces errmsg <- gsub("^ *| *$", "", errmsg) # delete remaining leading and trailing space sprint(" %s", errmsg) } else if(is.errmsg(x)) sprint(" %s", x) else if(is.null(x)) sprint(" NULL") else if(NROW(x) < 3) sprint(" less than three rows") else if(!is.null(dim(x))) { print_summary(x, xname, trace=2) sprint(" is not usable (see above)") } else sprint(" class \"%s\" with value %s", class(x), try(paste.trunc(format(x))[1])) } # Get object$x or object$y from the model. # Return x (or y) or NULL or an error message. # # The approach taken in all helper routines for get.x.or.y # (such as get.object.x.or.y.field) is that we issue trace messages # here in the helper routine, and the caller silently checks # the returned value for good data. # # For a model with a formula, the standard path is to apply the # naked formula to the data using model.frame(). # Example with argument field="x": # # formula(object) resp~num + sqrt(num) + bool + ord:num + fac # naked formula resp~num + bool + ord + fac # data colnames resp bool ord fac str num nx int date # returned colnames num bool ord fac get.object.x.or.y.field <- function( # get object$x or object$y object, # the model field, # "x" or "y" trace, try.object.x.or.y=TRUE, # FALSE if object[[field]] should be ignored naked=TRUE) # TRUE for columns like "x3" not "ns(x3,4)" { trace2(trace, "\nget.object.%s:\n", field) x <- NULL xname <- sprint("object$%s", field) # for tracing if(!try.object.x.or.y) # e.g. we must ignore object$x for mda::mars models trace2(trace, "ignoring %s for this %s object\n", xname, class.as.char(object)) else { # note we use object[["x"]] rather than object$x to prevent partial # matching (but the error messages use object$x for readability) x <- object[[field]] if(is.good.data(x, xname, trace)) x <- cleanup.x.or.y(object, x, field, trace, check.naked=naked && field != "y") else if(!is.null(x) && !is.good.data(x, check.colnames=FALSE)) { # Issue a warning because predict.lm will probably crash # later when it internally accceses object$x. # We call is.good.data(check.colnames=FALSE) above to check if the # prior call to is.good.data() failed merely because of a colname # issue (if it's just a colname issue then don't issue warning). warnf("object$%s may be corrupt", field) } } x # return x or NULL or an error message } # Get getCall(object)$x (or similar) from the model's call field. # Return x (or similar) or NULL or an error message. get.data.from.object.call.field <- function(object, field, trace, check.is.good.data=TRUE) { trace2(trace, "\nget.data.from.object.call.field:\n") x <- NULL xname <- sprint("getCall(object)$%s", field) call <- getCall(object) if(is.null(call)) trace2(trace, "getCall(object) is NULL so cannot get %s\n", xname) else if(!is.call(call)) trace2(trace, "getCall(object) is not actually a call so cannot get %s", xname) else { x <- try.eval(call[[field]], model.env(object), trace=trace, expr.name=xname) if(is.errmsg(x)) trace2(trace, "%s\n", x) else if(check.is.good.data) # invoke is.good.data purely for issuing trace messages is.good.data(x, xname, trace) } x } # Get the n'th arg in the call to the model function. # # This is for those model functions whose second argument is the # response (what we call "y"), although that argument's name is # not "y". For example, argn=2 will select the "grouping" arg in # qda(x=lcush[,2:3], grouping=lcush[,1]). # # Returns list(argn.x, argn) # where argn.x is the evaluated n'th argument or NULL or an error message. # and argn will be set 0 if routine processing says we should ignore argn. get.argn.from.call <- function(argn, object, field, trace, nrows.argn) { x <- NULL if(argn) { temp <- get.argn.from.call.aux(argn, object, field, trace, nrows.argn) x <- temp$x argn <- temp$argn if(is.errmsg(x)) trace2(trace, "%s\n", x) else # invoke is.good.data purely for issuing trace messages is.good.data(x, sprint("argument %d of the model call", argn), trace) } list(x=x, argn=argn) } # auxilary function for get.argn.from.call get.argn.from.call.aux <- function(argn, object, field, trace, nrows.argn) { ret <- function(x, argn) { list(x=x, argn=argn) } #--- get.argn.from.call.x starts here stopifnot(argn > 0) call <- getCall(object) if(is.null(call)) return(ret("getCall(object) is NULL so cannot use argn", argn)) if(!is.call(call)) return(ret("getCall(object) is not actually a call so cannot use argn", argn)) if(length(call) <= argn) return(ret(sprint( "cannot use argn %d because getCall(object) does not have %d arguments", argn, argn), argn)) names.call <- names(call) # some names may be "" trace2(trace, "names(call) is %s\n", quotify(names.call)) # If argn is field (i.e. "x" or "y"), don't process it here because # we process call$x and call$y elsewhere (in get.data.from.object.call.field). # This is a common case, so we clear argn for uncluttered message # later in errmsg.for.get.x.or.y. # If the arg name is "" in getCall(object) this won't work, not serious. if(identical(names.call[argn+1], field)) return(ret(sprint( "the name of argument %d is \"%s\" so we will not process it with argn", argn, field), argn=0)) # If an argument of the call is "formula" then return, because # any arg named "x" or "y" is unlikely to be model data. # This is a a common case, so clear argn. if(pmatch("formula", names.call[2], 0)) return(ret(sprint( "ignoring argn %g because there is a formula argument", argn), argn=0)) x <- try.eval(call[[argn+1]], model.env(object), trace=trace, sprint("argument %d of the model call", argn)) if(is.data.frame(x)) x <- x[[1]] if(!(is.numeric(x[1]) || is.logical(x[1]) || is.factor(x[1]))) return(ret(sprint( "cannot use argn %d because it is not numeric, logical, or a factor", argn), argn)) if(is.null(nrows.argn)) # should never happen stop0("cannot use argn because the expected number of rows is unspecified") if(NROW(x) != nrows.argn) return(ret(sprint( "cannot use argn %g because it has %g rows but expected %g rows", argn, NROW(x), nrows.argn), argn)) list(x=x, argn=argn) } # If object has a formula, use that formula to get x or y (field is "x" or "y"). # Returns list(x, do.subset, form.as.char, source) where x may be an err msg and source # is a string describing where we got the data from (only used if no err msg). get.x.or.y.from.model.frame <- function(object, field, trace, naked, na.action="auto", newdata=NULL) { ret <- function(...) # ... is an err msg in printf form { errmsg <- sprint(...) trace2(trace, "%s\n", errmsg) list(x=errmsg, do.subset=FALSE, formula=NULL, source="model frame") } #--- get.x.or.y.from.model.frame starts here stopifnot(field == "x" || field == "y") trace2(trace, "\nget.%s.from.model.frame:\n", field) mf <- get.model.frame(object, field, trace, naked, na.action, newdata) if(!is.good.data(mf$x)) return(mf) model.frame <- mf$x if(field == "x") { # Check if any vars have $ in their name, this confuses predict() later. # They cause "Error in model.frame.default: variable lengths differ" # or "newdata had 50 rows but variables found have 330 rows" ibad <- grep("[._[:alnum:]]\\$", colnames(model.frame)) if(any(ibad)) { warnf("%s: \"$\" in colnames(model.frame) is not supported by plotmo, %s", colnames(model.frame)[ibad[1]], "will try to get the data elsewhere") return(ret("\"$\" in colnames(model.frame)")) } } # got the model.frame, now get the column index(s) of the response in the model.frame iresponse.col <- get.iresponse.col(object, model.frame, mf$isFormula, trace=if(field=="y") trace else 0) # reduce number of msgs if(field == "x") { # drop the response column(s) x <- model.frame[, -iresponse.col, drop=FALSE] if(!is.good.data(x, sprint("x=model.frame[,-%s]", paste.c(iresponse.col)), trace)) return(ret("invalid model.frame[,-iresponse]")) } else { # field == "y" # select the response column(s) # we don't use model.response() here because that drops the column name x <- model.frame[, iresponse.col, drop=FALSE] if(!is.good.data(x, sprint("y=model.frame[,%s]", paste.c(iresponse.col)), trace)) return(ret("invalid model.frame[,iresponse]")) } list(x=x, do.subset=mf$do.subset, formula=mf$formula, source=mf$source) } # The following is derived from stats::model.frame.default but tries to # also handle models that didn't save the terms etc. in a standard way. # It never uses parent.frame (as some model.frame methods do). # # We will use the given na.action. But if na.action="auto" then get # na.action from the model itself, and do a little special handling. # # Returns list(x, do.subste, formula, source, isFormula) # where x may be an err msg # source s a string describing where we got the data from (only used if no err msg) get.model.frame <- function(object, field, trace, naked, na.action="auto", newdata=NULL) { ret <- function(x, do.subset=FALSE, formula=NULL, source="model frame", isFormula=FALSE) { list(x=x, do.subset=do.subset, formula=formula, source=source, isFormula=isFormula) } #--- get.model.frame starts here # get.model.formula returns a Formula or formula with an environment, or an error string modform <- get.model.formula(object, trace, naked) formula <- modform$formula if(is.errmsg(formula)) return(ret(formula)) # return errmsg isFormula <- inherits(formula, "Formula") # Formula vs formula trace2(trace, "formula is valid, now looking for data for the model.frame\n") if(!is.null(newdata)) { if(!is.good.data(newdata, "newdata", trace)) return(ret("bad newdata")) # return errmsg data <- newdata data.source <- "newdata" } else { # use object$model if possible (e.g. lm) # TODO the following code really belongs in get.data.for.model.frame? x <- object[["model"]] if(is.good.data(x, "object$model", trace)) { # Drop column named "(weights)" created by lm() if called with weights # (must drop else x will be rejected because non-naked colname). x <- x[, which(colnames(x) != "(weights)"), drop=FALSE] if(trace >= 3) print_summary(x, "model.frame", trace) # Note that we call check.naked even when the naked=FALSE. # Not essential, but gives more consistency so we select the same object$x, # getCall(object), or etc. regardless of whether naked is set or clear. if(is.null(check.naked(x, "object$model", trace))) # good object$model? return(ret(x, FALSE, formula, "object$model", isFormula)) } temp <- get.data.for.model.frame(object, trace) data <- temp$data data.source <- temp$source if(!is.good.data(data)) { # data is not usable (could be NULL) # following is for when no data argument when model was built data <- model.env(object) data.source <- "model.env(object)" } } if(is.character(na.action) && length(na.action) == 1 && na.action == "auto") { na.action <- na.action(object) class.na.action <- class(na.action) # following is for rpart's and ctree's (special but useful) NA handling if(is.null(na.action)) na.action <- if(inherits(object, "rpart") || inherits(object, "party_plotmo")) "na.pass" else "na.fail" else if(length(class.na.action) == 2 && class.na.action[1] == "na.rpart") na.action <- paste0("na.", class(na.action)[2]) else if(class.na.action[1] %in% c("exclude", "fail", "omit", "pass")) na.action <- paste0("na.", class(na.action)[1]) trace2(trace, "na.action(object) is %s\n", as.char(na.action)) } if(!is.function(na.action) && !is.character(na.action)) { errmsg <- sprint("bad na.action: %s", as.char(na.action)) trace2(trace, "%s\n", errmsg) return(ret(errmsg)) } if(trace >= 3) { printf("model.env is %s\n", environment.as.char(model.env(object))) print_summary(data, "data", trace) } data.source <- if(is.environment(data)) environment.as.char(data) else if(is.null(data)) "NULL" else data.source mfcall.as.char <- sprint("model.frame(%s, data=%s, na.action=%s)", paste.trunc(modform$form.as.char, maxlen=40), data.source, trunc.deparse(na.action)) trace2(trace, "stats::%s\n", mfcall.as.char) x <- try(do.call(stats::model.frame, # calls model.frame.default args=list(formula=formula, data=data, na.action=na.action)), silent=trace < 2) if(trace >= 3) print_summary(x, "model.frame returned", trace) ret(x, if(is.null(newdata)) TRUE else FALSE, formula, mfcall.as.char, isFormula) } get.data.for.model.frame <- function(object, trace) { ret <- function(errmsg, data=NULL, source="model frame") { if(!is.null(errmsg)) trace2(trace, "%s\n", errmsg) list(data=data, source=source) } # try object$data e.g. earth models with formula and keepxy=T # the inherits check is becauses party objects for e.g. "medv ~ log(lstat) + rm^2" # save "log(lstat)" not "lstat" in object data, that confuses model.frame.default if(!inherits(object, "party_plotmo")) { data <- object[["data"]] if(is.good.data(data, "object$data", trace)) return(ret(NULL, data, "object$data")) } # look for the data in getCall(object) call <- object[["call"]] if(is.null(call)) return(ret("getCall(object) is NULL so cannot get the data from the call")) if(!is.call(call)) return(ret("getCall(object) is not actually a call so cannot get the data from the call")) data <- NULL argname <- "NULL" # try getCall(object)$data idata <- match(c("data"), names(call), 0)[1] if(idata > 0) { trace2(trace, "argument %g of the call is 'data'\n", idata-1) argname <- "call$data" # Mar 2019: TODO this doesn't work (if model was built internally to another # function?) because it tries to get data from .RGlobalEnv (which in that # environment is a function "data"). Perhaps failure is because terms(mf) seems # to generate a terms field ".GlobalEnv" regardless of where the mf was evaluated. # Workaround for earth models: use keepxy=TRUE (to avoid this code) data <- try(eval.trace(call[[idata]], model.env(object), trace=trace, expr.name=argname), silent=FALSE) # so user can see what went wrong is.good.data(data, argname, trace) # purely for tracing } else { # no getCall(object)$data, search for an arg that looks like good data trace2(trace, "getCall(object) has no arg named 'data', will search for an arg that looks like data\n") if(length(call) >= 3) { # start at 3 to ignore fname and first arg (the formula) for(icall in 3:length(call)) { arg <- call[[icall]] if(class(arg)[1] == "name") { # paranoia, will always be true? argname <- sprint("call$%s", quotify(as.character(arg))) data <- eval.trace(arg, model.env(object), trace=trace, expr.name=argname) if(is.good.data(data, argname, trace=trace)) { trace2(trace, "%s appears to be the model data\n", argname) idata <- icall break } else { trace2(trace, "%s is not the model data\n", argname) data <- NULL } } } } } if(is.good.data(data, argname)) { # following needed for e.g. nnet(O3~., data=scale(ozone1), size=2) # Else get Error in model.frame.default: 'data' must be a data.frame. if(!is.data.frame(data)) { data <- try(my.data.frame(data, trace)) # invoke is.good.data purely for issuing trace messages is.good.data(data, sprint( "%s converted from \"%s\" to \"data.frame\"", argname, class(data)[1]), trace) } } ret(NULL, data, argname) } # get the column index(s) of the response in the model.frame, return 1 if can't (best guess is 1) get.iresponse.col <- function(object, model.frame, isFormula, trace) { assuming <- sprint("assuming \"%s\" in the model.frame is the response, because", gen.colnames(model.frame, prefix="model.frame", trace=trace)[1]) iresponse.col <- 1 terms <- try(terms(object), silent=TRUE) if(is.null(terms)) { # e.g. bagEarth.formula and nn trace1(trace, "%s terms(object) is NULL\n", assuming) return(1) # assume iresponse.col is 1 } if(is.try.err(terms)) { trace1(trace, "%s terms(object) did not return the terms\n", assuming) return(1) } # object seems to have a valid terms field iresponse.col <- attr(terms, "response") if(is.null(iresponse.col) || !is.numeric(iresponse.col) || length(iresponse.col) != 1) { trace1(trace, "%s attr(terms, \"response\") is invalid\n", assuming) return(1) } if(iresponse.col != 0) { if(isFormula) { trace1(trace, "%s object used Formula (not formula) yet attr(terms, \"response\") is nonzero\n", assuming) return(1) } iresponse.col <- try(check.index(iresponse.col, "attr(terms, \"response\")", model.frame, is.col.index=TRUE, allow.negatives=FALSE)) } else { # iresponse.col == 0 if(!isFormula) { trace1(trace, "%s attr(terms, \"response\") is 0\n", assuming) return(1) } # isFormula iresponse.col <- attr(terms, "Response") if(is.null(iresponse.col)) { # will happen for any model that uses Formula (not formula), except earth trace1(trace, "%s the model was built with Formula (not formula)\n", assuming) return(1) } if(is.null(iresponse.col) || !is.numeric(iresponse.col)) { trace1(trace, "%s attr(terms, \"Response\") is invalid\n", assuming) return(1) } iresponse.col <- try(check.index(iresponse.col, "attr(terms, \"Response\")", model.frame, is.col.index=TRUE, allow.negatives=FALSE)) } if(is.try.err(iresponse.col)) { trace1(trace, "%s calculated index was invalid\n", assuming) iresponse.col <- 1 } iresponse.col } isa.formula <- function(x) { (typeof(x) == "language" && as.list(x)[[1]] == "~") || (is.character(x) && length(x) == 1 && grepany("~", x)) } get.index.of.formula.arg.in.call <- function(call, trace) { iform <- match(c("formula"), names(call), 0) if(iform) return(iform) # no arg named "formula" in call, so look for a formula elsewhere in call # TODO for which model was this code added? I think it's needed if formula arg is unnamed? call <- as.list(call) # start at 2 to skip call[1] which is the function name for(iform in 2:length(call)) { if(isa.formula(call[[iform]])) { # warning0("the formula in the model call is not named 'formula'") trace2(trace, "argument %d in getCall(object) is a formula\n", iform) return(iform) # note return } } 0 # no formula } # return a Formula or formula with an environment, or an error string get.model.formula <- function(object, trace, naked) { ret <- function(...) # ... is an err msg in printf form { errmsg <- sprint(...) trace2(trace, "%s\n", errmsg) list(formula=errmsg, form.as.char="formula") } #--- get.model.formula starts here # try getting the formula from the terms field (object used formula) terms <- try(terms(object), silent=TRUE) if(is.null(terms)) trace2(trace, "terms(object) is NULL, will look for the formula elsewhere\n") else if(is.try.err(terms)) trace2(trace, "terms(object) did not return the terms, will look for the formula elsewhere\n") else { # object has a valid terms field # TODO Sep 2020 ask Formula package people to extend # (currently only earth supports attr(terms, "Formula") and "Response" form <- attr(terms, "Formula") isFormula <- !is.null(form) # "Formula" vs "formula" if(isFormula) { trace1(trace, "object created with Formula (not formula): using attr(terms, \"Formula\")\n") form <- formula_as_char_with_check(form, "attr(terms, \"Formula\")", trace) } else { form <- try(formula(terms), silent=TRUE) form <- formula_as_char_with_check(form, "formula(object)", trace) } if(!is.null(form$form.as.char)) return(process.formula(object, form$form.as.char, isFormula, trace, naked)) # if there was a $ in the form.as.char there is no point in looking at the call # formula, so to avoid issuing the same warning twice, we return # immediately here if(grepl("\"$\"", form$errmsg, fixed=TRUE)) return(ret(form$errmsg)) } # try getting the formula from getCall(object) call <- object[["call"]] if(is.null(call)) return(ret("getCall(object) is NULL so cannot get the formula from the call")) if(!is.call(call)) return(ret("getCall(object) is not actually a call so cannot get the formula from the call")) iform <- get.index.of.formula.arg.in.call(call, trace) if(iform == 0) # no formula? return(ret("no formula in getCall(object)")) # nasty name change, else model.frame.default: invalid type (language) # TODO clean this up, this won't work because it doesn't change the calling obj # names.call <- names(call) # names.call[iform] <- "formula" # names(call) <- names.call # note <<- not <- form.name <- sprint("model call argument %d", iform-1) form <- eval(call[[iform]], model.env(object)) form <- formula_as_char_with_check(form, form.name, trace) if(is.null(form$form.as.char)) return(ret(form$errmsg)) # TODO More classes could be added to the following assignment to isFormula # (and remember we can only get here if object doesn't have a terms field, # and I believe the objects below do in fact have a terms field) isFormula <- inherits(object, c("pre")) process.formula(object, form$form.as.char, isFormula=isFormula, trace, naked) } # convert the formula to character, and also check it formula_as_char_with_check <- function(form, form.name, trace) { ret.null <- function(...) # ... is an err msg in printf form { errmsg <- sprint(...) trace2(trace, "%s\n", errmsg) list(form.as.char=NULL, errmsg=errmsg) } if(is.try.err(form)) return(ret.null("%s did not return a formula", form.name)) if(is.null(form)) return(ret.null("%s is NULL", form.name)) if(class(form)[1] != "formula" && !class(form)[1] == "Formula" && !(is.character(form) && length(form) == 1)) return(ret.null("%s is not a formula or Formula (its class is \"%s\")", form.name, class(form)[1])) form.as.char <- paste.collapse(format(form)) trace2(trace, "%s is %s\n", form.name, paste.trunc(form.as.char)) if(!grepl("[^ \t]+.*~", form.as.char)) return(ret.null("%s has no response", form.name)) # Check if any vars have $ in their name, this confuses predict() later. # TODO Following comments are no longer accurate? # We do this check in get.x.or.y.from.model.frame but pre-emptively also here # (where we have the formula) for a slightly more informative error message. # (The other message kicks in if we get the model.frame from object$model.) rhs <- gsub(".*~ *", "", form.as.char) if(grepany("[._[:alnum:]]\\$", rhs)) { # check for "ident$" warnf("\"$\" in the formula is not supported by plotmo, %s\n formula: %s", "will try to get the data elsewhere", rhs) return(ret.null("%s: \"$\" in formula is not allowed", form.name)) } list(form.as.char=form.as.char, errmsg=NULL) } # Return a formula with an environment. Also process naked. # TODO this includes Height in Volume~Girth-Height, it shouldn't process.formula <- function(object, form.as.char, isFormula, trace, naked) { stopifnot(is.character(form.as.char)) stopifnot(length(form.as.char) == 1) if(naked) form.as.char <- naken.formula.string(form.as.char, trace) form <- try(formula(form.as.char, env=model.env(object)), silent=TRUE) if(isFormula && !is.try.err(form)) form <- try(Formula::Formula(form)) if(is.try.err(form)) { # prepend "formula(%s) failed" for a clearer msg in format_err_field later form <- sprint("%s(%s) failed%s", if(isFormula) "Formula" else "formula", quotify(form.as.char), # only append err msg if tracing because err msgs can be obscure if(trace >= 1) sprint("(%s)", cleantry(form)) else "") trace2(trace, "%s\n", form) form <- sprint("Error : %s", form) } list(formula=form, form.as.char=form.as.char) } # Given a formula (as string), return a string with the "naked" predictors. # This is used for getting the data to pass to predict. # # Example: log(y) ~ x9+ns(x2,4) + s(x3,x4,df=4) + x5:sqrt(x6) # becomes: log(y) ~ x9 + x2 + x3 + x4 + x5 + x6 # which will later result in a model.matrix with columns x9 x2 x3 x4 x5 x6. # # Note that we don't naken the response (so for # example in the above log(y) remains unchanged). # # This routine is not infallible but works for the commonly used formulas. # It's a hack that relies on regular expressions. naken.formula.string <- function(form.as.char, trace) { stopifnot(is.character(form.as.char)) form.as.char <- paste.collapse(form.as.char) old.form.as.char <- form.as.char naked <- gsub(".*~", "", form.as.char) # extract everything after ~ naked <- naken.collapse(naked, warn.if.minus=TRUE) if(grepl("~", form.as.char)) { response <- gsub("~.*", "", form.as.char) # extract up to the ~ response <- gsub("^ +| +$", "", response) # trim leading and trailing spaces if(nchar(response)) response <- paste0(response, " ~") naked <- paste.collapse(response, naked) } trace2(trace, if(strip.space(naked) == strip.space(old.form.as.char)) "naked formula is the same%.0s\n" # e.g. O3~vh+wind else "naked formula is %s\n", naked) naked } is.naked <- function(colnames) # returns a logical vector { naked <- logical(length(colnames)) for(i in seq_len(length(colnames))) { colname <- strip.space(colnames[i]) naked[i] <- colname == naken.collapse(colname) } naked } # Return an err msg if colnames(x) is not "naked". # Return NULL if everything is ok. # # Example: in lm(Volume~poly(Height, degree=3), data=trees, x=T), # object$x, object$data, and object$model have # colnames like "poly(Height, degree = 3)1" # where plotmo (actually model.frame.default) gives "Error: object 'x1' not found" # unless we preempt that obscure error message here. check.naked <- function(x, xname, trace) { errmsg <- NULL colnames <- colnames(x) # column name "(Intercept)" must be considered naked colnames <- sub("(Intercept)", "Intercept", colnames, fixed=TRUE) is.naked <- is.naked(colnames) if(any(!is.naked)) { # e.g. lm(formula=log(doy)~vh, ...) errmsg <- sprint( "%s cannot be used because it has%s non-naked column name%s %s", xname, if(sum(!is.naked) > 1) "" else " a", if(sum(!is.naked) > 1) "s" else "", quotify.trunc(colnames[!is.naked])) trace2(trace, "%s\n", errmsg) } errmsg } # Returns x or an error message (currrently an error message # is returned only if naked=TRUE but colnames are not naked). cleanup.x.or.y <- function(object, x, field, trace, check.naked) { x <- handle.nonvector.vars(object, x, field, trace) # remove column "(Intercept)" e.g. object$x for lm(y~x1+x2, x=TRUE) if(!is.na(i <- match("(Intercept)", colnames(x)))) { trace2(trace, "dropped \"(Intercept)\" column from %s\n", field) x <- x[,-i, drop=FALSE] } if(check.naked) { errmsg <- check.naked(x, field, trace) if(!is.null(errmsg)) return(errmsg) } x } # This tries to clean up columns of x that are themselves matrices or data.frames. # # Example (where the actual values in the x and y are not important): # x <- matrix(c(1,3,2,4,5,6,7,8,9,10, # 2,3,4,5,6,7,8,9,8,9), ncol=2) # colnames(x) <- c("c1", "c2") # y <- 3:12 # a <- lm(y~x) # seems natural, but lm doesn't handle it as we might expect # Cannot get predict to work with newdata on above lm model # Causes for example 'newdata' had 8 rows but variables found have 10 rows # # Another example: # library(ElemStatLearn); x <- mixture.example$x; # g <- mixture.example$y; a <- lm(g ~ x) # # This routine also prevents a misleading error msg later in plot_degree1 # (illegal index, missing column in x) caused by the following code: # data(gasoline, package='pls') # plotmo(earth(octane ~ NIR, data=gasoline)) # where NIR has class "AsIs" and is a matrix. # There appears to be no easy fix for this (July 2011). handle.nonvector.vars <- function(object, x, field, trace) { if(!is.data.frame(x)) return(x) ndims.of.each.var <- sapply(x, function(x) NCOL(x)) if(all(ndims.of.each.var == 1)) { # we are ok: NCOL is 1 for all variables (even though some # may not be vectors i.e. they could be single column mats) return(x) } format <- paste0("%s variable on the %s side of the formula is a matrix or data.frame\n", " plotmo often cannot process such variables") msg <- sprint(format, if(ncol(x) == 1) "the" else "a", if(field == "x") "right" else "left") if(field == "x") { # We issue the warning only if this is the rhs, because we seem to be able # to recover when the lhs is a non vector. Thus we correctly don't issue # warnings for valid models like earth(cbind(O3,doy)~., data=ozone1) and # glm(cbind(damage, 6-damage)~temp, family=binomial, data=orings). warning0(msg) } else if(trace >= 2) { printf("%s\n", msg) printf("the number of dimensions of each variable in %s is %s and ", field, paste.trunc(ndims.of.each.var)) # details is 1 not 2 below else huge output print_summary(x, sprint("%s is ", field), trace, details=-1) } # Attempt to fix the problem by replacing x with x[[1]]. However # for the rhs this only sometimes works --- there may be downstream # problems, typically in predict (because the column names are wrong?). if(ndims.of.each.var[1] > 1) { # first variable is not a vector trace2(trace, "replacing %s with %s[[1]]%s\n", field, field, if(length(ndims.of.each.var) == 1) "" else ", ignoring remaining columns") org.colnames <- colnames(x) x <- x[[1]] # add column names (helps keep track later) if(is.null(colnames(x))) { safe.org.colnames <- if(is.null(org.colnames)) # can never happen, but best to be sure field else org.colnames if(NCOL(x) > 1) colnames(x) <- paste0(safe.org.colnames[1], "[,", 1:NCOL(x), "]") else # e.g. glm(formula=response~temp, family="binomial", data=...) colnames(x) <- safe.org.colnames[1] trace2(trace, "%s colnames were %s and now %s\n", field, if(is.null(org.colnames)) "NULL" else quotify.trunc(org.colnames), quotify.trunc(colnames(x))) } } x } # Detect if the model is a glm model, and if so possibly convert the # response. We do this in the same way as glm() does internally: # # o A factor response get converted to indicator column of # ones and zeros (first level vs the rest). # # o Two column binomial responses get converted to a single # column of fractions. # # Note that responses for earth models are handled independently # in plotmo.y.earth (two level factor to single numeric column, # three of more level factors to three or more indicator columns). convert.glm.response <- function(object, y, trace) { # check if y is is factor, or first column of y is a factor is.factor <- is.factor(y) || (length(dim(y) == 2) && ncol(y) == 1 && is.factor(y[,1])) if(is.factor) y <- convert.glm.response.factor(object, y, trace) else if(NCOL(y) == 2) # possibly a two column binomial model y <- possibly.convert.glm.two.column.response(object, y, trace) y } is.nomial <- function(object) { is.nomial.string <- function(family) { family[1] == "binomial" || family[1] == "quasibinomial" || family[1] == "multinomial" } if(!is.list(object)) return(FALSE) family <- object$family if(is.character(family)) # glmnet models return(is.nomial.string(family)) fam <- try(family(object), silent=TRUE) if(inherits(fam, "family")) { # lm, glm, etc models family <- fam$family if(is.character(family)) return(is.nomial.string(family)) } FALSE } convert.glm.response.factor <- function(object, y, trace) { if(!is.nomial(object)) { # e.g. rpart(formula=Kyphosis~., data=kyphosis) trace2(trace, "the response is a factor but could not get the family of the %s model\n", class.as.char(object)) } else { # e.g. glm(formula=sex~., family=binomial, data=etitanic) if(!is.null(dim(y))) { # data.frame or matrix levels <- levels(y[,1]) y[,1] <- y[,1] != levels[1] } else { # vector levels <- levels(y) y <- y != levels[1] y <- data.frame(y) } # column naming helps us keep track that we did this manipulation of x colnames(y) <- if(length(levels) > 1) paste0("is", levels[2]) else paste0("not", levels[1]) trace2(trace, "generated indicator column \"%s\" from levels %s\n", colnames(y)[1], paste.trunc(levels)) } y } possibly.convert.glm.two.column.response <- function(object, y, trace) { if(is.nomial(object)) { # following are sanity checks # note also that here we treat a two column multinom model as a binom model stopifnot(NCOL(y) == 2) if(!is.numeric(y[,1]) || !is.numeric(y[,2])) warning0("non-numeric two column response for a binomial model") else if(any(y[,1] < 0) || any(y[,2] < 0)) warning0("negative values in the two column response ", "for a binomial model") # example 1 glm(formula=response~temp, family="binomial", data=orings) # example 2 glm(formula=cbind(damage,6-damage)~temp, family="bi...) org.colnames <- colnames(y) y <- bpairs.yfrac(y[,1:2], trace=(trace!=0)) y <- data.frame(y) # column naming helps us keep track that we did this manipulation of x if(!is.null(org.colnames)) { colnames(y) <- # gsub deletes things like "[,2]" paste0(gsub("\\[.*\\]", "", org.colnames[1]), ".yfrac") trace2(trace, "created column \"%s\" from two column binomial response\n", colnames(y)) } } y } get.and.check.subset <- function(x, object, trace) { is.valid <- function(subset) { !is.null(subset) && (is.numeric(subset) || is.logical(subset)) } #--- get.and.check.subset starts here subset <- object$subset if(is.valid(subset)) msg <- "object$subset" else { subset <- try(eval(getCall(object)$subset, model.env(object)), silent=TRUE) if(is.try.err(subset)) subset <- NULL else msg <- "getCall(object)$subset" } if(!is.valid(subset)) subset <- NULL else { # duplicates are allowed in subsets so user can specify a bootstrap sample check.index(subset, "subset", x, allow.dups=TRUE, allow.zeros=TRUE) if(trace >= 2) { cat0("got subset from ", msg, " length " , length(subset)) print_first_few_elements_of_vector(subset, trace) } } subset } plotmo/R/predict.R0000644000176200001440000001270314663771205013560 0ustar liggesusers# predict.R: plotmo wrapper functions for predict() # Returns an n x 1 matrix (unless nresponse=NULL then returns an n x q dataframe) # # The newdata argument can be a positive integer n, which is the same as # newdata=NULL but may return only n rows if that is more efficient. # This is for efficiency in plotmo_meta. plotmo_predict <- function(object, newdata, nresponse, type, expected.levs, trace, inverse.func=NULL, ...) { # handle special case where newdata specifies the number of rows nrows <- 0 if(is.numeric(newdata) && length(newdata) == 1 && newdata > 0) { nrows <- newdata newdata <- NULL } if(is.null(newdata)) { # It generally faster to use newdata=NULL. But not all models correctly # process the type argument with null newdata. So here we check for some # models that are known good that way. The inherits function is not # used here because for example a glm model inherits("lm") but with # NULL newdata doesn't process type as we might hope. if(class(object)[1] %in% c("lm", "earth")) trace2(trace, "calling predict.%s with NULL newdata\n", class.as.char(object)) else { # assume object cannot handle newdata=NULL trace2(trace, "plotmo_predict with NULL newdata%s, %s", if(nrows) sprint(" (nrows=%d)", nrows) else "", "using plotmo_x to get the data\n") newdata <- plotmo_x(object, trace) if(nrows) newdata <- newdata[seq_len(nrows),,drop=FALSE] trace2(trace, "will use the above data instead of newdata=NULL for predict.%s\n", class.as.char(object)) } } else print_summary(newdata, "newdata", trace) yhat <- plotmo.predict(object=object, newdata=newdata, type=type, ..., TRACE=if(trace >= 2) trace else trace.call.global) temp <- process.y(yhat, object, type, nresponse, expected.len=nrow(newdata), expected.levs, trace, fname="predict") yhat <- apply.inverse.func(inverse.func, temp$y, object, trace) list(yhat = yhat, # n x 1 matrix (unless nresponse=NULL then an n x q dataframe) resp.levs = temp$resp.levs, resp.class = temp$resp.class) } # TRACE is passed to do.call.trace (if TRACE>0 print the call to predict) plotmo.predict <- function(object, newdata, type, ..., TRACE) { stopifnot.string(type) UseMethod("plotmo.predict") } # this handles a common mistake # (TODO I think this is now pre-empted by plotmo initial tests on model) plotmo.predict.list <- function(object, ...) { stop0("object does not have a predict method") } # plotmo.predict.default calls predict for the given object, # and does tracing and error handling. # # It also allows use to pre-program default args for predict, # which can be overruled or augmented by args passed in dots. # These defaults args must be specified in the calling function. For example # plotmo.predict.default(object, newdata, type=type, def.foo=3, ...) # will pass foo=3 to predict --- unless the caller of plotmo passes # predict.foo=0 to plotmo, which will override the default and pass foo=0 # to predict. # When specifying defaults, use the full arg name (no abbreviations) # prefixed by "def.". plotmo.predict.default <- function( object, newdata, ..., # extra args to predict, first typically is type="xxx" TRACE, # passed to do.call.trace (if TRACE>0 print the call to predict) FUNC=NULL) # predict function, NULL means use stats::predict { fname <- "PREDICTFUNC" if(is.null(FUNC)) { FUNC <- stats::predict fname <- "stats::predict" } # Create arg list for predict. # We invoke deprefix directly (and not call.dots) because we have to # specify a DROP argument and also do a bit of other processing. # OBJECT and NEWDATA must be passed as unnamed arguments to predict, # because different predict methods use different arg names for these. # We want to allow the user to pass normal (unprefixed) dots argument to # predict. So here we use KEEP=NULL but drop any plot arguments, and # any prefixed dot arguments that are necessary elsewhere in plotmo. # We can't specify a FUNC argument to deprefix because we don't # know which specific predict.method will be called (a few lines down). args <- deprefix(FUNC=NULL, DROP=paste0("w1. SHOWCALL FORCEPREDICT PLOT.ARGS PAR.ARGS PLOTMO.ARGS"), PREFIX="predict.", FNAME=fname, force.anon1=object, force.anon2=newdata, ...) yhat <- do.call.trace(func=FUNC, args=args, fname=fname, trace=TRACE) if(is.null(yhat) || length(yhat) == 0) stopf("failed call to predict(%s)", list.as.char(args)) yhat # plausibility of yhat will be checked shortly in plotmo_predict } # Like plotmo.predict.default but first convert newdata to a matrix. # Needed because some predict methods require a matrix, not a data.frame. plotmo.predict.defaultm <- function(object, newdata, type, ..., TRACE, FUNC=NULL) { stopifnot(is.data.frame(newdata)) check.df.numeric.or.logical(newdata) # following calls predict.xxx where xxx is the class of object plotmo.predict.default(object, data.matrix(newdata), type=type, ..., TRACE=TRACE) } plotmo/R/rpart.R0000644000176200001440000000541314663771205013256 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/xgboost.R0000644000176200001440000000037214663771205013612 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/residuals.R0000644000176200001440000002017414663771205014122 0ustar liggesusers# residuals.R: plotmo functions for residuals (the residuals, their scale, and name) # "rinfo" is "residual info" plotmo_rinfo <- function(object, type=NULL, residtype=type, nresponse=1, standardize=FALSE, delever=FALSE, trace=0, leverage.msg="returned as NA", expected.levs=NULL, labels.id=NULL, ...) { trace2(trace, "----plotmo_rinfo: plotmo_resids(object, type=\"%s\", nresponse=%s)\n", type, if(is.na(nresponse)) "NA" else if(is.null(nresponse)) "NULL" else paste(nresponse)) # TODO e.g. earth pclass nresp=1, plotmo_y returns pclass1st 0 or 1 but predict is 1, 2, 3 if(!is.na(pmatch(type, "class"))) { # if(inherits(object, "lda") || inherits(object, "qda")) # stopf( # "plotres does not support type=\"class\" for %s objects\n Note: plotmo extends predict.%s internally:\n%s%s\n", # class.as.char(object, TRUE), # class.as.char(object), # " 'type' can be one of c(\"class\", \"posterior\", \"response\")\n", # " This is discussed in the plotmo vignette.") # else stopf( "plotres does not (yet) support type=\"class\" for %s objects\n Try type=\"response\" ?", class.as.char(object, quotify=TRUE)) } # try calling residuals() directly tracex <- if(trace == 1) 0 else trace # already printed call to residuals in plotmo_meta plotmo_resids <- plotmo_resids(object, type, residtype, nresponse=nresponse, trace=tracex, ...) if(!is.null(plotmo_resids)) { resids <- plotmo_resids$resids labs <- plotmo_resids$labs fitted <- plotmo_fitted(object, trace, nresponse, type, ...)$fitted } else { # trace=2 not 1 because we have already printed this message info in plotmo_meta if(trace >= 2) printf("calling predict() because residuals() was unsuccessful\n") fitted <- plotmo_predict(object, newdata=NULL, nresponse, type, expected.levs, trace, inverse.func=NULL, ...)$yhat labs <- rownames(fitted) check.numeric.scalar(nresponse) # nresponse should be specified by now if(nresponse == 1) plotmo_y <- plotmo_y(object, nresponse, trace, nrow(fitted), object$levels) else { # TODO needed for e.g. rpart and lars where y has one col but predict has multiple cols tracex <- if(trace <= 0) -1 else trace # prevent msg in plotmo_nresponse, see note there plotmo_y <- try(plotmo_y(object, nresponse, tracex, nrow(fitted), object$levels), silent=trace == 0) if(is.try.err(plotmo_y)) { trace1(trace, "the call to plotmo_y was unsuccessful with nresponse=%g, trying again with nresponse=1\n", nresponse) nresponse <- 1 plotmo_y <- plotmo_y(object, nresponse, trace, nrow(fitted), object$levels) trace1(trace, "plotmo_y is ok with nresponse forced to 1\n") } } y <- plotmo_y$y resids <- y - fitted colnames(resids) <- "resids" # TODO following will sometimes give the wrong results? if(!is.null(nresponse) && nresponse > NCOL(resids)) { if(trace >= 1) printf( "forcing nresponse %g to 1 because response - fitted has one column\n", nresponse) nresponse <- 1 } resids <- process.y(resids, object, type, nresponse, expected.len=nrow(fitted), expected.levs=expected.levs, trace, "residuals")$y trace2(trace, "generated the residuals using plotmo_predict() and plotmo_y()\n") } scale <- get.resid.scale(object, resids, standardize, delever, trace, leverage.msg) trace2(trace, "----plotmo_rinfo: done\n") if(!is.null(labels.id)) # user specified labels.id? labs <- repl(paste(labels.id), length(resids)) # recycle if necessary list(resids = resids, # numeric vector, standardize and delever not applied labs = labs, # resids names, may be NULL fitted = fitted, # predicted values for newdata=NULL and given type scale = scale$scale, # vector of 1s unless standardize or delever set name = scale$name) # "Residual" or "Delevered Residual" etc. } # return NULL if call to residuals failed plotmo_resids <- function(object, type, residtype, nresponse, trace, ...) { stopifnot.string(type) stopifnot.string(residtype) if(inherits(object, "train")) { # Caret train model. Force use of predict to calculate residuals # instead of residuals(), for consistency with plotmo. if(trace >= 2) printf("inherits(object, \"train\"): plotmo_resids returns NULL\n") return(NULL) } resids <- try(call.dots(stats::residuals, DROP="*", KEEP="PREFIX", # following prevents reprint of residuals msg if fail TRACE=if(trace == 0) -1 else trace, force.object=object, force.type=residtype, ...), silent=trace <= 1) # is.null check is for residuals(glmnet) which silently returns NULL if(is.try.err(resids) || is.null(resids)) return(NULL) if(trace >= 2) print_summary(resids, "residuals is ", details=if(trace>=2) 2 else -1) list(resids = process.y(resids, object, type, nresponse, expected.len=NULL, expected.levs=NULL, trace, "residuals")$y, labs=if(!is.null(names(resids))) names(resids) else rownames(resids)) } get.resid.scale <- function(object, resids, standardize, delever, trace, leverage.msg) { scale <- repl(1, length(resids)) name <- "Residual" standardize <- check.boolean(standardize) if(standardize) { scale <- plotmo_standardizescale(object) name <- "Standardized Residual" } delever <- check.boolean(delever) if(delever) { if(standardize) # don't allow double denormalization stop0("the standardize and delever arguments cannot both be set") hatvalues <- hatvalues1(object, "'delever'") hat1 <- which(hatvalues == 1) if(trace >= 0 && length(hat1) > 0) warnf("response[%s] has a leverage of one and will be %s", paste.c(hat1), leverage.msg) scale <- 1 / sqrt(1 - hatvalues) name <- "Delevered Residual" } # leverages of 1 cause an inf scale, change to NA for easier handling later scale[is.infinite(scale)] <- NA check.vec(scale, "scale", length(resids), na.ok=TRUE) check(scale, "scale", "non-positive value", function(x) { x <= 0 }, na.ok=TRUE) list(scale = scale, name = name) } # scale for standardization, inf if leverage is 1 plotmo_standardizescale <- function(object) { if(inherits(object, "earth")) { if(is.null(object$varmod)) stop0("\"standardize\" is not allowed because\n", "the model was not built with varmod.method") se <- predict(object, type="earth", interval="se") } else if(inherits(object, "rlm")) se <- object$s else if(inherits(object, "glm")) se <- sqrt(summary(object)$dispersion) else if(inherits(object, "lm")) se <- sqrt(deviance(object) / df.residual(object)) else stop0("'standardize' is not yet supported for this object") stopifnot(is.numeric(se)) stopifnot(all(!is.na(se)), all(se > 0)) 1 / (se * sqrt(1 - hatvalues1(object, "'standardize'"))) } hatvalues1 <- function(object, argname) # try hatvalues, specific err msg if fails { hatvalues <- try(hatvalues(object)) if(is.try.err(hatvalues)) stop0(argname, " is not supported for this object ", "(the call to hatvalues failed)") hatvalues } plotmo/R/printcall.R0000644000176200001440000001323714663771205014121 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/plotqq.R0000644000176200001440000001317414663771205013451 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/plotcum.R0000644000176200001440000001153214663771205013610 0ustar liggesusers# plotcum.R plotmo_cum <- function(rinfo, info, nfigs=1, add=FALSE, cum.col1, grid.col, jitter=0, cum.grid="percentages", ...) { trans.resids <- abs(rinfo$scale * rinfo$resids) # TODO what happens here if NA in trans.resids (leverage==1) ecdf <- ecdf(trans.resids[,1]) xlab <- rinfo$name xlab <- sprint("abs(%ss)", xlab) cum.grid <- match.choices(cum.grid, c("none", "grid", "percentages")) annotation.cex <- .7 * dota("cum.cex", DEF=1, ...) if(!add && info && cum.grid == "percentages") { # ensure right margin big enough for right hand labels old.mar <- par("mar") if(old.mar[4] < 3.5) { on.exit(par(mar=old.mar)) par(mar=c(old.mar[1:3], annotation.cex * 5)) } } if(is.na(cum.col1)) cum.col1 <- dota("cum.col", DEF=1, ...) cum.col1 <- cum.col1[1] # no recycling # user can set xlim and ylim if this is the only figure xlim <- dota("xlim", DEF=NULL, ...) if(nfigs > 1 || !is.specified(xlim)) xlim <- range(abs(rinfo$scale * rinfo$resids), na.rm=TRUE) xlim <- fix.lim(xlim) ylim <- dota("ylim", DEF=NULL, ...) if(nfigs > 1 || !is.specified(ylim)) ylim <- c(ylim=if(info) -.1 else 0, ymax=if(cum.grid == "percentages") 1 + annotation.cex * .06 else 1) ylim <- fix.lim(ylim) call.plot(stats::plot.stepfun, PREFIX="cum.", drop.cum.grid=1, force.x = ecdf, force.add = add, force.main = dota("main", DEF="Cumulative Distribution", ...), force.xlim = xlim, force.ylim = ylim, force.xlab = xlab, force.ylab = "Proportion", force.col.points = NA, # finer resol graph (points are big regardless of pch) force.col = cum.col1, force.col.hor = cum.col1, force.col.vert = cum.col1, ...) if(!add) { if(info) draw.density.along.the.bottom(abs(trans.resids), ...) if(cum.grid %in% c("grid", "percentages")) { linecol <- if(is.specified(grid.col)) grid.col else "lightgray" # add annotated grid lines, unattractive but useful for(h in c(0,.25,.5,.75,.90,.95,1)) # horizontal lines abline(h=h, lty=1, col=linecol) probs <- c(0, .25, .50, .75, .9, .95, 1) q <- quantile(trans.resids, probs=probs, names=FALSE) for(v in q) # vertical lines at 0,25,50,75,90,95,100% quantiles abline(v=v, lty=1, col=linecol) box() # abline overwrite the box, so restore it if(cum.grid == "percentages") { draw.percents.on.top(probs, q, annotation.cex) if(info) draw.quantiles.on.right.side(probs, q, annotation.cex) } # replot data over grid call.plot(stats::plot.stepfun, PREFIX="cum.", drop.cum.grid=1, force.x = ecdf, force.add = TRUE, force.xlim = xlim, force.col.points = NA, force.col = cum.col1, force.col.hor = cum.col1, force.col.vert = cum.col1, ...) } } } # Adding percents and quantiles on the wrong axes is considered a no no, # but here we are more-or-less forced into it because the percentile text # can be too long to display on the "correct" axis. draw.percents.on.top <- function(probs, q, annotation.cex) { is.space.available <- function(i) # is horizontal space available { q[i] - q[i-1] > 1.2 * strwidth && q[i+1] - q[i] > 1.2 * strwidth } draw.percent <- function(i, label) { # xpd=NA to allow text out of plot region (usually not needed) x <- q[i] if(i == 1) x <- x + .05 * strwidth # so 0% doesn't overwrite box else if(i == 7) x <- x - .3 * strwidth # so 100% doesn't overwrite box text.on.white(x=x, y=1.05, label, annotation.cex, xmar=0, xpd=NA) } #--- draw.percents starts here --- strwidth <- strwidth("25%", cex=annotation.cex) draw.percent(1, "0%") if(is.space.available(2)) draw.percent(2, "25%") draw.percent(3, "50%") if(is.space.available(4)) draw.percent(4, "75%") draw.percent(5, "90%") if(is.space.available(6)) draw.percent(6, "95%") draw.percent(7, "100%") } draw.quantiles.on.right.side <- function(probs, q, annotation.cex) { y <- spread.labs(x=probs, mindiff=1.2 * annotation.cex * strheight("A"), min=-.1) q[q < max(q) / 1e4] <- 0 # prevent labels like 2.22e-16 text(1.01 * par("usr")[2], y, sprint("%.3g", q), xpd=TRUE, cex=annotation.cex, adj=0) } plotmo/R/quantreg.R0000644000176200001440000000572614663771205013763 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/NAMESPACE0000644000176200001440000001125214567064051013014 0ustar liggesusersimportFrom(plotrix, thigmophobe.labels) importFrom(Formula, Formula) export(plotmo) export(plotres) export(plot_gbm) export(plot_glmnet) # by convention, the prefix "plotmo_" is for # standard functions and "plotmo." is for methods # (but check.index is a historical name) export(check.index) export(plotmo.convert.na.nresponse) export(plotmo.pairs) export(plotmo.pint) export(plotmo.predict) export(plotmo.prolog) export(plotmo.residtype) export(plotmo.singles) export(plotmo.type) export(plotmo.x) export(plotmo.y) export(plotmo.y.default) export(plotmo_cum) export(plotmo_fitted) export(plotmo_nresponse) export(plotmo_predict) export(plotmo_prolog) export(plotmo_resplevs) export(plotmo_response) export(plotmo_rinfo) export(plotmo_rsq) export(plotmo_standardizescale) export(plotmo_type) export(plotmo_y) S3method(plotmo.convert.na.nresponse, default) S3method(plotmo.convert.na.nresponse, rq) S3method(plotmo.convert.na.nresponse, rqs) S3method(plotmo.pairs, C5.0) S3method(plotmo.pairs, default) S3method(plotmo.pairs, gbm) S3method(plotmo.pairs, GBMFit) S3method(plotmo.pairs, gpe) S3method(plotmo.pairs, parties) S3method(plotmo.pairs, party_plotmo) S3method(plotmo.pairs, pre) S3method(plotmo.pairs, randomForest) S3method(plotmo.pairs, rpart) S3method(plotmo.pairs, train) S3method(plotmo.pairs, WrappedModel) S3method(plotmo.pint, default) S3method(plotmo.pint, earth) S3method(plotmo.pint, Gam) S3method(plotmo.pint, gam) S3method(plotmo.pint, glm) S3method(plotmo.pint, lm) S3method(plotmo.pint, quantregForest) S3method(plotmo.pint, rq) S3method(plotmo.pint, rqs) S3method(plotmo.predict, bagging) S3method(plotmo.predict, biglm) S3method(plotmo.predict, boosting) S3method(plotmo.predict, bruto) S3method(plotmo.predict, clm) S3method(plotmo.predict, cosso) S3method(plotmo.predict, cv.glmnet) S3method(plotmo.predict, default) S3method(plotmo.predict, defaultm) S3method(plotmo.predict, gbm) S3method(plotmo.predict, GBMFit) S3method(plotmo.predict, glmnet) S3method(plotmo.predict, glmnet.formula) S3method(plotmo.predict, lars) S3method(plotmo.predict, lda) S3method(plotmo.predict, list) S3method(plotmo.predict, mvr) S3method(plotmo.predict, nn) S3method(plotmo.predict, party_plotmo) S3method(plotmo.predict, qda) S3method(plotmo.predict, quantregForest) S3method(plotmo.predict, rpart) S3method(plotmo.predict, rq) S3method(plotmo.predict, rqs) S3method(plotmo.predict, svm) S3method(plotmo.predict, WrappedModel) S3method(plotmo.prolog, C5.0) S3method(plotmo.prolog, cv.glmnet) S3method(plotmo.prolog, default) S3method(plotmo.prolog, gbm) S3method(plotmo.prolog, GBMFit) S3method(plotmo.prolog, glmnet) S3method(plotmo.prolog, model_fit) S3method(plotmo.prolog, parties) S3method(plotmo.prolog, party) S3method(plotmo.prolog, pre) S3method(plotmo.prolog, train) S3method(plotmo.prolog, WrappedModel) S3method(plotmo.prolog, xgb.Booster) S3method(plotmo.residtype, default) S3method(plotmo.residtype, rpart) S3method(plotmo.residtype, train) S3method(plotmo.singles, C5.0) S3method(plotmo.singles, cv.glmnet) S3method(plotmo.singles, default) S3method(plotmo.singles, gbm) S3method(plotmo.singles, GBMFit) S3method(plotmo.singles, glmnet) S3method(plotmo.singles, parties) S3method(plotmo.singles, party_plotmo) S3method(plotmo.singles, pre) S3method(plotmo.singles, randomForest) S3method(plotmo.singles, rpart) S3method(plotmo.singles, train) S3method(plotmo.singles, WrappedModel) S3method(plotmo.type, bruto) S3method(plotmo.type, clm) S3method(plotmo.type, cosso) S3method(plotmo.type, default) S3method(plotmo.type, fda) S3method(plotmo.type, knn3) S3method(plotmo.type, lars) S3method(plotmo.type, lda) S3method(plotmo.type, nnet) S3method(plotmo.type, qda) S3method(plotmo.type, rpart) S3method(plotmo.type, train) S3method(plotmo.type, tree) S3method(plotmo.type, varmod) S3method(plotmo.x, default) S3method(plotmo.x, gbm) S3method(plotmo.x, GBMFit) S3method(plotmo.x, mars) S3method(plotmo.x, varmod) S3method(plotmo.y, default) S3method(plotmo.y, gbm) S3method(plotmo.y, GBMFit) S3method(plotmo.y, lognet) S3method(plotmo.y, mrelnet) S3method(plotmo.y, multnet) S3method(plotmo.y, varmod) importFrom("grDevices", "as.graphicsAnnot", "col2rgb", "gray", "xy.coords") importFrom("graphics", "abline", "axis", "box", "grid", "image", "legend", "lines", "mtext", "par", "plot", "points", "polygon", "rect", "segments", "strheight", "strwidth", "text", "xinch", "yinch") importFrom("stats", "approx", "coef", "cor.test", "density", "deviance", "df.residual", "formula", "getCall", "hatvalues", "loess", "lowess", "median", "model.matrix", "na.omit", "na.pass", "pnorm", "predict", "qqline", "qqnorm", "quantile", "rnorm", "sd", "update", "weighted.mean") importFrom("utils", "assignInMyNamespace", "head", "str") plotmo/NEWS.md0000644000176200001440000004166114664455127012710 0ustar liggesusersChanges to the plotmo package ----------------------------- ## 3.6.4 Aug 29, 2024 Updates for R version 4.4.1 Fixed an issue with gbm3 version 3.0. Thanks to Marcia Barbosa for help on this. ## 3.6.3 Feb 16, 2024 Updates for R version 4.3.2. For example, had to change "sort.unique" to "sort_unique". Removed dependency on possibly orphaned package TeachingDemos. ## 3.6.2 May 21, 2022 Minor updates for R version 4.2.0. ## 3.6.1 Jun 2, 2021 Minor updates for R version 4.1.0. These updates quieten some warnings from sprintf when plotmo's trace flag is set. Also updated some of the test scripts. ## 3.6.0 Sep 12, 2020 We now have better support for models with unusual variable names. For example, variable names with spaces in them, and formula terms like "as.numeric(x1)". This required a fairly large change to the handling of formulas. We now support models like "earth(formula, data=func(data))", where the data argument is a function call. Minor code change because base::range no longer seems to work with Date objects. Better support for residuals plots for earth-glm models. Support for the "ordinal" package ("clm" models). Basic support for "parsnip" models. Minor documentation updates. Updated the libraries shared with the earth and plotmo packages. Extended the test scripts and updated them for R version 4.0.2. ## 3.5.7 Apr 15, 2020 Added new dot arguments "prednames.abbreviate" and "prednames.minlength". o Use prednames.abbreviate=FALSE for full predictor names in graph axes. (The default is prednames.abbreviate=TRUE.) o The "prednames.minlength" argument is passed on internally to base::abbreviate(). Reinstated the tests for the emma package (were removed before because emma gave the message "package 'clusterSim' could not be loaded"). ## 3.5.6 Oct 26, 2019 The family of a model can now be a string (as well as a "family" object). This allows better support of glmnet objects. ## 3.5.5 June 27, 2019 S4 models wrapped in caret models are now supported e.g. train method="svmRadial" (which creates a kernlab ksvm model). Modifications for glmnet models: The glmnet residuals plot now includes the predict arg "s" in the plot title. The default ylim for glmnet probability models is now c(0,1). For glmnet cv models: we now pass the predict.s argument to plotmo and plotres, and plotmo now by default plots a maximum of 25 coefs (the largest coefs). Updated test scripts for the new random number generator that came with R version 3.6.0. ## 3.5.4 Apr 6, 2019 Added a reminder to use keepxy=2 for earth if you want to use plot.earth or plotmo on an earth cross-validation submodel. Plotmo now requires R version at least 3.4.0. Minor updates to libraries shared with earth and rpart.plot. ## 3.5.3 March 16, 2019 Extended plotmo to support earth version 5.0.0, which allows multiple responses using the Formula package. Plotmo now also has partial support for other models also created using Formula (as well as those that use formula). Added "Depends: Formula" to the DESCRIPTION. Binomial pair responses are now more uniformly converted to a "fraction true" before plotting. If nresponse is not specified for multiple response models, plotmo now defaults to nresponse=1 with a warning (whereas previous versions of plotmo issued an error message). Updates to the libraries shared with earth. ## 3.5.2 Jan 2, 2019 Improved support for models specified with a formula containing an offset term. The grid.levels argument can now be used with pmethod="partdep". ## 3.5.1 Nov 23, 2018 Can now plot multinomial models from the "pre" package. Tweaked linmod.R to better handle models with all-zero residuals, and updated the documentation. Minor changes to internal function calls to prevent warnings when options(warnPartialMatchArgs=TRUE). Added "LazyData: yes" to the DESCRIPTION file. ## 3.5.0 Aug 19, 2018 The default pegged value of background variables has changed in this version, but only for logical and factor variables. For these variables the value occurring most often in the training data is used as the background value. (In previous plotmo versions, the first level of factors was used. But the majority level seems more consistent with the median used for numerics. Also, in previous versions logicals and integers were sometimes incorrectly converted to numeric.) Note this change doesn't affect pmethod="partdep" and "apartdep", which continue to behave as in previous versions. We now support base::Date variables. Plotmo now has better support for caret rpart models with factor predictors. ## 3.4.2 July 3, 2018 Added support for the partykit and evtree packages. Thanks to Achim Zeilis for his help. Plotmo is now more intelligent about maximizing the number of degree2 plots in the 4x4 grid. Minor updates to linmod.R and linmod.methods.R. ## 3.4.1 June 8, 2018 If plotting a probability and pt.col is specified, we now scale the response range to 0...1 so the points are displayed on the probability scale. Expanded is.predict.prob() function for more models. Fixed a minor bug in pmethod="partdep" which sometimes incorrectly caused an error message under certain conditions when there is only one predictor (added a missing drop=FALSE). Enhanced support for the mlr package (but we can't support mlr objects properly until the call is saved with WrappedModels). Enhanced support for the caret package (we now use get.singles and get.pairs on the submodel). ## 3.4.0 May 31, 2018 If predict.rpart is predicting a probability, plotmo now recognizes that and sets ylim=c(0,1) appropriately. Plotting of intercept-only models was slightly inconsistent. Fixed that. We now attempt to better set the default nticks in persp plots. We now position the labels in persp plots slightly better along the axes (they were sometimes too far away from the front corner). When degree2 is exactly two strings, we now assign the x1 and x2 axes in the order specified in degree2 (although persp plots still get rotated for optimum visibility of the surface, and this rotation can reverse the order of the axes). Added basic support for the mlr package (see test.mlr.R). Documentation updates, especially to modguide.pdf and linmod.R. ## 3.3.7 May 15, 2018 Added a README file. If degree2 is exactly two strings, plotmo now prints just that degree2 plot e.g. degree2=c("wind", "humidity"). We plot the variable pair even that pair isn't used in the model (because we implicitly set all2=TRUE if degree2 is two strings). If degree1 is of type character, we now plot the variable even if it isn't used in the model (because we implicitly set all1=TRUE if degree1 is is of type character). For the qq plot in plotres, changed the diagonal qq line to dotted black. This gives more compatibility with plot.lm, and also means that the legend for the density subplot along the bottom of the qq plot (with info=TRUE) isn't mistakenly assumed to apply to the main plot. For the old behavior use qqline.col="gray", qqline.lty=1. Added basic support for the "pre" package (using the importance function in that package). Fixed minor bug: the plotmo grid wasn't printed if ylim was specified by the user. The vignettes are now compressed with gs and qpdf as in tools::compactPDF, (but that happens outside the standard CRAN build system). It does mean that the tar.gz file for plotmo is a little smaller (now 1155 kByte). ## 3.3.6 Mar 20, 2018 Minor documentation updates. ## 3.3.5 Feb 26, 2018 Added support for package gam version 1.15 and higher (the S3 class of gam objects changed from "gam" to "Gam" to prevent clashes with the mgcv package). Plotmo now works with both the old and new versions of gam. ## 3.3.4 July 26, 2017 Added support for glmnetUtils objects. ## 3.3.3 May 4, 2017 Error "glmnet.formula must be called with use.model.frame=TRUE" is now issued when necessary. Tweaked test scripts because cosso models fail with R version 3.4.0. ## 3.3.2 Dec 2, 2016 Support for the C50 package. Better handling of NA and 0 colors in plot_glmnet. Better messages to the user for models with too many variables to fit on a page. With all2=2, plotmo will now plot up to a maximum of all pairs of 20 variables (and as always, with all2=TRUE plotmo will plot a maximum of all pairs of 7 variables). ## 3.3.1 Nov 24, 2016 When choosing which variables to plot for randomForest models, variable importance is now calculated using a more correct measure, viz. one of IncMSE or IncNodePurity (regression models), or MeanDecreaseAccuracy or MeanDecreaseGini (classifications models). The second option is used if importance=TRUE was used when building the model. Use trace=1 when calling plotmo to see which measure of importance is used. The plot_gbm function now displays the gray vertical line at the correct position when n.trees is specified. Documentation touchups. ## 3.3.0 Nov 11, 2016 Added support for partial dependence plots (the pmethod argument). Extended the vignette with new chapters on partial dependence plots and classification models. Plotmo's nrug argument now supports quantiles. The title on persp plots is now better aligned to the degree plot titles. The margins for persp plots are now more optimal (they now give bigger plots when do.par=FALSE and there are also degree1 plots). Added support for e1071::predict.svm decision.values and probability arguments. Fixed error message when plot_gbm was used on multinomial models. Fixed warnings in plot_gbm when gbm.ntrees is very small (less than 10). ## 3.2.1 Oct 27, 2016 Added support for gbm package version 2.2. See gbm.backcompat.R. Extended linmod.R: support for no-intercept models, support for 'keep' argument, better handling of newdata in predict.linmod. Also extended the tests for linmod.R in inst/slowtests. ## 3.2.0 Sep 7, 2016 The functions plot_gbm and plot_glmnet are now exported and available for the user. These functions have been enhanced for this version. Improved support for gbm and glmnet and related models. The plotres function now works better with caret "train" models (but caret support is still a bit minimal). We now print "plotmo grid:" instead of just "grid:" for context when it's printed from within a body of code. Removed deprecated interface functions like get.plotmo.pairs. Updated dot library functions for eventual move to a dots package. Revamped the vignettes. ## 3.1.5 Aug 26, 2016 The pt.cex argument now works correctly in plotres QQ plots. Changed default colors in plot.glmnetx. The colors stay in the order they are passed to plot.glmnetx as we move down the rhs of the plot. Extended test suite to include adabag package. Fixed code in meta.R which assumed all.equal() always returned TRUE or FALSE. Merged the library source file lib.R with the earth and rpart.plot packages's lib.R. Updated and extended vignettes. ## 3.1.4 Jul 29, 2015 Added support for the adabag package. Added imports for standard grDevices, stats, and utils functions, as now required by CRAN check. Documentation updates. Thanks to Achim Zeileis for his feedback. ## 3.1.3 Jun 24, 2015 Added plotmo.prolog.cv.glmnet (to handle missing "call" in cv.glmnet objects). More work on the issue where vars on the rhs of formula are multidimensional. Documentation updates. ## 3.1.2 Jun 15, 2015 Added the new vignette "Guidelines for S3 Regression Models". Documentation touchups. ## 3.1.1 May 27, 2015 Removed references needed for old versions of earth. Fixed a gbm column naming issue. Other minor code and document updates. ## 3.1.0 May 6, 2015 Removed references to functions in old versions of earth. Simplified the way xlim and ylim are calculated internally. Simplified the way jitter is handled. If type="probability" or similar, and the response has two columns, nresponse now automatically defaults to column 2. Added support for biglm objects. The predict.biglm method (unnecessarily) requires that newdata has a response column, so plotmo adds a dummy response column before calling predict.biglm. We now find the data argument for formula models even if the argument is unnamed. ## 3.0.0 Apr 29, 2015 Added the plotres function. Reworked the internal functions that get the data from the model. Reparameterized the argument list of plotmo, but maintained backwards compatibility using the "dots" routines. ## 2.2.1 Jan 7, 2015 If pch.response has type character, we now plot the response points as text. Earth models with no degree1 terms but with degree2 terms were incorrectly labelled as intercept-only models. Fixed that. Changes to match changes to earth's predict.varmod interval argument. ## 2.2.0 Dec 10, 2014 Fixed incorrect printing of some messages when trace=-1. Expansions to check.index for earth. Documentation touchups. ## 2.1.0 Nov 30, 2014 Added a vignette "Notes on the plotmo package". Some more functions are now exported to allow earth::plotmor to easily get the model data Some documentation touchups as usual. ## 2.0.0 Nov 19, 2014 Plotting of prediction or confidence levels is now more comprehensive. We now allow both prediction and confidence intervals to be plotted for those predict methods that support it on new data (currently only lm). The "se" argument is now deprecated and superseded by the "limit" argument (you will get a warning). Plotmo will now plot the model even if it is an intercept-only model. Use int.only.ok=FALSE for the old behaviour (i.e., issue an error for intercept-only models). The "grid:" message in now printed for only multiple predictor models. Remember that you can always suppress this message in any case with trace=-1. The xlim argument is now supported. Typically only useful if only one degree1 plot. Plotmo now supports quantreg and quantregForest objects. Basic support for the AMORE package has been provided. Thanks to Bernard Nolan and David Lorenz for this. But this has been commented out in the source code to avoid having "suggests(AMORE)" in the plotmo DESCRIPTION file. To use functions, search for AMORE in the plotmo source code, and cut and paste the commented-out code into your environmemt. The default pch.response is now 20 (was 1). The default cex.response is now NULL (meaning automatic, was 1). Minor other changes to fix formatting of captions etc. ## 1.3-3 Feb 4, 2014 Clerical changes to satisfy recent CRAN check requirements. ## 1.3-2 Dec 1, 2011 You can now use trace=-1 to inhibit the "grid: " message. Removed a call to .Internal(persp) ## 1.3-1 Sep 16, 2011 Fixed an minor incorrect message introduced in the previous release. ## 1.3-0 Sep 15, 2011 You can now specify variables by name in degree1 and degree2. Suppressed annoying "Warning: surface extends beyond the box". We no longer issue an incorrect err msg if data frame has an "AsIs" field. ## 1.2-6 Removed an incorrect stopifnot.integer(y.column) in plotmo_y.wrapper ## 1.2-5 Jun 11, 2011 Fixed an incorrect stop when trace>0 and x had no column names. We no longer print the plot index in the plot title when all1 or all2 specified but also degree1 and degree2. Added get.plotmo.default.type.fda Touchups to the documentation. ## 1.2-4 Apr 27, 2011 Removed hooks for the earth package (which are no longer necessary with earth 2.6-2). The file plotmo.methods.R was deleted. Added the grid argument. ## 1.2-3 Apr 17, 2011 This package no longer needs the earth package. However the current earth (2.6-1) needs some hooks in this package to build. After earth 2.6-2 is on CRAN that will no longer be necessary, and the hooks will be removed from this package. We now have better error reporting for bad y's. We now have better jittering of response points with a binary response. ## 1.2-0 Apr 12, 2011 Added ndiscrete arg (variables with a small number of levels are now plotted as "blocks", like factors). Added smooth.col and related args (plotmo can add a loess line). Made tweaks necessary because earth now imports this package. Added dvalue and npoints args. Added center arg (preliminary implementation). Added basic support for lars, nnet, and knn3 models. Jittering now works better. We now jitter response points for factors and discrete variables by default. plotmo is now faster: We cache the plot data to avoid calling predict twice for each plot For discrete vars and factors we only call predict for their original values ngrid1 is much smaller (ok to do that because of ndiscrete arg) Better error reporting for illegal args. Reduced the number of default colors (just grays and lightblue now). Out-of-range values in image plots are now plotted in blue. Fixed an issue where the wrong environment could be used. Better error reporting for unsupported models. Fixed handling of factors with non contiguous levels Modified test scripts to conform to R 2.13.0's way of printing numbers Numerous other document and code touch ups. ## 1.0-1 Apr 01, 2011 plotmo was printing degree1 graphs for all used earth predictors, not just those appearing in degree1 terms. Fixed that. plotmo was not handling all1=TRUE correctly for earth models with factor predictors. Fixed that. ## 1.0-0 Mar 31, 2011 Initial release. Moved plotmo from earth 2.5-1 to here. plotmo/inst/0000755000176200001440000000000014334575431012552 5ustar liggesusersplotmo/inst/doc/0000755000176200001440000000000014334575431013317 5ustar liggesusersplotmo/inst/doc/plotmo-notes.pdf0000644000176200001440000316043714664222304016462 0ustar liggesusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 4963 /Filter /FlateDecode /N 89 /First 750 >> stream x\[sƒ~_S[>SS%[ز89$߯g$HH{$}Rt&LflCe3iB&)2SZJtTx&q.E&UJg33EW2mmEˌ8c~Ȭp̬%2͔̬2=љ-_I2e3sϔϼx?d^h/iHb5P' I\ɬ%Θ|VWf -4 54{MR,2I`i8@YJ dh" *1D遼d%Utpd-KPhd@j ', (G ȆqgM VbVz:,d0d`5dӒjL4-{<dGLcBJ*h $% %c2`XIAB`A.p 9xPs8/e)0:i YqZ{޼eŻUwQfeBݜgIfr 6nxPw4Ჺj!;}?p|ER>Ngg׽)ٞ8IT-ș8 +hkZeliZAG}茞Nu:Ro :Y]_>2 i]HBR3䡲`_hJ0$چ='Y U}ŭ0}0:M݂1І> $OnT)Oix^T,^śm8/h2ߛ^1("+.!~T%* (j\ Ũ)x8I1xyT]4BNşwՌT-.&jp15ޥi1+f5~+zZU뤸+_o_T 4%+HG\ȐOkmpHOpTiȨfI7jCf^ +(Zt8A"u./"4!FG^ocCBz7 0dzRVwRnȪ(*F5<o5g-m)ZG[F#Uy=I"I2Rdd7hPDbrz1?W(8|eWFQ[e(ţj6[梚ΆWNR};.ĸ)zn. 7.pSvdjf]vͺIӺ5fUIdx 2T W/|58$w>A܀{/_B4@Ax~P c7b6U > nQdy16m>o5 n78(I_R]sz l\ +6ׯ)!wC`FQ`|a6)Х*t5eI”DFr`!tRv5gjǓ9Lv!/C/Y<ɞtf88Ȳ9r|H>+>G 8:7O[?<u` w"#4 b3 `30] /)D4(D<(!7t]OR `!Y\ISp 4iGzїΞnaPVӷ*,L%b~NYҹ~FHЙIK3E%r8ʋ=\j > =F{(7rqlS3-jt }Oq9ǧ),| >^AinwuZִG}m:-G*\iϏHYPhRGOv\Mfzљ6h>mK~g{66{- G`Zw)L(9iP!M[V44 L:CK>Ԩ-GHQWeCDdˊJ{VC[bn)syWx|7 6l(Hn*YmUl\[WU}Ul`[X&VUlexYg?OT9cxlZ@.r 1r҅c|v٥SzJ^O)y=7J9])kSzJ^O)y=%SzJ^O)} ,yҒg-}OwH\?88)tM|IO0'9.iƾ[ ۱P+Z|e-Vm=)H )r6U8~ ?LYs ޔ#&Wwdmʋ)6:Whӕ+~m [op޷կ7};7<ĔX^kϚ~|@Zo]Vi&>ka^Vx.[R[w%ԩxcsaU `= ?iWaէl!Wߵ;"\XN+/X9:Jnaƞ-EWnP.BՍTPM5 qy ͍>\tS=oQ_~oI>^I淃˿GUxk8ک  WQaYIDŎ0BdIs }zW22+\k*m@%'k2TJie ty6Ro\j(>^7M!/h2V#мR αAT$#%ۑAa!>ufmζK$厶dJ9|h:;U01@w&n<ʰ7+ʜRMjRѲ$uhYPmn(OB:,Y~s6}MȔ8̀/ ΃޸yr1bS~4LPmJd؎{"#K-_"A0C@RS!mUH.fs b[TT8V-fm[6n6?.7wvW1Yc ŶXUomlqcZn+>b xo~崭'DNZRVoB{r9uQ֨D#,spBޝkħ`N7ͺɬ~M־kҎvCJ KDL[V[Ej14F-ַsjFf՛oR޿`47,je+GI it9gJ֛>_̕\k9Cg )L{l_Kì[灍uܚod2ՎQTzi!rmFEȩY{uPy_Cj+*5\ 5=6&<~Uk|ok[?!@W yGP;%{ҤV6JKþV1F#ΧG .R}<^{_GΎK\j+b+S)J){22Ǝ.7GVf LWwA']E>+# SJQL r]rBV>yM!wCYHS}-1M>h{D Jᷱ-A+QrzT#GTC4J|6=;;~-"~{М[ 1G*z˲~1 ܙ3B;t./h62y!nʸDOFln)a3y˃r]q>`[,q[endstream endobj 91 0 obj << /Subtype /XML /Type /Metadata /Length 1446 >> stream GPL Ghostscript 10.00.0 2024-08-29T18:47:48-07:00 2024-08-29T18:47:48-07:00 LaTeX with hyperref Plotting model surfaces with plotmoStephen Milborrowplotmo endstream endobj 92 0 obj << /Type /ObjStm /Length 2888 /Filter /FlateDecode /N 89 /First 810 >> stream x[[s}c2>\;if;n<3{&H$CRMs].II{Â|2xecR%(W*QlUI*z<*;Q(kLZ<*+ol2nb fGAْtVx'ᤰMVN0E`٫ID?%l kEu|䕸mPۨ$@IIl'uFy+x ]xaZm04OtA(`:tIOV)*~Ĩ2U! S!S"*~0hp#f* 1<~bx$DKDpPw*A.8^q[TJٱqRE:`TCVL]n1T,Ql@~ ,xm0 b3Ek)L^LR}[بj<:XߩtLъ{wdgg/p$M_;oETo ]yZBvu܂P@^RV֒=cHrm> kx GVJUZJ+U%UwT8oa_Æ3-K[q-o7c;DŽ \0Y?g*za%;4AB' ~Foo8t"_6,HiZftAFw߯**$k:\:39\+b>p+t $J.Ym5ahe C!ʎf[ cKQ4hl :[z_񽐝Wz?Z`?]8Kqm">gO022!nd =ǍvBKL]9&%vkS!CEz`^1ӭAAr2vzXVM5N(`3n}x75mhvftc)cgkX+dl ޿|?/߽{toN_Lc@`Co|5["t {%(lI0@%W꺻Dznj6"j2*@> a.u2~=˧HoVŋMwF9UsJƶ%GNs(U +CMs,d:"Wbۀ &br&k݀sN=8Dy)׀"%vY[3N`y"GT 霞}"։2a5-!33l"PCp6FRӷ`~[ w%|2p[zDpeS#O(|537-Odsבǝؤegp y0 a x: LDF+'=a Osy=yGZ> stream x[n}W.twU߂a ]; @Sc1E2*v>Z)sF0lΥt]OUm"eMoP~ .7~Vq?#pe˟ O^Ꞛ}eZG f`$:FM@l>8)bG:F`%69Y[f$jy*CG;7Q CxCf" $J-,>gd"ɏa%AoAFFP5 *j` JA @lA15r!J LRA:u2Ih :tl`ـ PAvk O.=7(E:yv^Ǵ&!!I@:zw.#䭀AB"9h*߅-@ K66b-8 k !%o@DHVmX wf?{B#CkN{!!{X-X⤝ a)E:05o]ނIȶ8;as#KS$Rӽ#mj&Q3Y~#w&:wM:a;5RI զKy?(4+ 0*+KPko)[8i5?ݱ*Vu. :=jGN$!F 1 ?6wR|'HMt =9Dm$Cƃi38 ,BGp+&?{9ñ4CJaik?^pZڶ>fOP 0(: ۈ-mɲO]9ǫ|jKU}QLz.j1us׍^\n ԔBbWֻl:9p;]eaS)@ypCO H&Zdmz\vLD%޵'> vwwyX7`=[vGM]b{o^ًWρl<̮Tz2;5&fzY29^N7: щhöJYruGbnݩK͐hK=nO:IK?Tjc12VgUlz7?m$o&qn-~_j4OgW#ʊ.V |gwU,QGm5lu$}/#$;j;(5Jjj4?GZ7տoT,Q5X. ?YhzrY/e='̚j2Ý{8tsr۔y3ZfО-}#=5B :ك3_L>|?(=_T*4FuTh^Sn?(;".Ԡ475InŢ${;GEtj %2F#E*W;{ꞁkg[}Y{qGk{CjVL6[ coցJ۠5[&C]X5l[l.IUaByYnYgwME ?M@[$GHߜ|2^l:kò'dӣwypendstream endobj 272 0 obj << /Filter /FlateDecode /Length 15820 >> stream x}[lm0]8a$~R%u29j$^>E߿}n}Oƿ~~/ܽo_~Iw⽕v+ߛK/~???^>7{v'<޾|~}_>dn?^ΕR;-n? oHk-?|͗_1s!&|7s<?-Ro9R m>IF%~ /d?I-EW=҈!vORxJ .{(ױ"fҮߚOfq[_~OﱤwW-c{KC{>7` L !3SF &)лREﲅbqkIو|#0lz=Lqd \ *DYl1i]jy+c1`'[,bH1\) Ϗ0zoBHx \B4!a!ϣ KӋzUph| 45< Fl"/*]Ůic o!9!ct67G9R14ldJ~ ΋$v aVLng"9NNqQdP 4dwv!@N޻ j4z ,LIbwhABGlv)Y k|LH2~W0 4ߙ,00m'Ed&Xe89=YawEkpzӥ A'm gF+b@T v .c6hJԘ$-HzhbTv &6W}2 %.bVMbeV[=s@ýf@J W-Ӱ6e3 LE WdA21p7=P+(gE; 1D-'3p&gܸBޛJ &ĭ,8.ۻ'!Y 1Z ¼LuI,c];gcw%d O2xGӣ YO9q$!鱿;#TpeovmjqcἽ%LM,0e4[$&qX@pUęMI7FL,(FdC3WLV< qW?7eu\JhqMD6N%L)8ԍd ҭR!mhT) f 2]&11CMZ2d{" Lrq Zhr hszM,Hp/Kwdц^g Jx#}u\L Cc}+Jt ^ŋ&TK2Im)֠mݳ;ζ0;Sz7,ِЏ&8599Gxdg4` n?0d:tL?+)cd‘ed愻NMgrq#ƌ!9b78J]HgI6vt8csZ M |hVkrNV (W놨 R~tɓE9䣚'9n&™Yq`ɝΫn< 0Iδ)s<:nDKH; Ry 0{:C:#Zd1W86$*W=* ⺡͕}0_M RP #Cq{:*%VFI6,Tk"\rm `u h mp#p]YIWeg7E1qwCBI T:RڔV0Yá)DQZhrm"|ua7)GZ0)asYz# }E ; F]A*3@Q,/RIvGEkЂ'~k[SwH]FE޲|ּ<~i~=kS>[ S[Vo]Z> ߺ gqY`4 ăP.b=<>?FTB@*`g/N\?oXdUU{<0VbeHZ[scr.aT8"hIɶJv1 ~Qvf;1L(P]DA.0|_̪}`ol&X`Mv S9dfОDž\jb'f]@(Jɮ} I (ծ}`"Եf?0)ͮc6w5 Q7( ~zٓI@,BMl^rˈdaͅF%cC"k ȰUfkKѬ (X!C I|*aWD)Fٓh'ծ V1 Ȇ;P]k xk \FVye vc5Ā-epg}6l J0k{q v5]@"6 …]@g@0,ίZg P3hud7g0)|:"tٲV?FXu䀀vŕ^:)='ෛUQxxVcL;>eT`JlB=nrhBgaZ&ndZƒΜU AWծ`dB |!<}ު W8ި G}l ^ 򾜍#^ oٮ`)5[2tCQa}i. )dEO.LϮ v,&_LYA8eg&ڪ |8B6ѤBL& F٬C (e,v-l-hB`A*\r G K uJ 6IA\uLmxXr%`L:2.RUXuւYA Y;= YA۱6@Rk B.V!,s XNc:"˗exlb"٪ 8L~j@UAH RcAP `A#qb0>2J'"TmA vI=;nA[|Ѯ`/X5gV iwo>oZJpZY@\D%3sg>cR }vٗ(ٮT)CY@9wr#9T4o''0h?qln@Z  ޢrb?3DYA)f:4rѮ`ޮ LMoB&rd}k 5dT]AXH5Dܶ6};&T$v9i=4c=k0f&Oج{ \jvSD3fa+rưy#g<,BhBvxGxU@+o=SpYu%uH3,ɮy 481_s,0P֬y`PѮy M2l87tlwM%l@ ,+73k 7saA2MRSw]A kk 1Wp٪ bA~;}F-\j!RDިc]*v9nU0Bi5uL\3YSCĄ#|)2u!Tc\z"Y CvMy@¬q15|9 b]AnEwrr>_zk#iN=۵-wx8WF806P.^|-D;6R,xY8lF<km6l#QOҨÒNlw?Y@]Au]Aub@-Míjj %FyOO|cs?2i ȗhQd@=xƤ҄UAlrqZQ@>$Kͮy  uѮy 3B,2>5%`<7EV#݄d= |F"VŜfHKȥaA] GEI]A]RrrTDB\veڹ[oa!r~Y@ֻڎAf}-p=̑8S-dXĂjW5/jǪ Ըo=Q@m_<0иWF3,nPU".>@Op,ͨbAr'~;\CҎ'>^:ʓPI:y£!w7$9L|e:g74 vxܢt&g,mlHx͗$ui0is:i0[) 7i@)4N:%#l.9A/*It[, 2sO:ʭ kY'|aOE1y"B0^LR剴?ڈI@6Gّw+[0ᯟ;&dx]ǯ7 ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^?{Ě׫׫׫׫׫׫׫׫׫׫׫׫׫׫׫׫׫׫׫׫׫׫׫׫׫׫׫׫׫׫׫׫׫׫^4 h.%wfb :,1($H ~j~ u)$U+D9[3ʓSAIx~́*hDϊ:Eg!koٳyFyu4o)>Af!~1O5IG!*TW'woVn(T+ob1Ds"o7?}󿣼c`$ y -;|?99ѡU>y֡s̴҆Q A^TL4Z,2SIѹsK7F 4"ЊybK(o68KfT4^MAjI_='ۏoXhes= Ǭs*=6 4B??HL^H[DſA$g%BsCpsT #:Wf|i":rb釔1U]$X \~eFmr2-* áwZшrB#s@H'/uN@&F @D+EШ|.o-Lw4Bxb J9>2(WiNe;R(ʅ!U1Z7xt?2_}D)Jf郋N>v0wr婾V:q-XKb(E[R t# - &ybDMzAlC<0qVՄ$ '41 -"0wriNRwqD s-LECZ5I64 [&8Z L*KJx;hxTt2\boIA 7|R8V4/ܢ\?b` Z;qMbF(~RP}l𑳁_|?4BcbO8IG2M%y?I8~,`>Nh~pDM2ᓒȥMФj$9pbFhj4p5еxωϋF(~hЇwaDݫw#o]E0MO k0eC0dv. 0@aA~!yith_@ithwd 6-'8MN `adGQ}*S%Qᠢ= ITNS3 ŮRdm3v wӴBF瞘L&"TjMcO.pD1R2fN@֊ʞLz~e$lblZiɤb@$QVTGqW$F'1,r{)$~W]ZSٓICD9\9؅UEZk*{iqx0pf/Ц֚ʞlv6x0JbPl^k:K8cz!6È r'ؚҞr0}~{S ="8֋$ ݛ<=$?N-aI{ N1 ˶,w_ ]qCS nAطy!  ȅ 2O3W0`6*ɾ% ˌ^pCÄK˗]%Sf$t N.gqI=d_qCÄIO)D.9 v0d!XCơ/m0!6hz ;z#wՋXqCÄSH$41F wI:510.;-#= <ߊm"#Ӭ lhpJӃPW8kn N)+>WvtHy;nhp &AM0*8\E l ePIWL搀ywW0L 49%`zhK:X@Iܜ[XDwtI+$ips`m.|eDMICrn<3,@#W[ƆHڜR0%6ugDoGxa)OSthFL x!3ZqG$XrlhǎG֜"_91.iXso̼P#S W<攁a#*7'2ӌ!!9Ў;&)xs@Մ Y> q49e+ {49e` -t06DR攀i0_in 4 Y\H%=KI&BUks!el18+'>xCIG4$;kI !טw=npa)a u85B}e|}z<.ͤ xa)`CYn 5qI$pʼnn+iXv"+9c$`wR4 "!ݲvSgaaN[(;E`b?>jʴB(m\#YNSCs _$+pA)6\p[ WӰM :3㝆e! BC|8cLK| ~gMoGG4<;l=m8e9xB'eopnL'V1Ÿ'9̣jfYp2oyDq5x&ҳ❆e=ݾh'D>n#Qj&a$+ ~xHU^TS& @c/2E~V%,gES *UG|GyCS)O l,r{Ebst"$CpC; N?7@q; ǚ3Y~ER*LqnE;No${_NS;{-q^ye'h&22+)HodncuH%p: NZe4IZ:u58f187DWpțo0iɁ=4 ;lJwHbr4;%lZ&7Iyf" )8vS\O4\4auo}\$lMy5,hR 'O [sN ڻ*FP,c>a%*8ym*YΪW$`/(".T]>N6tW)RDo ~`*ēq%Kv20M| r0l/+iHvb7_CN<.iz0۶ӏㄩw3C)y,NCȞ熃a,wB6éB͏h!)a3mYxm\=-/h@)_36 Zz+iPvm%Qdt= 9Sy$TUhD=7]f@;6}%2l@)[ObB%0JCqR %ZceA㹒}G5'1E<\{GR %O [ \mG5<%lAΥ>5v6,Հ1*. iHv }ԾxD|*vR4LTXڰNS&,+~p IR v"FyĘZv 'Ax;t/忀ip4s%7SՕHvqcQ4(;k)| eAp-ek9ˡ8۱NCSfF__E8ҰrǗL7+iXs5 s8"a)`sHMLbHCSZQS,e1W4RtFm?{Ei{vHHC}J%;+[}hFМC,;|h4!#=B`Ƒ]%]t#iXSVxo52n"ǵ5LیMsdG цEΜ_qĊDʜ쟩B ("\oE" e/$i="x"/A1 |(@`8"H49\C9+ isr ^A pBÀ=Oa WOj9H m0ɠբ+M-;Kȉ_\GhmWcMGO=-$I)M5%=4da82J[ɡ1D>ϸ+i&kZzh&W^k sOHx`ʧn=ȗ2eD7=VdSɑ۷ D øE5%=3Vƈ40p<1;7N7Eִ4s*4ȅJeScMK0sWMa ߦ {O'-xVU8|ǩzcpCq TkXy ț!}Ѻ&'w}Vwǣu&'D+>$I?TALYS!wEP|'3;+@!VƝ$opUEO=+F8oZIILFci& gDU0+jRxozeʣ#\'Ίj &o1#9 0&4?puBF&\HiH.uTRYDUÓ/m1IxfzߥUœ~ٶKt$̶2jxpٗ;jxRqѷ&яo䍬ʹgi& FRU4a9קe:b"jC~:PΈnE[0\2@x8sWFk|Ԑ!O l}`wPvt'K9ͩ:$nt[bvou[OdFs9+9+R6i8'1nD&6*okUБߛ ۚXy2?_<ZRn_o }'o哿_>?~{$ıp ԗ_h8Bc \Ë_#9`kOJS_}OKZ|t{!my_?W!wzͷo۟._3'v ?{Tt륾xy>JÏKoopDoۗJ;`l|3>vro]~.sY%;>GoM+/ĭ~Rendstream endobj 273 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 5606 >> stream xX TTW~mC'*.)}_0Dc\@Q(.(. .l "ȾuW7ȾC,@h`qF$MtL=?} I'srۜ1d2v|JYpG9Cow>9c#T?F3~Av y[msZ}J_5'Nl;iv >cǬ;w g1#f$͸2c*fϬaܘZf3Y,d&3Ɓe1S̻#3Y11N313c0L_?3bbxf  bf061LOf(c|He̘hlDŽ=P\^c,Ŝ5`^)*a n$=󁅫Vj=wXүo߾1=:mVx%VV]:hޠv~6o8c1ٲ(.);fE0:>AI0,TA%\2'GݰS2AKmÁ֨W'TZSZ *LY@ #d²ArFŃx$yGނ{(Ȝ8s{.(W*Lw "s}\T k@ĀeF¾?h|^0;|? 铩đB xmb'UKБ}~SIƑoxYYHNVi)Id5s\ߞL%3FdI8gEa**C8ivIƦ]̏4AXU8BӠb~C=%ġղ~Y.Ő!)9:>19`[p~d<ñDee!!bBܜ  %^B yOAApOlڱڜ4)=yZ,NpiA:A!C)e~$G/q#d$z(4cǎMv!5찻h>}ChX:.Kek9 1#wWFz(x5u4lWƢWFwHV~:~*S1M'4k4\om_ڍ9%U % sp(hW4s#Gk)N({J}A43*c1ez\4|JTl94p!(Q/F'Z3^j5xNP leib41JғdC< ;d%Md2K8UN" S?NWGҀzBd3'!Nr jz}&3lJؔ`Hur&y.YnM,wQ{pn{?=,5l)2J^a+R[צRҋ8Kј`@J3yJWJ!2#rL7!u1pCŧhcTS aśE(~.A7R)kqb_>-/5や2ouDZ"4Zq0 b K7/9*1jbMF{H(Nis3|C7{dڛ(oSV^rq;s!&\J\Mjn%67U9PFϦM{Kr 54%GndH?@/h)W֜>Vfęx\ZĄ9;1m(R+u=;JrH+SwX(jJETH6$f.JJAyrUVY uZvɳr 4E䚻\Gd [*̏pMrd2pc;O+tڣåF'v- ~u&;"^毮U 㬪j9Δ7F\R58K|bjPLEˇhWa$^(^~Y`iiBDL^6׆(onjZhK[ 'A^9Iwϯ6S[a uJyP d&'*^{rSE0LQ%Q9slw߬C*DiȗU_jRVɅ9p X_V <˷dѤ+?lVl><8y\..F'|ާ7]^#/itZUzT=% m~v.x;r8\y6l;i_*r˩D:]ϼ1\A]7l#H?4q3O>XO酔w hta%ATk1bT"[\>oԚ /w=ߝ. ɍ 7N2M#j'h %Q%,!;;3 w#Ws~Ddeߞ-۷c$ƼI8;ߒ *m J3__v> ~{32Iӈҥ]R$ryELPC9qI IT0%db3)pW f rsKNmJ߿)îb_yzbSׯ>-[N / 9ĝ;)=?T˟0a-1;zekE{ZK *Cpw}P'*dkQᣞ [wc Ct2ā|'\hmHzj/zXNpӻŰ?535|}:KS6n1.,Y uZ-DC 2`Y}GMK F{"M]Ind"0 ]K/Z87r1}~~;c)݋g("S%2zu||yK\ۣ*V\(UlB׫ CXi hjFt}OwR(klsph1*%@K'6F7}Smz7`*%#1>l3#÷d:Kj"ѹFoa qL94f@5_1*싳Aߓ)·_ %1ڣ/9>]hj i=? t ToUGiB5Id$noH 'J'U"?{?5)*4Aaje*:Ϻx\%U쏓 ?yݔ9?Y,URaSƚSȹr41†uѮlݳuEA^%i<$Kr(ä `)3oe[nCi]`6apӇ-g> C6-ʡng_9;]7i44"RItmFIdd;ϚB)Z ^h%<~Zz"U[uA[`'U/dH>Ơ<:oPFK!Ӥ} m;u|0f,|0t֞|Wi 3O,: PRS?JVgq(~U PtTnXd b:nq+dT妧 ̀M:zޖO>S,;~U[bvcsWƱn#Z d >4;>ueOlt S!(61-cOTv- RpTŃ0oĉzeUiz=ru;|wdN/p"R哏w'WkX͏;?<(P":UsBW'D_6߷HM_Zt;h/=u~4t^ u Nj!ˌJ7jq4<\i8ZT?,".N5IJxhAxHݞ"bf*\kIfsLDAbB2 `+d'܁:nBX%\p Y^dRŞ{j+K<2#.eڕQa{S'(lȐ~|j7oټ֧Mߢx@'\D#X * aJ4#fFk:2(Sr`2:., %{Bo z`endstream endobj 274 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 5128 >> stream xXyX纟`{g<գRҺEQD ٗ-HN؄&jE,ZֺX[km| I}8~#P"Hdg`{blJ_Ma2#Q/ ],<"2*zM"f;W_# XM4yԷߙ0}Ƭo) ʝZEVS8j 5RZBM6RQMRj J-ަާi 5rfPnLjLͣl!ʖJ Svj$bW({ʁS(+5(H ɍ([xQW;ܬXZA'K.GS>p@ jbеsastȤ!_ھi9C 7M{f)N=X8"z#G&6l0{W^﫷:2 mB#+0BT'lτ{@4D@ (R} b!EVh&]sHy (185+!ۛ,~`@0?zYe,;ž3JN%'nO gqw)VX˟=֋#6@ S:vM~@vބgKV\}s/~B#Y?qڲ'o?ggE~]]/NoO\E;vpfs7V )rF{*@ 2N&U<'rGbrk[ޒڣ)i5g]/^~1z"mje=&ݑL8l|QFZMPYΝ4 9?tٺeJI77_Kwn=I]@E\ٜf׾\`J*۶nxc/Cq^ -aDE?c$E9T][BOW)zCۇ6H8gvsA9Kc֛m !vb! :.Ne2dJ؉dD%9̶A9 ^aǏ7cGA&O1NnT~N,LGߓ~f&Ƕ#cWTq*>lK fu'[t9Y~i@u${[EG3v m.9#g]j7ֲS!:=<\*<^Pt n@xv3̇$M 2|2#$mbq h!ĥl.;vy߲yz+,F#w<\ yWZ 6*V?-]$oñ -w!.Q1|xZ<>c^p\W7'ۋըjM:'>C &zLяOyyxlZ㧬얃U|UI\>Ӽ8>~q@/NP=r57:"=DΦSptj$L8q(Fh "q+,r8U\8PT;=<)9WGOwCΞ~DBB}x"L#넂.u߸qqC)|DWEGUDTTpx~w܍i 4ҽgQYܷE+)m~.e{?,îĔ,`fVy3ed՜̼#ZsV9/㛋[e񾭲q9>%9+'|gqYf>I>v#4rWC)l{ [wC8,nG$-h\Av$a"Ze@\%r~i8GhTrf71^;!G: nqzx&l~5[iE]Ygw_uY1]ҋP/W]jl91E.kׯsDI_h<'OnX7<ޢKm{El'c P[ jNUyhxC`2)) 6W<D}T 䑛΁GmRGst( E*V6'?Jm|2%Ma2ا*bc P38uz5D`{F L|BUY7*) deܼlM2\c`;%⢲{:6rL[MOJ<}t6[̑?wٳa ؉&'Js琓E93WмZA5ASs7ȮZMDsx #Iic @zC՟z ccLRz\ ȘҺ'#ȖA!ҚƜ\ufg@N\8o}r@$ȫ &ZyQ#ny!k1:6T mhu@,BtZ+?jr5bqQʘ=)dHv*SJ da@I Ȟ"G< O=G4 rؗHynhrD~|x'ay}*LJ$y8-`K6(Fd[֥eDC(Sj;zOn274SW;רڧDOiTe ֒<9'%+>ޢr_!xMbRZ(683]CFקu92 ;K_\b0bmwZzŴާ3ՙj5Ƀ|F[8+Evw<:|i!Cu'̕ECM5{J*A5YLwǮAo$;cS!:=% "${XXdLb|q\brJJPe'4ʴ!=0YD ș٤m:`}vh"O99ϟ!%C!c, BX_$~GQ'm":@ q$J 򸆖s{ｻmu5|VVn.q.8&) eK4'nQElgEЪ>%kx=LJpaH77IkJġхdW*bpVGn?CE .ެ$t1f_>Z7.`2X8~7{O:w^{S׮7y8f}vӷ_zV/С ѿ(U΃{QE V]\iX}Չ:ZuVVsO?PL-xu>3>QhZE3)J,&L"#X#/lBCdl 9EP|6Llc]9٢))Yg4<Ŗ4CsS (x;hXBQrV|15h\c+-^ŭ<,><Ȫv+ƭ.˷84c24=IRU4l ox̄$e $0I91U5_ V c  A`3l(߶g endstream endobj 275 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2339 >> stream xiTWǫl*ˁ,Uh\L4&Qp J@dDfztl ZȪ* mbѸ%1zsf2d<3iΩ+rA4-[;/78 8CNc>>MXq"&6.~V;#gΞ빀&Qʟ Q멍NyS)_jIQ/Pc)z ٔr:7oaCc8iq"Di~arZMN U.4-X%SnhB;hO8Vd6 &C^zL"T7F),.s5r 4J?BۺdKkK/-2iرhtAh9fGH uCRzaL4݇9m\VtɩFQG?B׬$>[cJ28*!<<#?kJ@ lNKD.ϤҚTԥ Qe%pK75sL\` 39j^D *]/4MD(N;-%naT{?x+|Z OΒj8EGEܰ<+~dA<k:Ї8,F*/h_hTȬ;&1.vJeF=2stk7Y٥# >1ɕL,b K͚k]cZ&nb Xyӆ@,PBЊnmu:S %1; a( 5;h1℆Qj}&fߴ%u<^_ܤUZ9Ch V ٔC~-6yY}ns*Y%W %YnVzyd&|tCյ > ]vwa޳qѡwh;px_VBX?_⳶;=b9.mAZrX+`aLVA+7>p%ˤ7(O_L.^sl EN.L#O>ҐQY;;[U;iٞ]!@~bdQD>Ze+\NQJT]W)MpZs )bi-O)LqLTViR5\q+f,mEjٺ ˈA#8@ui3=Kx '[?k) y&aPĂ([z `N}CF6SpG8qOP3endstream endobj 276 0 obj << /Filter /FlateDecode /Length 2229 >> stream x[Ko7 :f9|T8A h1Cۃ+5QIv;h}}̬DֱّdjT &rz607_M_LO LOO0 VHa-d5z9;b.x=RĨtuC*ƨRX?N~:dڮw "Z0`20; +u #BKJJ)&*_-n7Ս3BgmGNʋ+Hn?sZwuoF)#IJ1ƨv0ެ٤mS=0[W9mznI˪z-qJxaSꆇңk]"Cwr uv|7CIQp)!2[v~1σ2;~|t|jyߡ7PEң9ꔋW10R'/A TGt4"4NV4>׀/zĉUhYi!_:eijuM˖ >th"OތeL1ˠhK>`ybTbMń^12mW93zA*wW ܮrhI͘V)6H E[._8KG;tT\z|qY%\ҽ|,gA(Bب325T  :PEи,\Flk V聖)z#b*r•r|˩iBLaSl.> stream xyx׶aL3N{)0b PlW"Kڒ-.]6Mǀ!JR=c?#ABrw>}sFgk$TvD"9-u v25:Ks¾C'@']Q/9rGuNns^^°EGlYui2>+l_cNW~k֏5Z@ޣxj5ZLMPdʙB͠:S~TjeKS]nTwzRoQ,Ջ ަ({7ՇK(NuQ%%)=t$J n@]z6ͧ`;ݎwRtv|]=6&ntkz2=oUŮa]}}Ὓ{E>lsVc?Ҹ\%?[k/a@1tX5h`Aefa%ۭKؔ\uz ĀZ܅ڞl\a9@ usfz6D~N>0Cz)>3ujƶu!7Kw }Hzu6+7S|[R8qr |sS)Z|"dp#=!{^7u)X_=<2e7͓gMs3b%QR} Uߒ h?`wo=doQXoT(?pH8WsZ#+=k6m4p^XNՆTj5y4:6bc*.U$gS!TZǙ4'l]J|~j׽FHVG6=(`N;kym]fnc<+ZgŠW$kԊdmƦ j/ぷ x,Zk|I4i\bʮd`Fc^eu@$dN2OĨJw >zx"sHU=IU䷵U%R a[oJV~unt_OwL;Yc47e* |ܟk+RIŒ=P!)+LYbDhB[gxְ7p©5 s,Sc:Iq H&035 ,0Gn4E6;aXԦ25·_Lc~;1p^v#?.*8]o"s>5u!qx3QDY}tb=_sώL`2!hF7"ɽhQ%ԷDfCXߌ%2hcUL縆!'/9{?t$q֡z0l9wG>5:g4˂SANJJF_5.VdoMh"l:ʮQ1:)"}_]ȾfzҦNU9ɡh_-P9x KzGY`Sqra\Zmc$f@ۢw MD,m")̏o˅lt(uy ,)B(URt࢖ 3:|! au6W Je`cۣZe@o_ń`A5d ~ٺ4d>F̅ He08wh$݄4ly9o+mÆa3qbcvo {iEUּ*A*|O *pPW$$\; @Rb .uj_U&NbuEsbɹ;2'aHT#++ubuq@Nԃ YO>G vq~^9Èň %?B[." Yޔ%䆘Ҳ&K-n^4ި=f13:ƣ.mC'3CW.1^p[tmKQdf~8&& QUuGg!Fl@X!M褄0|Cc9=Gn|[pLtR\SRJHf}`edU4Cu+Dw+<̒l!Ixܰ`j:|$ch{%]!hv^B1r SS^bsw¶ڨXؚ \X;3jt.WmUd0M0=`+/$GkիBH!2vXʓI*WԂ2Hb]r2yhx[;;NI oD1PV[{{Djkm)-|jj,Hz=Y(h4XJ{Rh' C٬Q$ebۜIHpqKkNvdoғX|AN Qfpt8jw`!O6,9tULh-ub*X744yݔ+7{!o0LZDZ ym(r($m-kͼPJg&:+N.;F K*m#O-t[m i!JAη- 0 'KLs*~ȗA:#t4}% [t*evL #z_ٴ}㆕9'Qj"l]h7 3DxڈNY&0 =f+|<6 2u{u%>a(ryLdW.섍8xR|@UԜۯ&>'rU3:%&@kJV-#'lX{-#H23cQhc+JC"j+J8ag"֝Gs }uS l5[UJZΠgSȮ k/FSJ$tN)ٯr%d~Mv8?0םd?4򵞵 E&O>R +wWϝii7nʼn=Qi_MfpîAS\ȡ=M9 -b ?b,8lN6VT8<,JUsV}!?g)* ^xqBxF& W>$i4,r1OU6q´3v~}# C`\U3 |A(XsC-fA ZHВyAIt@δ"Mnb#5&FoSsQzoI_< 2!>2FF-'xUWx$V֨JFߨ lDNFj[FwP`KծdʉmXyjh%owR\kj FR w٬򢃷EZ5N:9/kSuBRtA:{s3["l?X:B(؊b,!6ymb[Oy.\?ؼlg'%KO/'2 [Kw=ج} \_CpNST%6$&UIrI(6&'C|UNdFlob'JC{ i!~GdA 4Mo+GUNKa(é/%T֏x%4n 5֣&rBKh̲b(6D،OPQ6c3 EP#,"lpց֡uVD^ dPhbld?h f{5Y//-*.˭9Ь:L3Jh}8=v +'E='0лdD8hM {>l<"40Z]ORSDd(.sȧȦS^Ϻu`v$`iM`qog8FeZ"AyRTV-8ϕ e#b3ɃgR[b GV8Ѯ^4JZRu/PtL"=1V_dV3sRsąaFI-yK*Bp_y֖N%nʽ/Q,L Ǻf_ >LMݷpG IYE=QA5bh?bBxf;GvK"1惄JWeKA$s9U>\V{F*-KWwKoKo_E$# cOЎRa A**qbWR Ybd.V ` * vWEԠQq+-/c&qYL. $ׅU~-\<\&%&} l&E BOy# Z߭4n0p`Wbы\Y=(?1fL=3bgǭ5ɖ5\yB7RJ]‹8N=ʳ$ .-m>6rT8V+^ .l[b_"#o%/*ѮRp=S!\'KIWWB`LJ%[&wؕ\VU5)ks[fT Sg;YPzuZT*0(20s1| Nӿ(aw,ҾϬ6IX)OHڨwn ƭ{2ϠKy , $MP=)2/X68/ZQQ^T`>u|0ps$yB|5a,+;`JPk̝2{o/ NfSWzn 3 >%=PݿU–dwu^ gLI&.QCak~ؗ5Ӏ!e{+[MRt6W~|>cL>;fLDZ۳Wmrbkn#6{/~ӡG9!14]~qۊ,2"/8Ϟf$oR҆{א Ap[:6Keҡ)6 \ڼꎺ {Jpqcv=r&T'v5CwNъJs u!F7d9"+z]_2 `ɢW[qP:^4=GlJ#(QJdoi f`)#>=B619 N5lWL,]*-AR*'%zAnBfi8S{6%'UJgdra}/Au['=9?I>CsXzj2(2߽z5+K4B y2a,[Zl(( Јm=o+tio[6&>4tQEC_DSyZ}MG m}UR;ivHH?]!w:"iz]:ѧ- ݾ%?ܒdჲ/_ܬ2U x[SXPT[MVję҂ȈH~c;̬'\=VETRFA(TTt,Rn+uz):Y(x*`7d$vTX(YN˻wcK3+^/y;Rax&3cu}q`ARNjmzEq+o[:Ͽ:Ȇ!(# b S ϤwTƒГ: ɇn6L.öa]KM"ȹ'Fe*L5I cLӶ\;@йtAQi-endstream endobj 278 0 obj << /Filter /FlateDecode /Length 4113 >> stream x\Yo~'#wxn yHqGA$DJ4)*V䷧{]h:/q]~9*qvW?N+1 R:~}D3ʙaT^&#ZlBH3o7J f;{=lav^(חq0hGKt7 J7F"Ufr~u/_qG! ylX_ 㨀+Ldx!~r =yOa{ 90Zqop>DN J;¿Si`aMt8уpqן+ZGz_Q _pD|ȤJ( I*>o;ƽ X*'+2l$h$?"ExPځh# |Tq7Fh`%cw9Ce x=)VZKBZ[AV[ȼҶ01fT *HX.Lqt|0 ~Bya$M]8t3(3O2(*YGXg} T;p'B̈́Hh3AW4 &?yv%ۜ]9S&J(Kp9{ߟR/vMNF@)7u:äb4xVossl&(Ca&L1",^E#mOLtL^R݊[% ɐd kPY M,H>pcӡr?azF^dJ Ms<,$ N!tM5K]'3k_Ad2ݓ.ѭ:Eb8׹Dd`Hxg{SZ)L<Ͽwkp1 e> QLo0S.Q23d fܘ%G82 r] ^̹/<^f H:|pT5ђOx՞L.l8d]F#h`ZzBq2OTv^oPE4aC0;v9*_DkGxJMl8FC.D#h-jX_fRQm_<wGvOq}Foh,ndD货 89^E&S:ӳ !V9aHn 7AQĄґJ1E]XEBB .d.f1ߜ4 Г;$iK(3kňZVʠG np*AgBt N2a*%g绪ϒ)W% Qn l pCr1J">ReڪV"q*S/v4TMNnӝ_2JRHx)`v;+7NJC0i)`^ͤLn )@cF̻cpe8_6uueK)B5[LУӒB"qW;$/_2j{c8\hM`MWrÖA[yKbGɀln{44EsbZ 6?e/Eϫb# ,uͨ0 _7rD剅 eǵ|~-P<-]LY' MwVPAFS x唗ݴkpf"o0i.yrX")FIjGf r3(6{IR tZH#?;H+JD:pd~6S^;Q"r>fqY8ID„(<| nRնKc"Dn0,HO+b'?-S(!Hh`{^ 6u>M.Lv%bF˒CyU F?prϝL`h{  ;G,Ix%TUn-KlP$K pw&0!Ear?f#Lwxu[Fs-Un5acN%J>)+/h/Jbbr[Lq˱~&!Fo-B`OQWa*L"wRe&D7<>htKpG58/\a͕2GS{22A^PoFуpӶt1 j|s!&y]n:qut{~Q3E|xhgbkIZ"' T?Z`Ĭ;ubNpIYĒy% ~E"5-#a r<̊&dFe&]4>, -yY4֯3`r(]DLJ}G$w+!LxKQ: `Fr9ݽdiԅW6W.Et~dElJԑ3K?QJړ'5I۶:}mF,#|,z),/ԀTO6* d|R*p"Ȣin 0H=^!6,`Umvc'+}hEN=m!7e ^'Tpe+"Hroj)ԠDʹ`^mLA;N)'B>X:;?'>ِ>+߆*mFްŵWqYr[ZHrT_Tm[H5-dỨT7Xn_D檘{>k+Qk莦".ccޒ6v#\(0N[lj@_j18i,k$vٙCvJOK}fZ! .?zB֐' ϖ.#wRq΢nfx) ogBxHk6G#{]li~`/=I{6)!+1xyWgCwWn ǬHgxzmί?_ rMY,U*-.@VU2G-qh)\z8ZQvؒ*tkv$ZAkemj(4zk6r?~PF=drJrqYh̼ob?R8wqA0Ƥ˘JV7] ^}pCv;w!Xq4|վ5;O3vr{^M9_2iE]Y'#1>+9Y:_j4_.nAByOendstream endobj 279 0 obj << /Filter /FlateDecode /Length 4377 >> stream x[[s,q~g#K\@cKJ$VF{ᒒοO_l3CRǧRF/_7z>.Z _p5,>^)zq{BV.n?\ n5Ufq{\(ʩ7*U\sJ˃x08{aC\.g|0Vi*9cW.Ĵ_h= J]nċL&ƍ3?~LS#TțZoѬ -{MDA5$&!>˝xKgUPB6u^. gr⹐1Dnkau$OY)–P1̐V$P{PV6@uumu`ϔHn/y[n8P6ga-%%\0+bͮǛeWz{-J=?4}ִJy4X+ZҐ=1$93)F˩o-9'~R>cG'_:$g8|CƟAB+AFpI}֧s# [ WQ+l[}㠨lugcUDƪY ( J& NqBɂB'+SnͪC\;">e{1BG&/;fZ24D Qյ~׺?#+L󵳠C&Ά9+Q4󤜏لdA8 9枩dz27Wdp6ɑT_$6\ 5K7B61U0Q0:*&V#YAgN+ȖAMK XXU OHH ]17j8p=x379) hE.g.GFKNzk0yؖ:4 I )ȔU1TKjT-ji:< (|mXL~Ի-RAT@ rTN}5JÄϘ{lFϑ;D#ybI-YCYtKǣDbR,k??\T5e[Eȴ۔{V@6*Ԕ진Qe?K {V ~=~n&) ӈ?lZlzWR|)9LbcYQ/ђ LO⸉(VC#qhsx\`V10jդ{:NK!7ʥ>q *jdV >?#S!+M3ڒf-seQUUGrNz^4P=5ؐEm*/qϠg'QFkXsT0Qmo3ey"_5Y ɻw2T,F0q^L_'? )z_;uNbg7UI_TK}f[pC=^!`8FrϤg71mqUAG)j& z[N<'ڑxDգ ]E*BIs.s6$]rH֭Jߔ6<>3$M)MLgΙ_{0Y}FBC%w' hl isW{e|$&nhȪVQ`5`{U_2p5%^8`!  a5rBϚz nL1 /uOV(22Q*vCꏮ+Tl;{KLW yO76S%Wt2s*9 U޺mqfuW<*z1[B~h-U %/f-;ȟF6͌@+n7_nVz}#9];]>60Q+cjjQ))ԗqH˥8X{r kmgD4EexqmdNYy/uDن1'< 2xf[X3N)'{oMs|G4xQo* ?uM #7}r^!yrRUv"ˮMu=Na@B }MVK9U-z*rl6 ;u1F[Q۬9gR)sc;$;9Q 0ykE?;Hl4F(b5q,yE5r:K&RWzhT*%fLի׺H_+G҆|^9L1;](l'V/*5UyCKsx*nI| V.Ww? )D5I<%]jmOJ>@8r)J+헸AO]az˕a+/eHݺQC^~w݃YVҒ|[y;;߬p[TeA%;zHʥNڻN$vZ?u|𩋗}9F%-dM9X-uJۀ KK9|  iaF,IϏY@TjAn ӆu$kMx./zz1^|#2nk]SSA@r΍>CHp$pokR$a< cdaix-gĘZ?{1cP1}5˻z@@%^[Bv ^n<R%ooLI|1`ʣN ExqVƄU-@Y),nyC?UاKr" 씀PAPˈU8"=9zJ=쬭 7% bDa44,zG `@iB{Cw%WJ64M|AqDSn 4NI\h:eGVf=3%R/Ŗ|+xg&g@INqI^5RYi] XɯEUf\T'Jb_!b#1A?M-\. ix 7<O' oK}3D׻^ť~ĕrgh+[4a3PK ^ʠ5\QC-ɻg dS@ @@D\~ۜ3-x.c[޽<1ϼPX^- qv&?G}5^:~^w`}ϐ~|=gX@e{пA{f)~8=yv΁b. "yBj)ݿloE3,>Su ¡XlnറFL{-JGE ~Пɬ6Msޖa5NȚs}tO>l+5&=)l-1e;0vb|n4q3c@IeK!+^gYSrAI:`d6zqz>ʏM׽eqUI1V v=m/d7v#U~wϻ1Z 22<>+b[m#gjendstream endobj 280 0 obj << /Filter /FlateDecode /Length 6756 >> stream x]Is\Grc#:"AkUv ;<^blS#/%R?Y^7@Uj=u'r'_D^z".wy'e'^:=۽A+.݋ۓOٹ<\NlB!>Y% ۿe>i+hxjٹ^/}NȀK?a/dI* va'/! o`+Z +'pJkuBh&YtdlfCΞޝ)«q/op rj-~]ƻO&)U|,9dM3]>g޲,.Z- EGᅰVQ(tkcb ~ 7q@qq1l˿9C2/ ̓cLwNq:  4N@+rWCM^}l ׳Wss.'٪bj> )|t}΍{+&~]= 'CڙJK S XCGb; 9\\'T `D|v;n~&"LYv#dR:۸K3i߱9zY R^ vvm^ʥ>.PP5{~yZXM/߶1Q }>WC3Vi-vivU]#&Ʒ;q'X'@qy:[%efdN9n|PO佊+ ~]. f$D(o0 lt4-&ۭ7q0^ _6G'MlPT^ i"eUDʶK\LpT5iq iByٺ;hՉbal\%6=d4!I 2TC|lǿ(K*9:S~d iv]+aap"yY !ȼ,XZ2/0ȱ񺋏 {GC[@^0 k&Ғ<BLVzT4`zh,ac3 g)QBZ 6_}LG&S#?/FB%:sgإGYl4 JhdK!%#XС?c p JGl$]\{LI'1^a® ǰ{B{(C qE&y6{d(E6ӌ>OgDp@Ћc'"쀄!f,ZXT@e3e BͲdƱZFreJuxNlnB7IawN\xtsqa"NU豷p~M$[|ia~Yw<&G5F,;]-G6ޖ, ÄSa뷬 ٹ]  0'Fo2,U2c.$ͦH~4DEP&O㶨iwI'JU:z3tùϗɬg0lZ:x/G:mݱ466SI9>,-J2 rJb0)F:D-b%W @'g`|!E,#WDR\o+RЋoۇB͛B6xm_X SFDu+ F@٨w"zx0ܢZq0JqyPa ͏?NQj9g؏3:v6̲g9a4,YG xWJV+vFj蒻 XB5c!?@ 3p@0B#'ctBK `9_P=ZB >BboS331KN)|W5axN#}o٥q@ WVng >,L8ZX|AS҄%L"Qe684+ް-Oytm(?/CP6fEδP I\p˨&I>/e+C(@aXɄgۡw._:ipF%,S^ڏzvwAǰDCM|9 n/0<洵챨Otm4t l1fl b"9`L& H,{ƚoL.|t5gq"3 s; Y|ht>`s`uF|%mC]^6@Awm#4 Ǣ-M~6Qw1H?! "ܘ\7K2A8tL~zm n*9 t:O0}?" Eڐڹ1}O ͔(|{= /xF,5)j3k X?$s*IRy+FAlKT P8oiXVpyЀx-i5eHG͗<ђ C!x8tX mau'JG۳YqM~7d+ ,LZ&B0vFW%Q]o?*n/kwU&Pˠz0HrH?j_Sҫ|MzmI 5yhsAl:i;)a#œ|Uq^+EN{¶>,ADL%U;c_PMd~ؚ ״V"i k"xC@,ŕHiMqqUۀ)K6DJP`uF;U|NxP,=R|KEfw^r V &%c!H`P0sC򽊍PcbEX,  /YY P%Z&=1f3߇CWYI¡NHQ23tN> D `{ӻ?{#.L##QԠGP/S&V?&U%`GRtu2nAaEW_]xlSFh2l%@dqV꧵QTUҴz&P!h e܊Yr:c=ӡ"e Lx%AÔ9Iŵdg1ԅ>Db}Q]!"l@ئf>I< tkNJeq.=뗤-gM|Ære&)%f79 m/ܭmGAֺwWmq&|4 LܕҬ.=4 .\nh}. q̶=Ы4間i7i*-nk"_5lDD#ɘ!Q 6s(F 4A37B/;:K5oG$HdAsߔhCջ3+NB> #XZ6xuRbOk\3N]#\\1&Gl 15UPsKg1,a'Mßc]yq1Su9ƦKU~\(O $mqgqu}bQ6&k ›Qw5s_J@G3p^O9rCl%XXj-Pf{Wҍp'WCϢhJ1yZ01":~L5?˻rL|dVd]RԘ ~HW[}d΃N_fe%Yrq~R^U#kAA(,|w Nu웢CDgj(]MnG/h78w_A F#UWV4jkeƥ4g71F"BrQyqyeoyw^9H.`w_RL)EY( 澦?CxhvvDypVR)?t֭,c:"i];6ZPpc֙ !G6EWa `[#xJ(vh~/Kל5k#)pxnsi ~2{^sqS^{(Ɨs ]ut{ͣ iwdi,&K|hj[k,*M젆 M/VעWP띤+BxT:S 3;6,g OGGnT^M>69JaP/jCUjN7Xх|`&*c PLm-_lPxwf]@ QZg: :ci0dhDbjWEg4fؾ^Dd՝9}Ctb{%7<6/bg3.SN ftd9˾ =z*iE{m$N̶(p8WZ$n(CX=MG{ ~)(ӑl⩗f.*~ gs QbW}drrVuwhlyKWTPI{WI7yl#}bSK=f_v86ᤌF<5-0 sU;<³Y1ȠEaiVŅpVh> stream x\Ko$ 'Gw`!IlҬ-[ȚF|H6$;6=l.Ճ |_->?{\q\_X=0b|0.oOXg =hsv5^+vn%+ ܜQ3p1[^3p{#vy'˛yBYԫDg 栍jlO[.%dEc \th7sӑ(7Jp^yʳaQTIfWRFe`87aTlo\FJɿN|Ҝٓ-0ȀQ[=V.K, %'6/CBC~{Ĝ s70?F9_ #?rN/C?8yg3ͩ ppX(@jd {2me5hdaA"{uƵ@}8P':7q: @P^ 19;^gm!r"_0]_"}ߖ0F5H$E~ ?ohzMYyX2 6 qFlC%%Pi#4 %k,n/ p_%DJ.*ߖ3͉o+f #{o+~:{@^37WB;ѕzN3^ OÃD?<@79~oyw5ycY%*6O d&D@;BLs$&W$G1"+<ya~Mnp3u !r= O&}uLYxyW"ptB R+VZqjJWݰRLc.Q+;DZh؅h꒾VYnqaxP V^$\?*sD†:3X#\k$lR-7$~G_7b=HG`?HYl^ɡ- o;\7Dۋe$Y *, 鈶>pd>nAg s+S *pV<΢ၫ4fq8˒y,w-2Kpn;ZK}=W?qv05۸*rnM VGp]GN D=&.:{^{gҁ<2ʥX J Fugk@"!#>G~}f N qujYť\`Ԗ8Q eA\Z$Ꚁu=T  NQB$Dw\%U̾-]X9QXQR\Q>cDf`|6tVbRZ!Ո ?Z5 S (;J I5WԜ.L ֪pz_Mu`0v=c)Syڙ8ݔx ֌—r?( E° _Z'SWXv?'C%iLA}f?*I̧䠬jjPT~ҖeBa9]-d\kifڐѠyjtgCJfW/rRtB9֭ /ӌKC|vEs.,P0^܏pgDcf2?:7Ʌp-܍M7TF;tc^` +Z/n0C?R]-\evNVr.O-oUBfPL*scX'z1L& ؀QV"_J ~pw[4N~֐m??r]J78`);6Kf3H9S%bzW4d00Yl+1'T ҏ6; SO7FS$jwAzHnFA|&(wy}$NkEQ]굇{ C;(L#QV/ݰ,#9ú$̬zhΙD)WHFa\UR{( tRޔL$f' Ѝ5bU[p2*nQO*8LY%H u'04 E@3VRhi.)x+v8܋C*x*λhbrBsNpY۴*LGb2!?قrS:nCZ2t5%7,eft] ~ӝÏ"vpWJ}`wWʎČʗvm*6lonoG)NX&IqXpxTzg ^x[۱epS 1*EB$7z cqF6Zkܘ.O QYаǩ;(wsmN!6`?]ڶ|(ziz2"2";r&|P)9=Ff|o& LRjcŔNPk8pSǟЏ0VHJ7)vfuRTy" D$y1Um[;09]-=׳k  )`,MUفYESr$0p1x? %x)6熈("U[^V)f  iC_9KDV7:`W2 esI>6OVT;m6Tel><#}[MqHyo2V)-.P|Yi7^:h<7 k(Ę2z!qskƳ ۾t+pO16W[7EhcT-?,<վvhŴׂABFN&z8AS0tڸp| VzYĊ.hG[O*%:迊2XޗZe90Fȡ ;VGY}ͬhvc=?O& U> ި$ؤ ql;#+DŽLXMlj,)0Hbeɇ#cC8*B53>rW-;2:}8@4ט=Q_ F1E'x^hlS :Q:D{#-22f57PԳRtRJck2Ҩ) ĩn31Y'6a*]GMBxa$M<(I+EtI4Os6ǯFsp8d?/ݗoW[t"|2n?t4V,ן}O߷{(4!uk\pD`2[fa}; qoxz2~U'\ ŝ/54%ZαeǢ=KlMxQ웯𘛫![‹lu.l, UrdQ`&"?(m@w XMٝ._$)x|!+).2cdPUBt;1nOnn9emK(ν!kJK0X̏4s,PzjCjLL,O#Xc>0qJw6j+(qolDXm/pJFчJ(恈ٞ/4c ъFVçgвa^}].!zqDi`|SB~*c4g:A崲H)g> stream x}[o%?Guk` /v CԒJ^UYR1dC2"Ye/0Xp>%/duz忷 {{ MWw?o/~ǰ`w7 lһ`!İ>^|OWZz/:dJbJQ3v;k{{/WP~J˲uqtu Yo}Uko=|;Oc@1A9h= qߋ&r._n)w;rIx1ڵUZo2Fch5ж?Y;׮7X=B}fweJfM)saW4T -TCߐM-b=?j\|5l\rSCJZAYx  \?g>bNj_rF\T]n)&F,P S=jsunǪOX5aKPQvy߶Ձ3g]7@:z׬ՠ<Q[UN5'ta"8\^CVpGi_wnkPZgZbPƄ^u߬h}y=|`R鷸I4I'YJ]þ3"h|͸dPuKAK?5 Bw68592=>SK2>Κ~KbmA(4!S2Szfoïd+(2>$R׃+}P!pNq2a:DvKfg,/m"ֿN q`/HkN5j3Ki MBZ>Xk.ׄo䤐\H @uRt일 }ߞ9"ZU[+5VHQ݆r~:V 4㨉e4L[>n#{><!l|5L,05"|@P}Ⱥ:;>}q#㊆%Wo YDA+F])rBja6q@L풍e>ѡz`TU*^4[?Yv?\@uN*}\ ]4\S)EMՏ_At+ט|s 4c3-,Mj>1]"};p@-@0ܶ ]S"O~uJfk*m(^ڐuR|*p4C:`QJ9YsVC qוC}nEgY4Qp~i]'o!kEK`B!oeJT)umYO bD$h>\|d"kĄ5$xe#It) wu]^``]_\h3M#O8Ȅf|MAM4Ag-$;&Az{T5H* uNTT{볋&TJm 6B]3q?Tg&SO@^'_%wfx~SQ,Z;[xɗqj-:\oIid6}HC~pս_,0 Ɋzp8,|(?$Yq1lm'$D b8e5)b}Tw"vc=S& )5W 'R M\dMcik} &ps4W0ȺހFr,O|e=ӎD̹~M|?iɟg;ru Vd'a[+v益u5g[%vub_25bޙtş+ Sq( MW7OI|S{NCa}.=+m4/'ي0PL"|ÛoO\sS7%=>?|d@ Z %77G4UAȯ> MRԯ!˫'4Lm[q2K.( LI*/4h̒=?"&2S)׋+qsN sR e܌x^,Z/|XkUf #[3Cߝ{j3W+\~z`)is%%%a]ɗuYD'B^<Ʀ_VSbMnO l^`ϏïR샖6uQRe=2:kFCb$MÌbbn\T(Zsu;c1GxQmq&T{0A slp 7yR%^_$#@iNgK6+ U ma]i =NKh0aCp@$ԣfGktM/͂ ӠRXh!rcAI;\;g tIZ J4eAK+9H@I=>sEBI?8׵HE %vB+(1FiH21Ӳhڮ+)v@3zʑC5o|> U!3kxGC ftt۾z"~U:{m/<u 2Qt^fk!7h7@a.ei( z) cS#Qנ 8'H-a+SU0 OXة"6XOÝ4눯da@@K LР@21#) RCnW x4_yK'n΀ .'HZ0F]Vc@3047flQ Ygrŗ:H*C0:ZU.Tl;]sH'C0umѭE{I +ʀ _dZoq'a+,#I -$Hi/C)KA,6^Jt`'Aigc7+ts," uZ v*ԑNWd(I\L1\; R\]ۺ@C'_v:}],`c`iroA'kpm_k!yGOU&6u}_v]LIkm *0aŹanmK€@M r @ſB:ps LW#PEx\" %smm,T!Wsa5JRE{%su AD<ӲF A ,@|@\°I„3AIUju­9np.ca4䜠bn'0BA}@EfD Mw -4%yD%u%y3Ѷ+=J8sIә聝Zsƹ$JuqXBsXplށ@+$4>#3sXp m CDc1&95u0|6$^LdMƴv7Km4ҿONBk9%YTn(\ {,xV$(|N5zM|e\3 yvgU9lۮ 5+w\gP~n}̝%We.ţB',֛%Oe4,AS- _V H̒2lnD+iј⃶/K~3$Z#R^eO&}seO=7#K*v/Kɪ05| 9mr21Һ# C2⻋ 68q&X;xd\0F5T!7iNqKp돘R$ReG poeBGqeyƵSpUH43D +xG p 3*T@+GF p mb-mFB`26d|AM4D\>QC p 6^sPpa3'm[HL!0wr:ӰDř6,ޯ)Gp R]VȀTI$TSdЖӉǍ:9P`|tI *3 It`dD W%_HPzA}R*ё5#"Q?¬I\N=9ɖ$Jt/f8yʅJ)yKGp|&Ԙz?2:`0`G'Q#"j8YT p欳#k8JEu5 #|BSz:hH{BdPYgĭ 7t6l$ yS|ʸ2#a޹r[&U|$p `2 5Z>`d] |x0|$p GVRsݐ}]v"u|$ *JN}5;x},n0G$Q2j0 Plm>eU!nXЉ{ܕ٧#<8>>T>W'ٶZyhT3fd#|^c8y@xqmZ^ lA6老iu68Hb6_RgCtue]e<8ͻL;ϓI|!`:{|'pƄV{)#$2fΊiT@ȋB IlIoPFąˑ$6oF94œt2Dg `'~)Z_#N@]^3nN2avN`=]ώ$*c ˸R$2 5,cKxqm",X =2“،l!eZrY")ֺ;"w˺1jc#$@ʎ$Vc [+V@sp:">88ԆCsy10Dki3:\yݨQDkipk @bC,B6K ѯiĝgl@9m>UN>QK[>ц^@%{U9O6\Z)QދҟDm  IƁ0:f2ud'QJv} Ԟӻrs.\ײ@m! A:Cfe5eB?8F( Y!f_ӟDm hR^MrkfױDmi#CS?&*me;ڑ]\UFǓ,.DEq 'h&[^O6Q%Z X=Ԇh1D iBӉ1/޷*p'Ggp|;<\kU OA,n;ziRDj#:ykILv+'ȍi^wt +'C(hB\]ˀq( 1$ڒ>v ((lI r̺O@8FvW3rnQo UjܑDp ʣq*@x;kYm9P7pzLq@pkȹGl_t$(1p^ ,rV[ǂq B'PR3 J DZ݅gS,y֥eA8F3BIGR0_E7MsRM Ɂ6 x M,c%HNAO)Gn+'(rQ:#mĨ6CݺyX>9N;Wxh؎b%PD@gyިc@8+ŝgPo й@Т&.S J02t"\CXteY@8Fs1%hPH [dKۀ: йiԖ~`[W %[umK;dBYoHPb8Q|Feǂq '4ʂQї %PKPToIP"8q%=j9P7n)Z9_CA((9P7Ad \Cǁq$dlS;!ap#5vڲY@8F#@Fͺ vnPb7QdÍJ8zI"|IޢWFNguw %G(YQ ~;؇CaGx&(f'Fc(~8Fq-wIXQp, ɖ XoW\:gRXdJqϞ*saxb*~HJ" 4)QŭZcax }%(|8FagC5ql J"Cwʗw1;[jT]g[[jx@>cK3pC bGчD Py nAG7d 9LZCaRCG9p(tJJsʐ-DbAH@G 9p$@AH0 &ўȁcaż-j9W[ H#¶fwz!"-:N7[jxhD1 v/p jɻ˫gK^ˬ4bk<6̵9L:EskgF\B~1ڵu[K.ˍ4/i^ƫ%}Lը":˕N:<ങ#s` T-x-76.0%||lj[rZnF%:}= ulkF<Pڼlk6xlC]rxVւrLzrגr+m{1u5kg4cSk\[hN]29PFuauE: L:<+qs˱u;ɥGb. ɓ9I.ձNy[#}^PN(n-t$0-]HKY*zt!q' =ƣpT(pmB<6O~FT˶)$sh"w;Gʵ>!kp&\T M GqgOYxUo*t9P*J`l~쾡}ڥOV \x n e3EXL]2VթcW \#u^BX_j*apw}j} X% r < gʫ-V% 2 Ժ#MZ*Eֿ[({rnIBIC;qQwCcGq._$pYxj(vxµ||3|@S,41 [zZ0 P ؔrPkmɒūb؂!y 1~vƖ,ٹ }&;jkpɞ4v3i52\'8ttl :غ5dL>OEppޒ5yG1 M.T/T0O7f!1Xϼ6t݃nIZH}*ګ )M$nLko]8l"(adbOҙ9&)7b`dfo4I!4&A!ޘ $}&l[jZ6 Fe:x#'AqWk.I:TPppkX\ֆA}\R@WPZR;3-wR{wiܟM]!f"Tv_/n\_!C o64cǧׇOonn/r/~Okʧ$O!Z(9J|8*o֬:]ʯk<ߵu0%6 +_.WuyeSR˗_ӗ]րqQ%Nzt6tܜ.7{=Ri*@x$^^?R Z\ yg)NcwD,Z]{{w? -K߿ysK߾޿}+.ph<|ʏ8ݼ^_v'zanWxVgpq7%CHI+!0fJ8|Ch4}?VcR+P@gb4.x/b#PvRU@CDdKMx*Tn!L`|d_t87B11w||ZS>Noz|>р/,ޑp(Lx"J͕!p߆  S4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ES4ESI;mIj=^xtnyxw=EO}I)Tڽ/@}HޛREP R氘>^|޿RR ~/<ㅐKnyer1=^^qﰺEqQJz^bd"ZkګCRn'!EHconn/Ƣ<˻=n!־9kC^^n?> stream x\Iq7 }00y>Ȇ5a}@v-Bl4Yx,zFŒssWgٟ$=]ݟ?/JZs~Y!σ][/~ɋXL!ƝKb D]]_*FwC{guxx}~sk)wy^wV3rM3ihnv/}ªzHzk"a2KDkn]/]>%nCȘwܰ+|8MHîM4#pBv8_btk>pǛ=0ت9ǺIН-6#bDxY"K?~:OѦsϯ.yW#cp:? d .&r7J,_s!dXK0x=m`|:G%l5p}FIݞb5STi!/'[|+Me{icLD(C aH p+iea:kWBP]UEI>@I]j)|̛OX%e,! B>#,q*d@]mF-vygP^R9P$Wo'P"""bzTah Ig+r{E^F0x')d00Cu@ X fk(zUV3|ʧ|HxϿ6#(Q#_Z 8gFg&~@ D# -d[9 g=Kn˻'l{2+@29e'qx8` b adHO#_s.;$B-ȁ+ ZV63sG[F8:%#JǿfͰ5Z LC i혒~w(rEwZ?{? j7q?kfoji8Wʯçwwqvk{G gN/Ĉf>cX@D&'|0F`' 4\>%}t$@gyS\TGO!BudE' 372opHcJ]`!. 8$ĠziS%݃+%!dY_р`Y Ow"U'ʆ6D:wݐ)vK^EPQ-#'nubMN.M]*w}XߛpҠ1v|HǕq9r*hHҟ/Vך? +h`|ߵƝD2Ys`lNӦB$wQʓx^%-giGf>ȁGrTqGe+>GBI&ۓ,ԀcY#Jlݍs8QW[E ǬaCjo DZW)Φ^\] ߶et)Yt 6.p$'nQ)Շxp6\F^L`^Hu|as0/Og8rϴE<03?U6KmR| 3 ֑kNPV:;T GZxXF€+^!`tW\Pqy4h[bDŽoQe <@(ny`9&$)1(5CdhQ.t!ucD?"%}u*?A>m"ƆiBĵ׸n%",' a攏]g-1,e=O^^h xf젣<:[g{4#Γ[f(ʙ8^i?k"![B!P^| y@ft8N-ƭo~ȇE~̒5|ac=dIJ5 } $kt9'Tm^Ӊ͔20ϵڵY @ҙXC/+Ƕx5(npwRf%+,]}L38Kݔ8 7iDxiM0:!Nl{٧-? LCa2-wP)[4qBp'oߧk3@P|+b\0ƒǫK2 oEզGΕMe`vvU&{~lPol|w<LGZt)aS5mHf}O}}[];FEKӃ5T_r(vPIJ.sR;qRCmy .--Ƨ4!jX ̽(ѥ59HSڔq2DXZlSg{JE` \ci~D'Wxҙlk)$2 Q]g.G\w ǼHacl@f-J͢K2P7HjCʾg CJcRSHHXD+~v]R5*E}nn&'^ʘ:_pt)HqU[HE߭lrYӳzjs|p ^~ HQVǙ<(Snw]*g; y7 ֞q#O BgYMaɢ\:6lP808R`HT>2vp>V@=}sVV SAע:>.J0pN TA;2[8{c[S4xژf~5 ߏI3ڞ D [#~~)FO?Z'٬ǔ1;<5c7yd3Cwazn[sIMoyk`f&'I9  ƛuFm* <ϰ Ow6#KM%r 3Y *V^B_PӇEkius}N%]ϰ.*$e5ZU8>su%)]Y"Q%tZoVK#22#0[ 1u[ˮߧ\q.}W.y3]2bˡPUG\.+2ZYQv ҁ#,ԑϛC7.UiM\Sjk63ߊhy?# aթrmpSv'M6Yt59ŰM[q*GZ0Cwy? c ?Sv}xfW` ?RNgE%ʐu>Ktʑt=k8?'T}C4-ؐ,B8.9"YE^dkئ߽b}Q!CaKvqin 3bRzWSH"JW+yHc{y2 X.cPg ARFIhJƅ_̀Ta+| "r-k!1ǻ>6|bJVޠTRi0lWya K)wwx}s- C>ʯ7 Sh>H- RtI׳拏4?vuFwV<ұi,T2G=^ 'D$!cOla~90= b%;S[Wc=_;>endstream endobj 284 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7385 >> stream xytT  Aь) P^!!Lz&3d̙}&̤MzH"UEz@PkzO[`{\sS{G@ Ba [2c&'9Oj XCKz4=0ȃ7K$-L~3EiK22eeE,Gؽ2jU5kůOذgcL}n3a_mҼb%1XE#V5b-1XGL")Fb1L, [sVMb1XD 3%RmbM,'^$V/{D1xxMU|dՐ+3\1`:r|R+һ# =w8?ʫjAjb G=!яWzE[9yaEduIpэU/:/D3붂ZD_@Ahw1&?CLuCCΡs€5x׹n4 7#>\ h,@qy-T!'sGZz֍}| 8zI3)i0]<`6Ѵl,>+{DMwRLkgj[jϸCVz2;Y{7ZFRbSϡwֲo P7@aTŎӷuH.#RDo.VQ-q"ˑ4[q"#~$<~{aV7dv@Y=ßoe4eQ?0WϣU£,{p;t1LD.n 좽Mi̜L.zc7ѬO/|v{G^N#ӀJHf_q IڑU4dY2]^0!r&?mXN*jG3X ,E34[3opL^wѤ|fUfFer"'/6mo,ŸWAz0[0dq3GML\ub$3<*f;aS__~!xԽ[ral^rUnCj:9c5?3gD3Nl7Pfh_\pȁ@`NS/b@*i, " zŎ&A5(d`7DZjUCIЩ<[5z"bԃn6K+vZ2i"# =w(yW#YYb%ELp7eo+iQyՉh):п1O~g'"hXǜ Z2;Uǚl*Yq3T |%HuT ]yZ_נÚKh""u@Z>~& ck ʽ`KKL-sC[[lu$ar::]j}cmXr=-}lR3KH}#8҃_"ϊ9Yws'nNؕT ͛dt|w@|immH`ؔa`t*;P@gəI;j:#: #H?0rh:leCזxzNa穀l.QlBty:uG֏AmBڵ ʵ[RBwnI -ԵK2uMmqG~וTP00?0\bNA*58]+FW~"֡7-aRqI]'өCMǠh+1X+;l3@:}.W}B2^397Rt`hGx+,lk~0ߝ*R;ζN\n=ʊ" @cF00w(17&< OLY' Zp8l>k=S|JIEŝr[`+k_)EY@8z[*IcSɔ\Πg eC MNmϪR=@. Êr?xTSoĊ JZMU~zsYMH4 )F k u;LBⳕ}i)aa$X0u1t٣?ษ j f6g9k@Ph2E`eya`R<5L!Ydh"9R*@㹅.췼yDsaFaJFX!Qn#9evk8-(--+.5f7fS\g%z`M!:.Tzd٧i^;T3ZZ0iKqz*pT<!nŭLݴ6vl"~q_'0Wr2 e})M8~>Ñxn´ë?8unGU Btz,Ԕew)z ֈq+r=Sp쥫0EgF#px\\PVoM6~47J]~J d,z?T~$1Og*&,lN4M.&܀R4K7?_OႧm瀛=fO~rBq.Z&:[;:\$_ddX }7M9f<4Jrjƒ͇QR z;8O8.㈫C_уO?Oɏ 8}b {b< BF(6VB뤚(^;r$1q@3:1k= V(s9Pd%vKy{x6v(r]˳d4MOeY5-볋ru[F㗿_5@r+Z'lg$Gj"q - _*Y/ewg{gЖ3(}MO^1a+Ra+.YXLJsC0-Z"銴2GƎ\ә] aM{VI |1+F.lb-xXYEu$h$GoDtm.7+dx"J޾qS Є)F Ih{`/ˁbF= Eꒌ4[y^bslΕ_~HO%F}|bO9U`P,9 \?yNZf2;Uya df> *D Њӕ֖'63!w:on2)oJ:ĂC ^>3a +eTWe=0DO$QO{5QZl tA8tw-$W$LJVf k:{H@=RJSKc`ԆLlrR],r5;u{lq+;%_{w8I9U,kЦeu;Vذ=Z8S%q~~/@ 2Nۯ3L$0RXRe3BaNr>kKg`@xg b! v[=L qsCc=ugc V M1<"}LY,dMFIE2/MElbJ;6`_2T:$1ix^I$g&H\mЍR9J!bXXKk1]tyY,B%Q10x Asuє6VX [7OC%v)|"j} ML|I+=1#Q9r~M)r?%.ۯZxwն Ojbmn8իZ/-4#=d'߂t sPؚ[hVF dԚN׷"43`2{͕k]Ő<Cn*p?hSY_6 Ń*F WhE k/8KvtGכ;)>__yyBꏦ2k.9\u;<E#NAUbA9dSxA*'Z=D&6,g>]Mz? 4{!Z[, [="+VdU_F`4̫oO&H+"_3BtHX mƓh(߳^z%#uiN4!)!D^YP,⧵Ai0mo8/j%TR :E&lj+/>3y$kŵ-XU4 yz$p z&>xgB˙W}3}5_znWʝ;'<&Rj W|Sd\ z\ |39k; @_6V]۲ `?9`,`ֿ5es{;^A4!剫*K+K?:.|I~Ln܎qhTs^m 0yʮdn2h5յ?U9ҦԶ/oKVrS^&C vJ9JeYH$ڏ:wuFZ)| l$1T.W-;`hMGzc?+ŶjKTqX5A]#º>;K5}:zHC`p'q֤e+Ԛ~2 E(7tJOJ/RTW;;#Dqbt:j*nPaSc$Z;YIBovsMWtPNu>7D}Sĵ{I9u_.d^ Z,*v}EXwMJ9٠iY E/"@៩HzF.UG=4G8-@EǜrjTGI ΊRuT:74G ?.>n \nOLB'x8 x4A7endstream endobj 285 0 obj << /Filter /FlateDecode /Length 4064 >> stream x\Ys~UjCUyi;NG,r% "7et  D\e wg> X KNglp}O|ٓg8/bp,~NLz>ƻ|8bY]h,Ƥ3ůÑd\X$| o` _Tn{1 _K!;(c SJdr9s 0 `VT.` CCmu5UgekC"PRsPgPyYLjx{7(0+[^'Jev\q| ArZn'j,7\CÌ9):V7b{<%;cLs(Oq0/Iބ*ֻY,j_p3Ǥd(,4 Mj hxMd`^#a8R>Ӫ>4t4rͧrW&}4J7Oto Iw`Fׇ.T[u|œU8/!jDhA+k@U`bW!϶M!*67"|/Nl+\ȽywAچIUrZp-X[{ۉ-*A_a #7AÞ>1H߶#[ʇ[W[tiGp8c7B4|`Xq5n@f3/\. hVaU݀c(o<xt[-7%F6k x08ph8@Xɣhndzck\ fXOC%Pclk\ǔwBj< Rk%.8RL6&9҆`)hW$[n+LRMQRJ 4mLꑞQG# Z"<t- GHYN-Smk "Q*3RѩH_9xc8TeSw}Ag F7U䴶;gt.=F1Zԁayr~>Tҿ$ QԃJIh]Xa T:I֓.d*kzܜ6u$`p$j;bBlr즆Y׬ f~U,tEM8J zv-C-eSZCuq׷jdey|Eqq`& h =/. ei.5EUvsyFa7R4F5yC!WXp:閸Tt%Z(y)42 \iKM&7DL U|e2n#zjq30U~{a'`/J˳n`pC^yw;`۹M; "u&:e<@s"CǪ?!0}Wi}1IrbGCm2)g3;,hly?Hl*-iYDj\b Չ)d)Mzٔ@pq,[~=/ m-~-UBdi<1 e<ޏR+B}V7_CMB8a>[`"?8˥?0~i Z6SyC@VMfNe3wuJfph{zE̴9iys2͸/ry$\$5? rAehߜ $k|^L` 3Δ$@ҩ=9e@ɛZV]mw)Tg٤[J :!D`69Z804&0 }ͪLV7>uY[3f hjf `n9@6IMZqVȦљRDT0pG `qIHe"( h!֡"[˷1._Zڎ&RI<5xJHi@Oɛ'LK0.ӾQ:h'ƴ|-t;|J3e:=k Rv#+@aeUGAq@[<-rm.ٙ|7urL8PK9}$7]DmPJ/f[G0}O,>+ɨ7R"CfaVwu4DS# ]'{Fϊ˸4j0jtMEwuQKC#%QCά>W.P Mm:( sZWNߦN; Ah OH aA}OFg+xcqZ`zʠwR 7>f,i 䚷ƌ 1s@fg-Y7ÂKQb䅢!/?! *C+!9(4#֋V8,%،2+) !ӉQ=GrOI]}{σ롼i`%/.y2rq%-d$0t X'3HU!6ތz2ckճ%f ={3| ̓SZͦ?qXgx~pxG1"ވB2ⱒ8APtlD*;$`l)˽{< RHN]uhUWy4cM.^ xPnT=~^$'T^ċк9Ӏb5~Ȁ0 `4;|tҡh&:^TJvQt&-3 v!2{EN?3hNulbhsrcTrc_áLV si=wak%.0zvqXuq̛FC_`|W'KjRD||w,}`[F_0Yb9 ZƜoR=]!;S-LMh7i1ܲap9xia9iiWX(BzXHCq, )hqR}rڌwBd8jwa1+9aQkZ,jnEZ,^puO<&+o ƮolMcx^9 =r^fXN@fUny<E\'1w\1xX aHE#O`L΃2yO}:7'ez€&#9}8-c}`g-,]D%+̷z8ZD$oѼ7 :V61j$R8 $ hX7Ͼ &B8HK!ty}cmB+x_GWKny?uN'`g%\`bFA+thdRĉ {Lme00)s'o\sX$5/.q4c6ʞ[t7<$amΌrmtrޠK[Kpäglܬ l.'15g`$^h :B3tspAf endstream endobj 286 0 obj << /Filter /FlateDecode /Length 5330 >> stream x\[w7~WGm{̞Ȟ}8d3ٍ=-Q*99i5{އ_IUх d0 FB#27JDZZ;:=8J;Sm<ѡ`t*hDOtJUߎF{48`K Z[}'tx:\4N+EHr6SdmB^6slU`gy?1NN;錪64%0iFriƎdZEhSvɞ)-B<=$nai(A[I`QMn1y7(qڂ$H %9 mWyg 4&ȇ~a*bK|qVjWd2+hp[9-,%lq(oFm[M:H5ZoL=*uYX[ YGeIba^T|={ϟ_9{Kڼ}?aʆs˞ qt:Lg:׻͐.Nmoow}OY;]AI l潆ȣ5( R(= `0+jݘZ^c|J'QG \#y 5>nל|/dvxj4@0ۃ eW 4 UmhxBRD LWn=$&6;R̯:V]n tT4i\ zS1~qY).&d&‡Z€ IIֱC/m 48WFgPn/WsUh^/gXGɲf]^n,P!r2 gF 鴄o{O 9xkԖ)>P,lV|ȠMtŚ2?\A&.])\'4p<42t^4O#dWot3$gԫwƻ[/E焽ߤ/<$Ec.Nt"{28US=ɺY%A:20i"w#1']h;ZC>Fsw&6JN`T&sc qwء,[$5)@tڙ6<,O9z4t|&L,\FJWf0h 5߻i xahϗɧIY{`;uHRŏc^\]EgDa 3%2ۀ1Ѽ=$?-Ll-u\9Cpd#ưC4YI+-~D,)dG'M;u`A"]g>vhޗcHvD?ъFgܔ$Yv%9~9Y-yaٚorz(.:{`M?f֢hF`O8!@f );ڹul?yu ąOgߐ/q7MQԇ7Tde!y0ݤ!,hF ?஄_˱Ĝپ*m<G&lϳl+0>k?joYm0x,&0˒@YEu\+Pa Ac&i5džTAf')'{#Z/b?/\P[9^E~&(:̑ Щ2+;و%o(͕7 `c' '30ݥjT郍GtN5Cd'FC aTix@)_xCsRlSPW&SBz`I*ABwG96|mhhLjLv .񬿎)h1D^-} fQnz\]zZh-syt f"ATd7i~m\l["po$r=!Nz-Q>BU74@k[y=C*? %$4A4Axxy8XN?y#rx*'sτldϋ›H9X|xdi#I U'+҆PC뢸>F j)`QK (?B ؘ#(.Py7/]5}%_aQU啕R+yIOpÇbr^Nѷ1o͊U i)?_6uF)bCQg-kgk~(RJ*R/i7hnD~byEƛ2:ITg :jL|7]n/619cc-)Dƚ< [[F&/+0JiM %nqF{&P[{( #;A$?W`gFn2V?{ꉎ1дHcz$@мgv@>=ᢃk醧3-ekTg_~'"rGl-G+؅WlcI躍"0,p쮀;-:G]mHvyOR°PP =qib>8.@~{eY"s B~utr= `i#mNp?55ۃC*Q= Ng>%'¿]u`*]raEuG#$ V")Ǧ<;=.c6!me~zqYxwGQ KړʩNxsxi.Ɇury[,yuBǿ <>3x¡Z u6~s83 d ٹ:  0~ei{:il~1gr3 Ap\ "'I|pZbշ;Y82t!4q`_v' l e<όqDW`T? H@[٘N h =XV 5Xi0B»@oah$D@y2X!)5=EdrxHN/Աź`ZO+nRGKvBד%w=H㝉|gi<:AL8u9w+?W~X:kO'sxnՀm'<9n( .D4~Ticpv?(j:2|3+>p7=eq1gB?L;7t׮ I-0-Z (=`rmv֎wJV۬рd>AX&MɱhHq>9Cqo[6%Ĥ{jExlLjW{# j$xIM}XmP)HMG!VKHt]wya_CXWGtZv'Rx~MGe2VrPMM5i_t[ 3W;C%-aȌ2o%J v@'fJ[?̕<[R/^Xcq[αVv' yh101 .p 8|F`%~x *Niendstream endobj 287 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 423 >> stream xcCMR8vz-  123OEpbcVs,jŦf,hjዸ⋴ #h,t`‹ ' <02ZYΤ<7#B? rGlwYx?{FvťbڽQ"DfVT@htkpozc,MI%ڧϋ1# :Q?f{ku؎׃$Ena}{mltNx~} 7 :7endstream endobj 288 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 432 >> stream xZCMR7w,  '123QN͋oKL0bg͋§j~'eg #e'͋JiuP~>}L讧Ǻɋ !74/XWϡ=:4MFkgo0w!¨oU CfQc3asloozb-N K֋06U;ixwlЖu4a}]qljeoYr} 7 R endstream endobj 289 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3766 >> stream xW TSg>!sJzFjZkNV bx" 7NAL AjmuڱRұڻVevX묹憵?{/a\]D"[fÜَOuw)V{{2j _]L0?QXXX;<{n*'\]wybd4RP-^C=XdR]"f^9{bg7tndalVuexzX AQk8y#LҸ)XyE[E`>:H˗*k7.:YA&>c´wXyz_%kuk E:^笕m?Ej&IMl)p6HƐ3'Wp#C 4FWOLݱ#p ,A X@U@`(φ3MvNs2Vܜ |K8R(ʿ~kCS Ci؂}׀g}1- FC 1!M€]ehcG`E Pqn qY$g~Ga';?>˪;0& aTZ6p_1癥WHN,qSʔdVR8 Q5߳wK%J)Q`) ^BO9, Un/>qD}~ˣ KDúw*v}@7u@]-iqɭk\]|*pQdSIa K!l:-ۆǝeqYj>|<#Z:0 e-"+)x^Z+\K2D{VgYyq'&oM972n󮐅} ӀKDxIYRWW mR1iG"کKV1.sA~ AAxBMRSܜІ`Hyܸ"^%o54d} 159%)쒈Н+v@HcRuRfW}u~SJl+"K=ᙬ`y9ݧ|dfLAp5X?iiljZjGF `HSl$ ]yyWl*-P%FmDC>0|"g)p AjCvAbΰUCK[|I[Y#UA$a[uD{hSf^/cSNPCF6kc!"GA8 $0a.5٥4[{_s#׫milz XS[oU^fצyiQӓumԟ5۷ÏB! kc wvLd:9/cX0z}nNW޹đ0/· Y}IEُ ZcB-y vjFUBŶёU MUU?ߠ:\WH MWD46;u*y)rTv68&='hJwuxV'jŇ ϪlE&, q񪔈ΰ;Ν |y&n6;Q\ԅYT7Xj*eQdk!#콗н8 riKgiYNn{(G{O}*>=OBldkŗ|d\C&d;Kj"[bt䞣pen>-Йl (I-$r΢#I>pծXߘL!<6Ly`{.3kSxܣȢGJ3 ڬ kH-qo~Sdkߝ露̾Gˉ!\HIL%W_o-k-Ia(k~2K"z6~r*_5Sm,6;ۓ3RB(򡶲=#._oצ[T^.<&'[\RYjEquamejӎy*fXn)ԼWLIN ]|EY-~mҞ Aua=|D={m@B.SW>~Xl]a{[|XK(5okB9|8=qxO1_. ? Gx 4IPGU2hUNA(o?7)Q UtL)`66 too%mV3"th|1,;s˛k98Au J"<$XU%j_P~^V1>8GtGq΍蝐@kb0RǶv BO93d.BqN1 "sS .k jU5ԌL2xx! \'COw%$3GCW6#/n([R _Ӧ8VNJ|@wo҅xaJHjw0RxxoZPO$Mvogiq5B6+ qᖔڊO|:"l&ƔRq/dQ*c؎]11ѭ*F}/feѬr̂בܟwO/HXendstream endobj 290 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /Filter /DCTDecode /Height 386 /Subtype /Image /Width 644 /Length 23654 >> 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 ީ1X;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~(Ϧ h"35ӜUcM*f iZuƻ~<ޘ|/$ěoS|XاNk0:@}Hë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~~;.s*QHS3x]Vf H>מڡ-ŵOM:úUںi9iZӌ1i WȆ+Y㒪Ȑ).5mIdmFby 6q>nLH)h((((((((((((((((((Bm_*'eX s.oƶ7o5= \d͑01 :ܬUS6s9 v=qܳwu ;l1'EtG5K4Q`<jDQI((ܥNpF88;1Hێr2znպk;R݉9F4sMB]:aרW+yaHj+j%=CQ 5`!.$ɮi8ۢ^ .Om{Nژb#$hR@P2On}r P;L~\L7Wqkך;xT圹5-5nc\cƯ]PI\}_ҹ+$*ӑsF7dc:=n̮GhZ|W j^CHWߒyct)|U6֯#?߇_= zLsգKs=h+49ӭbVJ?nԭd 08Z^&FWoH`$-ݸTұ͈J2:=KUed卆ve:ŖY&*OG)A6 g}MW"`Q'g>9Y*M\o eks!Lkkz|W˯̲_Llm3fBW V`i>Y=ac74L٨8PYڕÃy29~EjK} NeYp4g$΀5&V6W`wڍ5fuᵱLfp=p1ZԢ2Fk{\)\2)VؓW-t;2Mc.~Tmq %JgRoH΀$2\#B J@&݋n=轷{W'ݜ`I@5o\pI1@Fx#bq.c+3oZ$w6-ݯ䶍"frt 7c(CI-g'T–#xcwI3z-zO>]`+~X#BOV$ ~$s@KEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEfnkEPsl`{t+yDG(~";Ih7`:ᙚm xb8Y~$Dw wb=Տ+RkpƏ} x$W>HGt-GyA)'$ q# HGJy!G'ޝQ\u CqKu IKP]\-WId(˷'509'fǵ2[kt* h)F4`p@2:´m T^0Hҹ+]nF2[ڴ^8]&!1jWN}{W+|\Ee#=H8,\+`Ecx3$1I{g4I{=IsϘ]pSc&M;  \~T4zAZ c_}'Z,qmnwnyf``7,*3$ݽA18?S]Qjp]_DfapI8 ICw6B.-3O}ϹVc6v[|fs3W}IfF'fvly=Ztlsq2)oԯG3ɛ3>qOo,,$k@Aއy+Sd49y ]"QX/N<@#׮:j:̀CtYNa[vEF3kY.Vg.0ϻYƧS:t:n-K OMgV.%Ԍg|54/0w' c*YxN[==AgoR}iϩ7V%۸a[##h*ї봜$ķ,{VL7'Qug튷yamx0V'! Ws֩$pT)KWX=Dq[8+ϵ]A%l@^={WE[ԒBr]k{d@p2~As7Vav<S8f}'?ҟPIQD`2=g[[xG Ƹ߇?벫gOAER,(((CX6WdonSUOVnH)늓K];MCbh4j)(Ŀ7>* >?o ObIK Tp-{tQL((((((((((((((((u JM5h2#r:g T>3P-دcPUk:l^Oy'f.q89ʲ\ sx'TͲ7(dO)&J:63ۯZgվIWb(n{;^wqi%!5obnxO_E+F3(.0:=V+meo>EEXP\lh8#s0}«r?3BZνsU%=)̀ #2Im@ޤ~zqҪQ.5S2ෞH- dud%ֱ5մp)13woSԖ2{ WY{檱&F/=k26Ļl};f@b[prf\;͒Óի9TĊ'J MGsҥpa I'<޽$7J|tY!P6asDsT媃xɤh*`{gM I3r?l`TH4e黦Ua6>PH$K:{ o%,d c\}yNi/.P.~~KXelmZR8t4QL((((((((((((((((((((5tYZ0FGkfl>:$Mr;*i7`sر q⮎w*m_;vxHȈCӾ}ERWߌTҬֿ,pAOkިpt?vLxHM>mPY^xȥml%5¶HuFU\6xV6[$Gt:~gbHɏ2.N.Z}X)[6-aUor;?/8$ت2zqPCm;9+;i` qUb=ե\yE*꓀=+T%6ܬ2 f蒊(6 (,O$f=MdJ"30ݼMr>`? _bQ?! +;u>H>b&=)jw:(f6eRqϹF7jzޡr!3WIX6WɒD1#|`~@QE((((((((((((((((((((+#QcKd-HG:k^դ- 9JҺMik+I`>3nթPȻER(1[OOz%+)sd [¹{lmÝ]%a\]IcNH]siʴFU@G@#~$XTAPŸIK@(((((((((((((((((((((kzH)lp ۭA k)[t6-R}'LA9m(xRj ::e4̬R®p3k&ɱ@+>)U:RM8Ia sV$ LSj?- IEG#cqyֵPnV\!vUG5~rˇMis*M)r:z+(z'-29<;:yp\HqSõe3DG+u󩽷I.ot2G#wp?/*Wi9CrM,er#Z$b}V2~$YQ ;ֶ=bF_Y2F1ul:Q%m[VlP,qǹS)PÊͻEf27(m * EJvgJ%D[*ÏcXύF\!*# s{֪Ƹ+jƱNlЮY% KwjȺ9?)kOJԽu:i˕2jV/:%tt6ya![~1R9֓<3mc[zpx?5fNP"ux_B12sV:+"ModQ: pϸGGTŚ12~(⺌4q-OAm0F+}"Qe+loBc:8#cAxQxpnt81z4@8gjcI=&+[\4L F'׊*FUea dnA .D =4tεo%Pր9 =VrȒ8zڛi Фgs1Oִ8GrIU8H3{uf#?δt0zxesv1#G6wdg-ꪛ< ֎{UA鑜}8֕ΖvOrFT6Ңq:is=+%s}(ᘌIƼi |:γۣ8=pؗ$$ {(gg?y>e AJzF#뚷 5ZTS)۟{~t!XNJ r3[r')9`v1wS;Y8#<j3o$kӵMAq \^ѓꙫ,k(Ե JiJl.nbYճ'n;TRGҺ[9fti ħ)ǩvHAcH'̕CgmB"=RT;O?3,8 Ջљ1x49#%ˬ?խinz2k]?m.aZA~^LWH)(AEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPU5MJJk6F((O:Χ} XV qw"ne29~FZӥ晨:6v( =i"Y Kf9=jKwq^^WOȝ9 '#; \4?7S^M6,Q6(vw9+M4KTh%*9 t52NXQ_km,zOXHZѳ+$ϡ?Jռ[wQr FpW%5z ibLQ1u+v >BB ]2jv'Vy\܏NK4p{+Qm zU:v)1`@#9G p#'5Ƽ-K/wW#X~1ФvJ=Ԯƕ lt{I:QKej,"i'|Ϲ}" ghXO(sjgFitfxdT a~Vva[:A8*b+!n>y4Y[̙CqUMsE%G}ݽDkR/Bfiʉ Hjp*y) )L>8[j/d;qOB**vd*,ār\4|ny;Ji3G`JFq\ND:qS]xDN p9?xz3uV-LIcƺh՝( (((((((((((((((((((iۙboŒs@hGڭķZU#{%t݀{]½kKdӧ7z&==Fh|WQyQml_WCI@Zt:!nHcӭhEU,٢~Tn݈5\$ξᾄr+Jt` R0n9LveI'.od zQӧ5|}1 XaN2ÎFGCn=\a^ݘ7(#?󬩾ej r@)?3tcQ4ts$!Dҩ#d]_ 7z$d7S]dNXK5cFw$/]WV~dԀqUgD0y 8<? p8r5Uq֩jV G}1W#p"y+$.[nҋklQ@U9UxR68SV :Rj"1֧ywU;7v>㦄UEnHiēۼOїY7W(N?Q5T8VK>pO» 3碱N}ҧ[ᗦ g<DyUss+ rTjƻxO u AJ`d}sҹko1xfoP#dȵm KScW#f8sH}ze".!fѴFa'뷿־mmϨϘ}*S[lsLt#nBp}N+N[ $uE >QT$n` #>殎[[EGl@:w5 غZr(oz؍jm9qsҫ+%h6!5t9npG^}J=Ash:˴N̲Yc J 1,2stxAӎUp=W-@$Otm>.߶]"#26xG&;p;#L-bh 6d>Y/}OI%k&fwظÚn,o|}KQtۙZGv[}ZKM&6 WfWӦ1kH!H#`/;Se0yJpFx5I]jc6ZP0z tt0ATX!\#<{T;+{;>ΤߨfO#Hfcw5cgl{[Cm}9kLjfފw%$K9cQS{F[ 6u9Aו@Dqd|?"ޙk+ZP=nfar+Z85T`*OP`QEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQE%aL`iZA) EB0IR? ,PgKi]w4m9+ʹ9biͤK$y4lE?n.Z2I#@9[iWSZnGtZ)>_1@=x=85--A+v_9#q2k("8UQ t;M Ah_6CV qZtQ@Q@Q@WQ-tV`H #g=3X:;}.{MN{f c(h#C"ȄNFAA%q Yjl"g93א>ƀ -t p@\y?L)Ƞ(ѫ dRk%WNb{OoGuiRKB&B3?j=p#f/QC?e{)5Qz&l#@GB2*&o^߳Cgg3"ŁʵdgE[vG(Ks7`9{j͢.hE{uDrEk2R Yi֞-NJkaȧ6<P;sPt5 ).-zLT֚ō6>>Eh\w~)gdBs#6=zq+oC 4謭c˞}^#\+K,OH!^ϩ=I5i0 q<ST$Q-ܞ1MM H5Xڱ'jI[Stdxu*@XiZ\JD,UG5gLamfZfN"!I`铁Yoz"\'=qڴ5{ARkc6;WIc`zYF<9{R+ !> iQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEV6~2F+)ުGl@ H eE z1}PEPMuXR0AE:}:vӜe]$yCrckLWԭZܸ3#!XzA&o +"wG?CUЙZOh|?,r,d20i!I;A*zdzVwIHu_[?ֳ5=Qm|;3<7]q ݙROnX$'''>Fšr~)B0;, b!>95wAL]4ڌ2]O1Һ%9edzoo+ $Q ¢(U lXtSIعEIXc}ޚђ"F0FjZipy׳HNy,q9'XƾI]Nxy'ߏzkffۅ.䏙(ҪJe pWbbֶipyVpcsug!UB )QLAQY7,7늒w>q\C!WҀjWw7le6Ba `'NsZu$$ =WitMQ&aW7yJdݱ]nˣ/mh$R8@6mZ6\㺞WkSHu-GˆoGO~ݎEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEV'kX>4q$A4`u2\dCjtmk^6ڠ"8<' oN{^յZ|hVx0"QNWpx_z]GI;s2S G ;I[-!ٍ*9䑞k7:$>[-&2 όeS3u3M+(EivWBҌF3jiL;Z*Z{RRrWtR7F`85[e y:|;Ao 4&R, V&O\qt- !#P>R(<:\QiTE{m)hQEQEQECOֵmM2IpT`s[4Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@5E}:t/2!i>bx=+| kk{9lПsiX'"6ܬ D8KKK(V8QI> stream x3532Q0P0SеP01U0TH1230 !U`laT072̀X$sU()*M*w pV0w˥{+esJsZ<]86$͇]9>U6ݷi%Wm??͵/~/|}ww‡؎k[6sqmB ?"aendstream endobj 292 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 6345 >> stream xYXڞeav:I%Q=bK@1FQ( d)˲YzĂ%bYKvƨM4Qs, />3sekCD""7wS̿X!~j/BŨmםy8 b0e9(x!KdKC> oܶ\^;Vz]&`mǂ L8iޞ:MNߛ9jc0o7ޤQGJj 15ZEVS)wj &Q "j2ZLE-ަRPS)ʕzZFMS3(7=j5zGͥS|j 5L 6RR)F9RNNR#(;j$7ʇ(>T_j9gzϭ_m~},pdց9xC![f}wΡGd؃/ ;0!1'o7߈‘n#o{č6rUS~B2ZO &&W @AHN!MjFT=˪PCyth;o9 Be35&dpB ^$:6aGkQ8ot7?6A Mx;VD5?o\;tQfXBK=ɢ8,T5rx?MO<q}jן>!Am2AI|Ngd1_ѩ{` 5N ؉ǒ#~$6c<"]%A]x-G>(ʋYfv$,Ń6_n4D%CU9tq5h(z)jìYή~h ͯp#ltȴc#hٹӻsI"RH;!$ېy7(QuU!d{Y M`G0ӅʫS/nb;/fwT؆&>?rEtBU3$1}ca$ʽ?HއXթ:ٷ,@{/bFS89lX<]Aij黢tNCaĜTna3$g<'lϣyքo߱o7d\RYr~b'O(!DRzL#ԞQ^̞^d{A&,̴lϼEwxz2dFDqZUqaNT0G(kY[m5w?UcO~ YS-\A?(DYnͤz){72\KQcCRp:?/ʩc]MTJ:"h I#y-ufLOuJ)8bcgE:u?荳 ~XGT*Q lQT"ĊM $P B+BovZ:&p~Ņ|GsrFK{q"{n@ 9ܑڇ2c=]Qz3=Zp2TZPzIF'FS-Fl؊ڽ [!ָ$cE  ʪrt:}Z"'#xI ~\q҈t>H#K4= *CΧ\]*Ci/|q,6AQmb8(ر1A qGށԬ*R#fuww%=zI^I7]9a^Y g}Y']g/%M&e(YқV_whK~F}z YPio[ɖX4ܟQ:P[WπbjϙtQ-k"^f%B)>%P%#^`mO}yELPE \XQ ~ptx~ )|5hZpLyѝc=ՎN1K!$)C #Pi3ӻZg)Pezr#E$SI͆Tbi`>8tiAmҵk,H28>u6?ia_욭GN_ظvT6=uoX+b\_U 2 uY;+SZYP_ٸ&vw)߄ɋRWK1|d1ΞLoQ[WEgo%tF i*A1EEZ=JCiEy  ~^ԤKrUty=EmQWi as|h78X T/m:=ϞVB?|'9 Nj?ZnEGɦlNrXf-BMx<^" Vתpɾ+tA2}@wD ^ZBg HĿ8AByը_h>6-fќ\2Aprl=ny^%9բrX'۠c~7 Ʋ r@;GNu#y@"mdeQ+ՒȗsO!Ix=-p[jwpb7Q:4`Q/hB0#kHf|'aE66h+PU;"=ӧg+tٲMWnrHq`IX#(ؔhNv_k%J$? ^t}]0JAqqW/QjP0 |׺Cq+*e2q:pg\\M"Etk˿t,C߾Vr/,+.Mvuֱ 03~;/J}I_|%-un*JDNh*2_Sȃh%V$Fk)` rG~v]/SkY1b4 ɹ^ `-w?Ivsb ^6MkS*Fͨx Phb Ek5h= fJ7Ry+Ua5U;yYwdBAW3/?xS?gffg!=S=<䤏g]{b%{E;[*Qj4\`pRMJABntAtv`eX\XY5ՔzQ};{!&Ml SnVC O܀a]9\0rdX3;Lrm0Վ& 6'n g`$ZzK\ѭ\@aMey9\m3~B9?z/xYΩ`hN6A>$BKrĜ_OL y4iHx/މ F~ͥ\&dXhbdj;v7NmB췵Zi֌٫G'uAIJ Ox _w=l&vKxN/_e. GDQ?Ioƿ)"~7'EͅxNQG)LWjFw>;Y硅8)GD0ayoL$[QJ*>D& /[LIG!> &axMD ^յۮ 5~HǙMEI()C5fv9Ojq0J/j6xRe0]̖<r @A8w[W`ăP22(Ccz}AW~}}< ~`a ]Rۿ/|mp}ef0Գ_FD:ύbdJ♵Bu<+#/U2uxM3&anPu WˏA5GA~e"$t>!;SҸ LY4wD Q~3cnT:7EedLX$K>.lcJruEf^l3'f( ۛ -zxCI~v*fr!Ax vĹ빓 &e&S[&CJs mslmfd5U~bf 3OGhSTuH$dɫa \n VܿSM]endstream endobj 293 0 obj << /Filter /FlateDecode /Length 175 >> stream x]O  F]8h@({ X{ɽr D{Du:bkT#&H˩*}Yj4U;n0umYUBn1SW?`$6 Q8fjDg]s=Ukp(9s<|*|]Zdendstream endobj 294 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 311 >> stream xcd`ab`dddw 441%rgaae3@ryI99% L| % +XY4?3!#{7GJLg79s,;rW]?[sZ߱Eajɽӧ}ɽ]&vKNnendstream endobj 295 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1302 >> stream xmmLSW便bEMvtn&N.m *C@| -}h)-@[J[IDبlʋ8eem_v>'y?$1I=臘nXݿX#&NLXbؼ ^YDD|e ٺ7~"xEKG,$Db1,!%$t $ ',>|EFHNufuPTjhy3t90? -0PQ*@Ik}mm} Mc dC@Ul묹g;C@=5NzC#E Cr0Hh `Nj95+51j:4!h=CYOFMSAVNPbk S[C?ӁiCz^:0XY z=LX)"!aT5$j@;zZ}Vgd27;In',:CysGK",k<fE )MSK#(1B"f UN P pUOx2Lxs8X gC? Nw4jUkTYD#Jk]]6B޾12TOGie}S.jJ'Ω ym] ΝM ՕPB_ȻRR2)ݛAitټG)ǗJ}ݗj'2lhr50//zjk6Q+X^<@:z)6-[ uz4EŠ_~eqCؓ2X/8='mYX3H O3_u4> stream xU{LSWp`A4>B[6J6gtMn2c̷bEliˣ-ܯ-}R]U)Df⦉fۜ粹-z.=w~2aŽ^W B (ĵ`7.<=83ol>YZBz&A$/K:b=x#D|["f N Åm!\ $ג=1\hBt[$J^f Ysbl֞+Ք9Xdk!-KB|+d.kqAz(nIEӿBQ\U]C@i MDA5 vr5טM6d ]jIHDK2 S5em,^4,d Y[T.*2&*K,UJ(U@UJ\@m&6nAmi-9 Xp &VOerb0ൖQ}h@^=nP> stream x}[7r;?_ư]; oZX?HڼH$%旙@%x1V3 $yϬߧomw/1N?iwΝ[J+ɝsw߾ys޶P=~jI;tzfƼ26inZgvZ~VmUwΥ8ןk{{cmϏ?O9s<9^-tza?7!9oq$m7ZOd_?~82ꭙ_Ǿ7:KFk.z{,y٭i?ϏJ㝶/+-7G"9yhջ>K\ יm[NiI<-R{+|¼݁$CRF- ^|-gBChyOsh~m'Pc8|ϧm81wK?MTso#yoAw!bR6h̞TŒ/{Dk|ՑubBQUa`CYͿ>"4sͣGџ1ב3 53-*YK"ɓ => GB`&^n^cs,ՙK}p(23QjىD[('y4қ.],M,cާ"* ]6G]f[bVžkq 0h󄑭W+MLeH,3okOvrMKuK.X -ͯ9)iy'<0u?'^mʕ ]-LW"xbHtWme3DP?'NOh< 'žq(Uw8FR/HTt]f^^U?OE'y~!>L*i~: I|o༗@{i야zz/!A_ӈD轙 }*ʡ-7j$Ioofm|XCt߇ 5_TT~ t贍91#5[db?1͵вiy!㿚/T%%{hyDG,R-xSc;=]-q>_'@#4~pyD+|G%Q!֎3TQybrԂpWb b<_vV{aT?k3&ٗ<٤'gn\!0..dE4t}." ^!$Ng`kFЖJMK[ `Pgt-Nvf v}~ í滂QW})n WI5\+{.¢,p - w$]Ҿv)1Ǿp\ڋTpSZ.ȧTԓFދ2}tE5uކG<ߛG1-Nz*_cIJ৫Z% m,RKƸB~w5%-$Yܯ3[$\ SBf154ʪӭþƘ_(*k-bO@Xp>E,ERj<!0KO&h;x}62j=떼TG[H6h})Gxon-|`MAx"T+IGp,@QA3)Ϳ1z+Xa1OG_c a.83#AgIFT70=uf>D!֪G{RSCl7/e}"RaRZ^r2_S0̄5qy @ɼ]u=׎VXcPǰbsٛEC @{1ċ:JL)q$^_wttM[I6$-O]|%%ju.خd+Huyy s/q%\639c2ɓ|EC;"fAIgcM.biPV_=.˔yLCݹ~233/O[Ƴ S/R%*BN{T6?w I_v;s[Y֌+i묏q,7 yS"l/ɗJ9sKsd8_:PS' -Y H[*޳^1K.nᚷiJRrnƠazۏ?*%6idZBs;ypH^q/ b!"Z_iHriW>~kZij# MnF[p4/+_n zV,/}턎 ݈'ۃ+au]f^QV"MA,g`'9(1'9$gYg:ǖ?ed)+GMvV<|?$yXP'-hAq~kI/Z2~b=+b :S:tQє&WE 8P8kPUq^W',6x~Z򍐱ދd./s4ײi6eu%gi{,|nh?㓷ϡ;[~6z,;6{dWI~ӎGis^Nlp ^K#G]z:G|'d^OFŕhRi _Zp?_o?L~xD&] P_?J7F~ܽ}DĹv'+idu#yۀGWvMdQbFQdF >}̃j# ^3=.}N0x"cl^'q/Huw؃B7+\&0 jA c}'hxx1!Z'NjDHc }e2\½'r Y8N5$ۂ cKk}LZC:q?D ޑRɨʟ(8$J 8~s¹q;"ҝO0^!;0̏qh(~xF274Q,khW@ qR;0D2MZCڣ`S%*pn c+9!o |幺`Dr,Dr.,,ȨqV}&ҵ !\8!9b.ܪU+,縄lJ;ژlڒ-\t8&$ڂ F2~Y#I\l؝Kn+"%` ߈%ۊ-\%,_s%m$K+X$V`g u+ `n Uv6X!">^`]BOL++.r%VHćB!->#,0ot'_p*=+xbF:? x{x }ׂ+:ӄ$q_sυ^ DgE}!%D52Š;=dաlb6t'^_Uz?_g;] pܻl+=BsI!\`GYA茓asz%qygSѳVܚawq#aNY+Aܼ~IF(;&UB\ Nrz@lDpUxCuE#U%#vF#]2 SEH,MFM-tΐ}$ a5{+KQd$cد. \JRܵ! . JƺE#+RFqhD_)[XI.I4VbtX%A N"֯ymJF[HJF0ddl!*kꢱq-Au_$rU'j𐋭Xl*n mcƲv)J渽@-Yqw?67Ceb[n$ÝEohۑ-PN,@VndczT٠sZH|uiC F Q!銑hxYHhuz_V =Ձ9v_OvvH b!ʥ"wEMU\`OKx yK-Z*i]tﵛHmHAE_ԅF*I[R|ŝjPܢקPBR =%RQZE+7,xaZ;W $:8GPg.0a?nkyX#9he*BqV&$^ _xsHһ#3_YES*,E+O0ɐK\#f8Jd`Bx"EI-K5!6քI_(B*Nu$]KnqF7^hN b]0@IG"ӳ+#"LsDy! |L02׹LW9w%ֱfիWk*˕?)5oyPzyV&LqR!A&p6 Vwek~m>n )9+nr94iAp@e;☍pp +&@҆\8AМd)A7[cp"!j8@2FB@ dnOYl!vZBd"ذXX! IRAۓJ(!*['ۉNpJ!\N`uw-/ 9v#s/U_W-1WMc@B\,hد5+rX {=hMYEِNȐ+"Ȧ/WVE&!tvt,/Wre*alzd+ oWW,6k,V0$yx^@|.:ʏ*wdYR_?aAN9I9]y'$V pX}  ʲ44N[a3Df{7 ?^pCi'/8d pp:s̀9cq(rf!8ܹ944qFȐ]oAR(? Z5nCӂm,qa-G! ~$r~7-5^ II k )i@*ա1CbZ.n>dJ:M@fe:tEnX4p|:bS984Mw9qS%)eTJKT383zcAWh}HTDos+:8 $caJ,d#* $OhYRsRAqo ĩbIg5lEA(I?\ӓ*(K^vQO<Nr#%H)8)vM 8)W–?5N^YL5RҴ,娌sTMOjA%Up7tTbIxKe%gDՅh$K v@j)ȸd ܣDqYszΨ;Ngd M!#p-Ne0Hc[c0$l0bYF>j /r` 2T; 5 $ R`ҩ) Fzd0cg*RP2)V\RQЯ8>~ĩW!\7!BC#RS+s+C/WB<|qmEo-Բ= dp1@xCW]Ҭ㠝>Òjˆ+ZU@WMq2OK ,%.dIFYY7p%e Ks[/6pu)\pMPZݒ\K ,D "=u-G u'\ӧW,i P>E M#""OH=.\rt=:ήz|s5V]Nga!fUfdߵjx5oteGPιߥҵ(  vvݞ59BҎ, SkџaD8kH7 4 S h-|GvMٰڐ'W "_L[j!EP"co3,MV(n v6'y7SоEÀ%;W;f8*Q¡a<]5SƻS 1ƻ nGõ0 }@:fCkם)ρ4辐LXgN֧k~DT)[^-{Mc]&!F1f6 >4f FA`۵L_єީ iHa~'ĭH]׆(p`% D ^].VL(`%=t|D+N„new%'t ]:>]ΒNӅHGZ}Yި ¯u}"1[]ҾOhV.E}4Bd¯Nua°",iEqo[Shְi Q<:uus\6{դvRw˟7F!x!!U͚6u? $;$j96jҰ+Nݺ U+~D4@tvH:[Ze0_|ڰ۹pBM!)1SP;.OzL־$N>q]dB >M"OcduH`}(wF8Mw+&[E][Tb=1>h ˵3Hr Ү\0)>hA [ |EAt}byǧ50+Օ #1#005c #`F}q8X8St$-n12;>ܹpfMT<*|%q~wo$w޾xXi99wc}~N(v:j6ݹ:dol:4ZO9Vk=J'-F Ez'NX}trz:|.BR!UZISK=I'h8JK=O\tzޠ^%6rݔ6RBKtT0jbO:R)HQm'k' XbOͰӺ{i?^=ixdezO.ޓLzOɭؿ=ҒO|(Ŧڢ|::HɧKtE8Ы> DUdiW}ȕnkZI / Ы>gi^I2UfOTmO"wOn^IzLiS<$EqS$]tż-9uBe,5 nM]v@p"L a0 BH4#>o0~Uuqƥ_NJK()'1.ND Rl2ї~qh'ntj~IhY6"roRW_6:k ;]\T骽ĸz]^Hjp:j-<Z`3HTq+#t.YZ(QodjoCe!i 8 8)ޝUvܜ?oW-Gt)Bb- dy'VrV>I{O+Ð25"C?[4Z|_ۘkY7Z76Z}TlɪMo˵,frhe!dYf,pQȦwZMl mzWeAq&+ZikeAޑkYЦwZmzGeAޑkUfpUQA56C \6]2\ˢ6Wm mK7!'nv/|ҠҬoI'ז]9]gX&u<&qv>ICv|4EvMѴ{=t7D`X!{M myvTeY)g: pTm><4-ݐ#_cQw{Eݍݰgs'3ۧذa~sw·,0z?v]-\$4 ٍ`wd)nnޙv؝Nm;6zǰ !M݉B:pwMOwLx;G&A. Mcwzq nӏF;= &4vPIxSY#ܢӜ xӏ޽wЫLky 0}Ǘ<_18VN߾|y{Y~/ f:zqPĴȾ|/Ǘ<uKc~? ɂ&ce?z{ӓry:b͏x;stmm[endstream endobj 298 0 obj << /Filter /FlateDecode /Length 4963 >> stream x\Koɑs#lӘa,lË=<>P$EJ;"2*Qݢf ŤϝNؽ煤I?)iEzCr筜\ AJe'+/_dbq/C˃vRq{UJx A[B8#:EwRNZ'P[%FVڴdi aݜˈzͥ`%y |u#{.%)paK@b}`i`@#/"];DJMi[\ήQR^!/a n$-26$P?bvւ/ײOZP8$-ѠI~eɷ/@t EPdUOl=̻Zȼ\P"!%]^v|z.;E! /*4u"l^gfbb $l6 j5 Vf溝K//*L$ƅld6)/&fT'P)yg+;+ZI+INRK6y^6( _Ĭq 2e>X~Yod묍о}()KMbX}4Dy¶"h>؎% å/ p3C2vn0I M*E/Zx8I$y/9VMq6 dD;'"˼)]y?X]~N.m` >jH(Vƅ5=BjCHH q:|D\h2s]&?sGq$,L4⧁[k!ke2\ZI/Eum+7ncqL[|Fns<_1lR5H __N$y`t*B4KZ]I7/C(#lm#Va'5 P \$I+wB ů9T.)_& ^(1eBTx .<(!CɇηG qX ;;2]*Pq=$mޥI*XI7@qU UàqF0hN,.|r" l4qg $.ڽdj?f7K~TtB7Yaղtt?PQ&ѵ26&e"?.Ht?Va~pN˅C+l&Lc [mtp9l΀OmdU8Ml5G=9#Ӈ]G3lEG>>B7}\;_cA.,nmdP3 Ҟedx0$MD6$ iD.BCDFj:g^D&0We]CY^X&JE F LpU}uE8yrK^`VxH4FrѬ^+\7NkWP&Zꕮ#,{xˮoZeLϏ%P~iB|AaPʘ5s!i4UyƢ!`8W,<洟ڰ1A)%my^EעHQʖeP~5\D 8i+]!f6Cc:$;Bm8c2!t}fAfHi, ю!$M@gUx?fL {6Tg^(6~PaJRYzYhil>a,HQ)>agDSB>: 5)r`(s)5EkDOe޵cܾ]^{~g4hiYK ]q'; ()p($R'yKq1S46a_&ev}kZÇ=ކ5q?V=5BאtC#wb$֝POCod$ Ff~(CwطEq7v?O5մOk2[ =ȨP.t#AvL>Siz5!eK t;2@HGFQήm)sP \Pn&FJkzowk٨@3j,8 ƂFϜ*(9$3U`Ք+CJPZwʚ)|7Wv\I S5j|H S}B%$m8&@f[ k#F^F`}.0%-C}J/җ~s(wk7069`Et7fHHi3b;d(|c$,^uvF!6Zv3W.o%eC9# GGt%pNx)aM}tSҶy$ȔJbUlje[*eGӫHR ",PM! NyZ贩1})SˆN#PƩ9nBRrӹ3 #n1\PGd%t##z幅*=OXM/iLOK?uc-8-JG.0ZmvoaC] Wdg KPʃǙewͯEWdN]j}g & qpvnI_b7=cKӈ}4mAia<3%܁$SHiV5'!Y`QU忔ks7f.S=f>{nm]mF?W'Sg@S^iJϧ%y88 ټ5I(2c]:N1 "0J9y"}y*ժ]׻u~ͫ=_t:Y⫒bjg)@clk+Jf?W$xt4__ Kendstream endobj 299 0 obj << /Filter /FlateDecode /Length 2762 >> stream xZKo+X 00g8{H6iW,"%mTuT?f$-nU|\I^/ fWۋ~yEWNLzƻxk1.|wn{itw‰db({Tzs絖p2wØt מsN{-cǘLߓU<d.?8ΑD&~#9TwK} Lo|ı0ETJ3.9I3kG*swQai{BZyM%d|] -Od|9#1+@.?%)bDp3,;4,[2ޓ2Jb5PiANwD*NkQ>S=u ׈ǵ @J=,W+ G /obWXpgv\or2.)ᪿ~<]h}ig.Ҥ?r=' jnwyw7fy+3^m)4QI7u_c:.#)]0q&3Xwi6HWߧu5Xqiˇ0j[S1F⫁A uUԗ39!SBH7v )RlXeI/:Pm7$DpThc doꕂ/DQ k 8O!q/$4Tڮ?_lkqA=+uY|MQ ^PfF5>hPi| c3aJ"u\H0Gİr:|LOV_E(,g8A/G . M%Ҋs >N63[XDk.#!$j@?ucUт3w1ӘzăY(2h J ໎7@Up%7\dc74n(<<m<hJ@`]pWܪ< k-c)s+͔)1.kdtu{ӑEUn1B3uSlsS-S  +l3N&Jz \5:cBJ"\y}*hyOQ#։'8elr-(IxjLfl6 nS fW㱆A$sv ن~"xͶa"Y㱮*Z3&2xhgv<E b3xdJ0^R@ϨW2dpj]5t3Jw,ϳ >V ;i܇Z%;}@["6u,\Cd6%~QH籯V,FIzyhik3%ņH+%R32^@tHzQ>õA(loO4R ,~\yRC(h>䢝A^םs x* |HRVW\jݢI_Sxo;,#!tܕ~\5a`l{3j$̰;%XWoyIcX٫ v ?S/ffCM%R[(bTN 67<@CMxD=ŎI1+ YG}׋GK0f{U.5|%uo* օ:l9|ꡊy~o-KZ!otUD'%U7Z>]hg+v\NJ&KWshUjESfҩ͵3ԞQU!QsoSK‹ m3Gď@|h1l=r8!p52aㆹw p8+Wa0/.d6{2~_g27bU@>JdZ nLhlC {i,3WyКA:lUee\74ȱLKv(sC>E@bu^Eṛ@ `#ߐ4+9$KEVKțඑY ByIrS*%\GO@=5(Vus׵F_NmOy׊>33uD 7zUqH7fNO\!W08 cBeW={KܸpUW>Td^)<9>Нy㺆 lE?W~`YYX-'AfB&mcZG c_Da{/?x5endstream endobj 300 0 obj << /Filter /FlateDecode /Length 3324 >> stream x\Yȏ0b AjW{YkN"# Lbꫯlb_1/‭^tUG}cWk:zu+&=_Yn8z|7g6(Cƙ]9Hx`B'tsܭߒ1؇3~qN~xm m78um젼[___6w_~83Zu~uO` 8iiEk;xƷ33d" c;9h_KL$uڷ+PE 9nŔ78 kN2fg$=cF:4EuY m\J81Cy<9lNqaJ:W? x'Z_A7G~ vX4!څ09:q*v}Hq@ƥ,zx[A@3ѹVC(L'q`i=+{5hS̃er`Ag#Wb͡﵌1j0J %g5m?` Jr݆ˌYmHuU'a! DCԸR;2DVPl32qk0u_s˭@$tXs"Zs4".~DM V`Y WRAa YB 8)u46GU "/(2򡟃v 2:"*cҜw4|Ay iG_X0)%[+X%W|Z3=*89^.nMfsy%$a$2xcv|D^LMF3DȈDn}E;L'-n!Gߣu؟ bLhLϣY)VBw n1>If'5ۊΑAsLÑqӮ=^ƹ9%8{8dN{#hn8WoU?=c~Q(ʜ=~]E-NP),K%p'cpJ pr8NHDt#$3 Mid19 noxF2*0=֋H4`],)@(w`a-`!fP"-%Hj1ux5He`*ǁx5ۑbc-iߦ6&o|\S\l'wM^UJ ~N 32y|\ƗsZS0yLcYX25v٨/F߯!@n%ƏŋXd?P0!3{{Qm.n8$>с"Cސ6͂_pFF&KʺQ)ǜ܎W[Ӆ&[h礝i6U7;XuZ= Q%Xla[p˧KJqo:ʻ+m!@ڕn/ 9)qCU%z/ wL-5ٙ"O#ݜ]9g%Ii90nءx* R#M3Nh͗څ+RkU N9^9#\w (-y>3!5P zq TĽV"Nm9JV?D+'oU\D =O>oYE y!x%*X*?)û@?Ep08$̍V టɾx݂uL֌G4biU}xNKg8HX5E5=y+ts,v^rE-+!pƳS)%Wgrz,n ǂb hxǬ1t3OD ,T`~4UfQf@ a-CocJ6:kx^]PrߢDv, mRp](Pcc࿤PgS +@R R]-8](4~o0GFt A_jP}Aj[TgOoT3hp?w OWy:cPau3f۝ށ/ƨ}G} {N [qd=D59r .>:",,jyvr(,bKt`i.,uuޑ9"  _+vfK҉u)@V8GKe̵`mͮ6*dK6ϓ: hQ߷rԂ) X.x\~\t-p㼝s0UW]U"b_N##DhXN< 4Jotڢ畤GmOK9q+"$]=Xs.ܸL8#Gr G ;.\WB\t:@>gʒsc\i "1{e i״2KW8vx`C/bS˹naQ,u ^/?i1փK1+c!9ǙUem+Э(0P"^@Б//rEc ْTI{&JT.77zRQɟQbBF7$-DI|#z|}ocendstream endobj 301 0 obj << /Filter /FlateDecode /Length 4302 >> stream xN$#&^:uCeD"D~0y`yff_9.ݧ.=Zu;[cc?zzs狣?`QXtH%/6G?ws{ͻ^9gyώ1-L9.lVdW~|}b@:vfÓq>3/nf\0QݎO*Ƅ6Y^ԓ @([hԸeG}I6:Ӣ& J]^(D pm_ $&SI F'9 dyyܲbpv\>""܂G`P\Zy07$D{uȭj`e''mFv9 |nEZ37(Ryj NJ8 ArJ7{ .fyG v6]рa[EP2:7W 4#uTbaddpw$RWTso_XKCtsz0{7j>P+Ke^NiK؃D!fC⑂'bL7?sQ"@9:?d7EO){|;͸Ӄ6#^ mI^Bl`ƁVM]\9}a#sk]0-9.<.쮜AW!I+3*ƾQ~,lFpHտ^}R|vS>b6W!䤞@ r^S_|F2Tc\G@2H3TR0FnVI=C EJcV!.!udϬt7DWA܇wN& W u` jG's´-\:mƂC\08cxi\9?Fm>dwA5-KF4oޗ1'ybo$vEiN4e;_G,2<if˅ 7wCWμ(ٳA"LX-Vr C, )SCHyy=x/Qջ+i`j,G{6&uo \M~hl$v7M_K1e)dKƖG~(C6c0R8- ( őtUNfv=c?Q^H쵟|RMoڍi4Y369>Faw.؆uXO#*Ƹ"^6FuѫRƓSA@!jMb9b^s|R*ncg'QN'V^B*"SF1, +&@cL?'>9Oa2ؙ*)78wU2_d!|o<3dTCIq1s0劓[+djphgŌZՌjqHl s"6/}LRaF[T\aiflds!^*~6Eȥ'@b(Ѥ ,Q ]QU!Nh*N|f$!t2+P! t14`-պP[rLr[X#ظ'Sb)`lu("zEhǩlT^298 {dk^:U`Y͵4?Ί ۼ|gH _c9e. R.Ǹ&זmt{˂ز곬'&t/Z kr.6z$ss9`4SfaNă!鞬2f;:ڼ},fy "[rW:x,7*c=:^P/RjHB\ bu%Ų+!Dmey [;ߔā-={3~987y0yٍaӌÝaS}QlҟH%⮭1SǰeT]s.4z#;1BT܈]iamUg Je܋83@[IAC< Rʡ0ԁRYU&46&x/}mݺ x>Փe5J<F?zYI,a~PJ 20spqs_% ,+;]{I PծSO!E|xJ H/P ™e ~3؏'mR!۞HJ"EFJS3\9=mFW# ^y$ ga0 \ <Άaiu<䂍N}ᵜ$aJT`ofy) rEbNMSUVnR6^rN@$WЮ RD| EX9ߔj  6HB_n ZıeF׸$jR&&e[5Nᶜ39 YխM=򺉑3oW H_zI 9ʢ5` *+S-U5ƏN m/|بٮtio̟8xOi~]T&S_.޶|4ɥI'zD,>'ZqWZgYU8놜@{ ]pC+@B$'NV嗃~a/p/$`}8Y#*CxݗګO~Th1zQׂ1Bm:XuLB+= ~F.%!5q坃3;z}R@IqTEa9>13Z[V߀Mߘ^-;] *E%b>v GVhs`S~yZ>ķdޝ, / 6V0GlbQźϊr7~quxp!|Òvgb{zon00H(MG{zIݻft~rmV 6!%*}DRxDJ3_=n.PaEY[<'?/Ovˇ$햏O4~wwZW?hXvݧnyʝ-iK@"f3lYS2q7ry.!XʜW։ԗ#GpxD'XGD7z,2~ py-< bfetw5 ko6䌅I(G!x2΁v,wۻzuBV厰p{E> stream xZKo#3V>Er_6E!8lA-{Zg.")>$j,V}dQ3RjAfԎ~_fTJ1p+L˒pCgRi5_RmLA J,%- , .|f0^ɜUH_|(a QN`nYhǀ8X !b'pYj ,z)MB^&ŋI/`v,q (UE(3 XO;2$)I2$BLJVe8ԴEg/mMA0Z)leYi>YdK vրPÊ+2FQX@P<-.D)B"ƑʔBfM#+'䕡~ep?$&05(<'AsTYEilӔpf&d>ydAN<q3 Š[g0/~pA{dMb"rViSJ)]PrHꜴ`^@No (J6p7 ` cPn=>]9}tqgmٵMKh.g}QȱQZw?]T4cLӪYקnj\A>xšY5S~tnmr6--#JŪ$1>0[p]Aq"(eav]Bb]wUs@2w+=tS)M9w^EN5$\DC*~GANmD/Vi?E=s*<'Y~")!6X.b`޿K!Wl(۞"uܴ!ƚtCv2ջ) U t@4**oBY!xlDc? HS$Wqă_4 ~1c\滆JH8'TxшKboƵ2}wIĘJ%7!~o I>4>?qWbcrO +tB})bIRB K>Ys95yb|De YٴwL{G ;Pq u-qr/ˊiB7ߖz`( .lѿ^ &ffz)f h69~7+6`YE,iJMQצGUf3Vy*O.&i1ڦy‹(ђ既v0ê&ܛ3w~:*)y3 I0`Q_Z)Y*H!Z&%@:u0c4Qʮ3j]Bp;!:cP>։n4`7aw״w䢜=?h>݈n!/7O: GO gIln>t>֍.cjC/.9u =R3yOE|r,^)7PWUZg/  Y^&>LPƸL? r ؞*Hÿ&*ƌK $Qr]QF1X *1D <S+8ߕ[Q:L]j_k 甅Qwg cPo4x@:~y?4p}vg yRN87U,35>>Oh6/|sx>9i0}?81e q<ŵ}"&g[PAv<9c#QYZ;qH8Z+4{/Oڨendstream endobj 303 0 obj << /Filter /FlateDecode /Length 3410 >> stream xZY~g/D *3q*J:y@Rk2ɵO7fZI6F_7˔-f¦7_&<|6/.'O/ۅZM/_O >uzSx7L~hl{=9zy͌ p7$/7!)9~{E-2wQl^cr!Zk]\A4ofsiB9ۜI!v#)*H:HiwF6S^ gƿEjy=+/<̄Ai@,8͑L^ș^y"]"5{{Iy%,LMR4:o$XX7xycLfN~Xw pW68a|wdA#v2(D84XQgk~T̵!ڛb$ Zna/8m``beqȥD͇0Qp~fS苬@W'#|O)mi&nn~w/V(/0B׻n9#_n#IbZ\ȅS2"ܺ`F=ݢ,*yVim.x(]@6oJ YYH׻f Z=7CbLhof!8Y!=nc"bD~>>?gIՓn:xyf9 # 9-y#|EVi'Q|{^9y'Zl(RÜaR"ZI*) g~,u`?9ʁXƫAeCPF F'_-pnG/~^\4U(y<\T9 jm>5pPp{kfrwyl+5*!} '} |yvW} Y㜈o*,kxErTMJ%H8@s"߉0Ԛ ^ QFu=NFO/xH vGZD#wU* S[{Q J)XGp";gځ*)IU8`_Cwg0MW+MYH^5{s5} M)n>uSƤ$xTt aBVAK k<*Jq/J'׋i.QJ8Z/%w4 YkV7 P@a+ۦ ϥG^;2yNRc-L~io(Uϣ5MzH\c50RHF+SIN;40(nƝ)Gp:?a?H*q XCWl1VV4f< gA ˶i { '˖mʛ_ʝM-Aw\5Б/( fF䠵1֥-p8cmxmTz\j}Dy~y0"Q{ڔU`8nɱC1C F:u4"3 5Ud<Yo~uʉkAGQG:p|Tv(9+nqqc#[16z8.tٽ~ʍ2e4BD!p-9F>e팫A0D ol&!*'˛K|o: b\պ#K^{9gsC%HۆP=5ث:ib!?[s%:0T4< bpd̼>/F1S(vrZp(iɑ? , Q|N`7w=i-B4ռS&B'L1^Ln[Uސ pceљ[YJ΅ZXSO*8M63rsӌ{A2' s9jm1>GK<'{bc-VU{K%Sߺbnrf%NfZWGRnmF-bcPh򣸗5׉]ӡ4z֒ӇBos朱pڎ+Jڞ]LAF2U[KBSȭB-h>|xm&@:U7=U ~@q/wxѰk\ U[#kմ(1c(uqEeqB4bI-sN#c"E%.t t:#n>%r&ih 2ڶoBě7!MD}AãzZȇ>NS"}VJ . }Zr>s5沽U!ч9"9W9x Cm`wcSfṔTX=mbGO#n:KC(q(5cn&Y_'Nc\GO7%=z=r"ǺxA m߬wAϾL]nCfk& E|? p {ب?i|P5 CGQ}4v\͛zn-mu0C*9,a5i~~C.)tC+\~k!kR(I:ЄRkuUn?\h@G*8`ߜPp8 ߶],u%A8h³S|g{+Cl|&Zigҷ$1ÐȔ 6*_4bR떑^>#):+>NNƔj?g*4iU #/,d俖;aFendstream endobj 304 0 obj << /Filter /FlateDecode /Length 46798 >> stream xM-m%6b{hGUYXP8zCQrdNR{ݻ*XXD"xm>m '?|?^|\^_?7Fy֮~'?>mk/~]ؿkwy|??_O=o?'?ic_|o鱿c?F(o?|͠e Gi_]er??7}NU3?z(o~oegLCΧy/?W=?Qs83{՛wf?}\s'X;udR? {~?&>V󴂟1_2_?ˇ5)~`b]gboS7jq1&p|}RyY0~u#*!u+<7#{<ٺk8Q~;}oy_i\fS״ĪˆO;ۇ<_Pٻ;}vy:_*|UWú*a|"W幎o% ; WC2ގ#ϯP}s߫7~٧sM7^;zӭ+W_>󤛧W|NG[nCH_07 uRk~Ngo 3^NZ鯦z}Y}OyI(g\ ¯^~G](KgG.˸) 9. &LG|Sk0s7f[ wyUa5`TψK+oIw3c.ysa,c1Wx0]~|L.)2.vWmW?o? CVs? gɿlS޺`6jCOCpG<%+[f^NCoLKyT{>_|wwC?/&4?uhuU >hu}Jӂ_2' 9 CLǓ&KE|n R)֏[^ofQ`^³KE$|n24ڿeou^&;uu-<_4c.y=_s<lXJ34?/%zOm/Sbm pwOx5`܇tu_(g ߼0ȟ xտf@Ų_6h>>t_N?}n4E-IDK_|!orgO%=|4}}>]G*>_q(=/:Iᦱ3c|4~`ܫƿ6NIp\U6qc ?|Z>_DO7?WΏC6NzVjNO)_~>6^D)o9GO}1ւՎ{S>~n\a)zGOZ>S)xU=>~n?otJy]mV@;c?C7ONE'@ZH߽??C96Hn'478M֦s؎ =ed*` 9H;f9ȿYms;{d N~׿ӼX 8X;Z"m4R@ķq\"HgӉNZ@@G,F hec+ASvghB4>6N@9!vp;dz½u8* z ThD(ߐ0Fc7~ί=-RgNj/̞Wq"}G}CO(c9j4\̣1t~<3LJ[ᢓ/{Gd77lq⁐7I<:`~EFeso8>$Q XaP/2(Y&OcL)@_pdi2bDGDxQ%2bDGq i>FpEd!Ye)D`9G@\r:y0(DnNo[ ?V'f@dy F2i1\CAKw6cLܥɨΧ`eT;Nree{ ha""Day&)_iYZZxT~K3Xi3jTgo XM?6}t3h=t:mD{Y(+ 3I(MHi Uz8EGAp$zʄ#3uJnޅnZgʌ3q7s p'l_$girYz~i .0wL*@>%{`4`LLψ$Ag4kPXW$G_Q\-דvO3:Lex\h 0a7Lu!3 :-&dziC;J pυ@i-LxXU "dK] 2Q7D -<z/DF8,@&SP[.16^YKUTӜ[]atB %rm/2}*[K*hX-e!deVZ@SYeV8&I@`F^x2*aATM1. ?eFB ]b@4>wcyYE=\egGU`_JxgyUE5Uhlv#ȝkyUE--}7kZ^fUQOE-9tVP|>?Y\&*|% $r+U(  ƝnSiwPC kۙF=)Cda]cSvfeN ];dEqg[;3ݨ)_jMT&ξ3ۍ i(z;:DB+Pgxf] Kނ5x2218 nT0⺐;j>UD3㍊Z.4R/z <1ި'TQ_9ú3ˍJ' O/5ug{E ]+C\&5n# _sC[cHySvV922sޔ&π厌"\n<8 ww6wʖ;2^@ {Wu]4spܑB*l)4 @ -D$,\}gT##d;2^Z3OPLD3PG QOڟBfZx!ji_F \d=4o=w$:uhs*43TB=2f8; ^;SR6uQC*8Ae"h7޶qA/8Xpu/5Z##_}0n#kC+D ?ZBveȥd?6H瓇£:p0:jh'`/y6qS;qK#x"V#> S>n49epѮXSRvH$)秌|.r"ٗcf3;HsIq1OsM5 4f)cEv ڮz"2G;^S3¢pL*.rt6V@ODLAǩ 2މLtՇgR\ {2 y 7 Xnx'b`uL9w-7e0`.zId9fX' sKhMOb/ep07XC"v_"y)%\~ _YLLqX5kʥ>X:$Œ^FhcUS?e1}ԑ^FhdYa0}lGzEz2x1_ji_@ Fb2bXpnuU`“b$ߓ_Bl Cz(2^PXՄ! V8Ȃ,:uE'ҟY̗Zʯ>Y24S3p%P`0D`/ם(F ev`\Ɨk|kB`?u)ԗZD",<.R@h<&fQ;u]V! 5pjFd"ЀϰjƘd$w\5, 2 fQ6#8p) h&,}ϫiFRX |3j™68q=c*M1K|E2p_%WuVeq`+|N̠7 :KH-`!`vy^FinC㗅-hk 9{ kG;M%0PZX#Ƀ&ެHl^ibvC qL-R]3QG|EDa,eAt?fpi/㴀,ہ_c"(1eA61/+I *X_3u*M{qjmBy` H5c̀}W|Tf1i.'ݓ8 YJ2"lfE7hK ]F-siH'iF`} T,4(g(5ˈ856*[p[Py E ,w+YE"x,b`O1@*VIteԪ V260Xn "N&>(p4CH5xv_XV'=xRvO(-N7)zm8/᳈20gGzE_$]3^Fif68HB2ڧei/#Y4!E<C|MFCN7A0krw]2Y5-o2:dQkԌ/#VG8Wp Q fA0;]+jƙcԹ*. KvWΌ{Ѝ(vjƙbo7z^b)Ie7կ[w?Od!w E60Zϼ(/g?.'YDj@V10uwYMU@C6260XnW8AOi-_Xv j?%ak 9tQZt7'wg"aG""Ζ[N+;H-" :8Dk<N(*`Yty+F Ip(QdCjq4GBܚfDZOѨ+N0TfQf&mjSsYZڌ[d,v EY3֌[n%Y3֌ 6y8Us'YDb'0xJwE٘zwb@c~GxE<?F,B,ɶG;ș%Vzrt /Q3xgŌ18M3^Bg.q=# "py~Yet1v%0:Ee<+$OȒ^FhvNyKohzݑ^Fh.lh# GlI/ᴈ;"1BD@ 1S: +wfqԔNDBrz$>!Ynx'ba#66}V1ܔO*%ρc^'}>5`ǘ+%xpcev=0u12GL Dg(\U2։pg9$S V,3%d+ l&-/eտ`9p2"ڵQN@uעP0i DzzNH)U0z҆2Ɖ(xJv.i񵔔MlmSW0R6ny|C/ld )cԓָ(RQr R7 gV=lO!h̼4L&Z42BJJ]Q=E:q70BTRz7QԵb0ާm S9 'chhIE,qdpS&chcY#c7:\Hlz6cy#ㄈ!iKbC8K)DؔN"ukwmsdqӢ5qW sdqСw;Ȩ!h*=%Ӌ@Ϛږ<2brRvu?ydyNռE3=Y'hl`bֶF%NŴY 7iu 䒣pޟ3!WVf0kۙ%R!"DegV~mǃe0j# z\(ϻ>8Nl6*iuBӸ'C;5` ;3ڨE`YufQMIޖz\h5mMY'6t\k>%ăgՙF--7vDi,;*rjvfQM+KXAM̟mT*r-]k#9N6Dj'.'AG2Zy-M=evh{L@H2#>1̬bϪ5]^fW!>x̰VNk#;~_fXQOY},"!Z8̮2E7P(yf)g{aE=\K Z_fYQQ+eHN Mt֗YVʫh| n6K1ƗVʩh X̮>} fCLzXF(> ^]d"L¼* #ZF(ŚKՀ֚var?hCna0 QKEC g ⃖+v ɝjgݒl1ڀE(Śʢϡ&gWk;_zCm3Q;;h~w>цeTK٧hA3t3XF9L2WDkd3q|pASش]oLO\%AhF Q5lKx3`FAִro(!lnn;nmA3JfLT/Y7f]׶y(A4&7fd0h^;0ᮚzG\p4AOUa10ʀiSTqlǛ*#ط 2D)f9^W|`eR\ MHA޵V(Ew#Ѻ۷tPBf)Kh+Mf3Iu7Og:s\QεHHYg:\Px֎7yl[Ϛ W]j(*43%<ֶsc,zé;NLq w1NV,W|WiӈϠLa+& 5w d"XE$q%ߚ.j/-*(v>o'?ݷ?FqvqKY@ItڤMȏ/xíGh,[EH~)5q]}>ե)9}緊=4VQSw~(DB+ ij3W=4nXa<,\NWu#(ڄFȫQl 6Ͽ78h!wl.L26r~ztjx"!s ?~Q 7 kȯ Mx1vBp4;~Ulw#JNyZy;M07??Up<<_oDIV\rA_aOor=q0g⠂=_\c(0Bqa6C8hA~4>8>Tq)mpWS~0{:vD+{;ESYzoG۶aw-(}Ο9d %EjZQ2o9dc/UTBFNnܐٱfHm¯>62z!c_8Y+4Alfo9\cP?lFwZ>J+Daz;lB}q&/3lBm:E'5ݵIg&օ5,t8@DRIsLf:NIpDG>;GG+L8uɆ|uJࢢ/>eEh 6p7&;DP#'ֺPtbʕ4%1G\"k"SFXorFg>9S/C^=hX3#!fX7&2ACNXes ʄgS5ⴖi$RutQ=kȵ9L'q:0Xez]DN*q7?Z=*6 5hzBOìJ 6! I<^gI(,:6~xW|Q> -N2)+|s<:ߑXpPQ`\Rd4>op$8\L-Mx=Ƒ,B D.5x;49(GJY:]n 6h;[N$/AdNh?'-»ڛБb(5M>$ukkmR79e2D]{e2[bCh"$ XQ=HC-RfzeBε4uŽ|YP_h<[P VQ4+ #18Ҷo,s༰ǸZv:ML)w.qkSx`gXQe7!vڨ5r">ҷ}b=3|F W57>|V&LwԄ`gYY$.7.=3FwO8j8`eE#d/Nh۱}^I.OXp%M¯Ѕ%,3FX,֎=Z>`N!*4JfA!3ReM0k$(q8ԀG8Ək._=3dGAՊ3YsCڢ?Cvp#`Ϡ]^:gIjCه$;x'Ў^ @ӊJϰxWMygH PE46ў 9vv5-3 GI/8r#(eԢDR:+Y4/GEV86%. ~_f[Q3qX'DeU:8qD%g32{#̺T69 ̬KuƦ.иzKl+ Ur=֡kmU\S,-Y6uZz֮6gjEa Boz[Uf1Q?sh`MOUe&? NYe&գJo_[ʌ&gE 2# [qItjiWkZd 5Mku}&Xrf^ӫ[;l4hq4$oDSc4]]\gƙFɸZugFZs,Vg..iގ3#.J kșF-&N5LR1UyS4H-),*bޖ;*RlEҤDcMF)g δ&_TE]{DEL'b7ߚhb~Q9s %wsp9 0*g' YfF4>~>M93ӊ[*<O\7(Hq?d֮B;4/  `!1"oBf_;:C%%#A;({MGG+ w*, !is \F-#dT4! \%ޣk\3b9!37u:l棎JԡUE5枙rT>J]Jp0ޛ{bQjmHk-G=q jrc›{fQomX 2뎚_Q9nNkUJR9L{̒Ft6n3K s )ҭdzJ !(=odyV#]r 9J"X dLxF#˅c" 2Kʙޝ"STG)$6.0E#;d 3 >AGԣTC.z^rӛ~fQE7_zZyf󿼳ըf<pTtzj lVf۪6F3~fA+&hT2\ٹE:]j*7kI yD7i81J!$nA6n瓆N2(dc,d,5>]̷ oX&h©WY=@z}G2Zv23@Uh_$xTtؚȜzXI 3𨟹.\}I $63_"ti&ѐn $6u%0b 8F`rwc#Td'df0ݛW 8*f>uᐓMYZ~l?aK ]H Tg,ڝנwIW {$̃*7PiՅ-$!rt &hK?80OIpoJ.8Ɉ%a]d^C=+ѠГiK=D-FعH 垌YG#TxH#ᄨy0qՙjy#ㄨn*[h!r๓LC𗣎.Hýjȕ Dp/vkFa,'$&/'8œޣ _ABfQ;`]:=!X{/ZT2k:%ȋ[H@1\4P@Tq#s9ܑC㠆;.s :pڲi„ca"NVDZ~xm}BD$9,4QLB7br-P0(3n$2#Ҏ~5+8AD)M7NOX!fn/ qd3?ԔQqd53w bܑB{hٸ~Nu;2f[FkٯjM!ZAF=y$ 8+&7K̑C25sO:8!BgXr 62JYm%t}ބ5\DjRچ[#Fb :Z:8gza3UB@2*r(QnVpΫ/;J(Bb&U*c 'RI42VFA3. -aedTb'n>9J(jl]88yr1L O-)&0HS.C;dRoC‘dY$j{!CZ+*TG'YD΄==wd*T^pܑCD<|8p'@ Q3MWHO3D]Bڕ={dtX*g-"VkC҆AMLB!S2޸vNeR1[,&V ùIXE)4'"zV %N#h㬌"S@ :()Bj>dlAsqRH2qRЯ..꼅a&cʯC)Tj@4D͐\cENj2 Y4 D̃)7 ɣ3JA;3#סdW.;i=%W|ѥ 1HF'w|ۄ0 dA⋲I}h΅c"TV )@"2HF@CyShK+eDT@޸kMQ8ZI8#\I2}*yV2'\t`ZJFQ3o7{$U6#DÌf030'敽/mɎC1kuѫX_4zZB(Q5dHQjlި~ N9*z9gsI*:HaQA AA%w:&$\qJR QӣԥgI(yBm~9,c.~ QtNUo8xU.'}hƫ7SCˍҳIp1rRf0LqQ3k,LsQ&Pn8̟2cpr?s qޜ7 Ʉ?|;EѾ_A!B3uOL_QT&gSUMv뵑I:|8_hV62Qύ&̓[3Lqq0N|WN6퇑`&/gdw-ok$HǍ\wv${)r_&86V?$ėI'pav33ow9qJ믚Ig5Ig/r+iݎkIgs/xrkH?cdDn1;luv+v7euOϾ' =s₢_}~>NISYưi`W7䧸F/&s 4 ˾.w)DhGR.wa -ݙ{\G<7 OO>7OEyMʄ ;ϟ}tc_}#L~jU\c8S}!w6½ģ04@~tl5E8~Wl#ܱ+G=8/JH y}~X?5FvmA7~?%oʇܐOiZ\X`Hx}꾃0@q- !gsȿ2{Q_yPmpxK?۬S)!Y O@POu妔 g+y96W(qb?lqS>L`D:܎۫_ZNFos"/?9~ϛBOrZ#Y#zEitr!K_Ap2\^d8Za?a^QGfI$bO2h?L!|+륖ɤw/ԭf` #C=햋Lݠ14.*[p4-aTnE2gG m'fm#}[}|#ZF(;Ҿ"!Mt;CubP8'A,#C}ﺢunƤ]V4c 4nYe[F޷.n/}xlsyqQ9.#twj,#C}ӽ"L@n6z >ir;F5E5_Bn3zrZ.s k9>Ut0o%5̨9cttYfHboyUE-|v?ЧɈĬ>,K8;*: mWRoyU3j?+%xrˇԍZY]fRQIf7٦%&u䘔 1ġ:guEDʫB:neut;,8t{|ͨeUdEڶF8Mu!&SԐlgѭ*]tgZSJr 9%7Ȯqkyp?u)4:ب&>]CQ=ྷdnn|9tCԎMF]r\l:kG6ܭúMNS 9&2y5`e4cZO6l{̆.7`xy\ArIətfAC+!Y,6*awO e:L6* ruo|B!QHZufQK1_S6MƦ3{ jZ߮--njXuXZ?ștf\FW;bG"flDmbR4pmE:|cS>ea`t`QJ-m/-##F;#yn{K/D$8}ÚԂy$ppV%ʥ W[Ȉ!B ޷g/D=Yhד)*W1ܑBT;[|C-BwVtCPҽ<$tg?6naA=uKc#l-ղ^_~C'#^O<t>."!;Ȩ!aAx%63{Ȩ!aS"EtLqG Yn.f|>sdrւ;̑Bpm# vtu[sSF< Lֻ_ŒSB=rs`qnһJu2 0ht-7r#xzpoIkGB.Zgu" (ztg`u" lK7CJ,[}nJx'`JӦ{:$"L + b@ sQNb_JcSpqNDF^_5t_ĔN>8}|GLDi4pK#t\|HWi;R'`r% ibJ D,:jELMwPN0t-s]'YuDZX/YXyn7.Ƹ|/c6ܿqŚ[8Z(36̋.;mR|jƙfwJi;9W[jJh'`q:1)GDhԃ3DQSF; 6Eyq 0]w"I޸ޱoIwudfTV{f##EB|@ ROȈ!i&f_p{lh#ci(}F|ԑBDj).V!ԑBD"a]b t&;x! ;[SO9frG m!e" \NƁvkā>=sd``HM&DK72N:Z\Et qBQCM`7q$䍌lY_5UzDjy##{`Ah"qRcי=YmSY9Hja*2z bk׉F-D;΢VzRvfޝ͝?LJ] pɁ*hc]֮3*N5W9 \¡Ʈ3:Zd6\~l6h$g$1˦ƮJ;gݣ 7-uU'&"R4:3٨E 'bWtqN,6j)sx5_,:3٨+% 4 i.1Tz8[yI,o /3({W_I?w3Lg /3(S(>x,C?e6qi VfӬ4cwQE=Y%@i[MeUԓ:}TTl)29:*)]k&* FrVxZ^fVAOd6#efHFhktXeu^tw⸮Be9g$=n,2Êtu]$Eyw?PrƑ? r Fjwg g36Y]6 ]-:Hpx[oƇNͣprg6+[3$>%Dqh-#C}TC6Oaᑒ.2G%.E,A<^E(h <"|a99{BvӒ&2G!&7096=0=V][w#r6>1%Amcv ʤ߹H f\$Mr`v׬= bR2Sk~7eb-8pѢEn(ŷLU e QXf"tflpG(@n ;ft2\'pE,Tξ h3@Fώā,#iA2qaǣr ~ͼ/DeL#4"'iv]O3: 42x\N\Q!\F-d]ѳAJBH 1Q3Ѻtn}؁*L8-`Pe |#g1K /q+@ x8EK"8TSz0d׿,fI*SAFx3}y쬖ϠDq KQm;fi4NrҁsϾNJ$ݙLwuZ'U['*\% 23h%yg.wBBA=mK&sxFG~A5^2iMbA1;J*k,ŇB>U6Nm3g1>?|oq+z )O3c_}^K- տ~aV/ Z0o~w?4" ʃXTi]jE0ԓpHD/3Ѩ7> UNyIu+Zo;|jpP"w߇}~9,Ԋ\"k0~7IT9\9[߇߽W{:\s>}o"e\ g{G\c3?G~J(7]Phz~zt Ur96AK?}(턿YвqP*UHe?/1zdqe]IHNpCӉl;aS_va)kF9,q/2H~ eBJIP嬐$l;@qWtFQxqZOI?5ږJxV.T{U-,$ yr'Riƽ1 6m9UZk@weÔhRy\ON+y7BpV /hT,L(0)!! (lk~Rـ s_ fpJ b>J >΢j_Ȯ!+L$|׵fdZh-;Ŗ$U bDh+e.稜IήzŖx7aDHT@>_;jws\()f_QJ&8>(I`N^u/F+(߳ j؅RZ$^*U< Tq7nt~uLwt]'Z$8E#Z^+ߞΔ.5xIZt5Vg2StizUD#BLqY&JŹ 7val49h(k^.كuAZGdm"|TU.Э7 AM+عH&z0h;w ʐTz|Od"|bmCԥp>J}v)iUZ[zPh<.z7bKZF DžۅJ4[F EJ9 ';_m.`JK)J>*jT Yߝi$z:F] Yw髽sNOwNU?2&IfBe, /3ʋ\\Z6ЭeV4_/WZ2g2JzB"41vTTMujs4Ic9j̨l8/kz! :h0eFb`K~*)=Sr_v2 jZ9] T .gyUE5M@eeU-CuRj׭F~VM ԷPda ;1ڨ'uW. CuYE#q]'F2: 1@ufgaB(ib@%lwvmDIO^jY\~vfQMC[Q2 8oEtiؙF=@%EegVeajVdxsWIMG0m"Rz>gٙF=e9Au޴-->F!˱lo40ά6=PL hrMYvf|5u'UNm2vfPY psGF#" ҃9Jl ipG +\H,qd`Gw 9(Vg" >2m7<' U[H!iq2'*R. o$8 8zo#c&Ǥ!yij"!<!<#cVV  K1KHudq̝ jW+9SGF FH$^yA z=\|GLD,F_?5ĔND cwPڲP`qggVT$LrpcM}sAD/1ƅ zHL }P0Q Dn|`'aЮf\<&XP\b;%ojɢ( UԽ{}u0t#"V P;uೌ"~HGbζOrUD-? <%l I?pЧ" ݝ}?#?,bxdr.!0,ypzv|~˸+=]Hil+KqW`O=LuQW{xPf/<.-.R_wG8|MQ^gc<Q8,,Cz܊#|,mEp3 gم\Qͺ +Wv˰^hh #t2K!&I/c3]w*/M9h-bj,ltZ֡;Dm@3rZvI"Є#%aJQ7)8 Գcppm()P cӂ/ɖXV cDϣ5H儯$Ќ#5%^33(./;%1XEL wr h-㮈kU¢TWζSCGp {E܁|϶Zכ128X,)%X a+b2N8{x\ڠ7%{ZzE3xTӠ͊s9e /(LK-lM Ƞ 1[ڂu M=e\)piqR2[<'m=9v)5cΈg:bޡfZbQnCM|3jƙa6ͺF*8V@T=qfD{|c0[WjFa89H~-f!X*AX멡S{EBW0Kgt9Jc"'Y8mnB2V XXYC_2VH7dGp6wTMh/c<B_AT=%Wjs%ӊb %̗Z=+JPq_kk] vR_oj M(6+B[j<;^}^Fj+۹A e[72V@02w0Q/. 'eqK 1_j~](&IA|E-d4Cd2_jjƹc@min㪯4/cu措%>c ~:UT;۝j/#Z9&ڠz=>Y==V'w;纘Po5Έ7k%=40kƚbyt;4iY3֌0[-$>ѫDRkƛe+"E$!hLpg=57v1 f yXfh3b`X^zl/c舵r̗ZK{w" K=ery⍌YQ_Fkj)w5_ji0Tz_li+뺚q^ZJ˰_llmL,d"ޓv&weQvQS*9>㾄"-dm,x/#B.6 G|E,V24aa%J/c5,Gcb E2NXd%/^ilˉ\cMlY)a)!{ǫ+(Ir"KU$s92ʉ0XPJC2 PX-fe$@"RıR9 Xs''/eW,.C1fYTGKDrH:+^8nx'`Dt5dGMDzI'B= YfwĔjw[fr"ެ2@G2_1P٥ .h夌o"V̮Ga,H)#mrVA*%GJ DVk oz8)㛈Ů;Gь^K%DE_rjRkd2slX4aV.6zHO'D5c $bw8Eѐek卌Vl@$t[h!`A`Hzh&^,2+xXs9H!`VYeGF +hܵ^@P)D5^u^|!+D=-x<b|M̑BԂQQYRGF AS+-`CE7杘nԂw-{jwaݙFEly/K3pV\Fp֛O6jiŦh3lVLa@CmmӊN/X٥ƴjZ7!Zf}kڙE-#Fx>#6jje]mӊL[*J3ˍzZ(IvB͟3̬UFXE+J#,(kjMiZmYf@Q\+8aDepMkH}M%ǭ~ŬJ9"(ݡ y4P' wyK, ^,kK˓ W X^<#|kn{S`eA me{{._-/2[Y(~̦ߊQ]`Y^b(4tV؈.F&?Qi^࠲5 ݤXm)?xA~pq:0o D "P'E "z+Z ?͎~ȧi)˞@ R9? ͣ!m:D-0Ki"\+eL`rUH% Tُ]ƵӚ{ׅ$JU">WAQ0U䖘E$g7pyx)Uٿ0d7Ws_ K^HڮHtW-H<~2!(C!TDǏ]{xրdjFYnQ)yGs/v2j&Y;5MbB;c<5(Zp Qk;| Tu>2Жk7Eݛ= ,2Hz者{6,7xtnbrA(ƀ9A? "Jn?&J1=&E^wTgeppǷ] QGEetdUJsRXg-\?UD4x} |qE#h4y14!eZ3a;d(xD JE8D=~"S*C@0jL g; s&CI&j5 ߢjt; ɳ4jQő ml%:>SRzV*Y9e\#)s,\zPgt[FmudJW,Ņ_|u+|nͿOޒoL܃\<6phD[L dAo3 oM4gO=o;fF ~V@ Ø*2|$YA8R!U+h5wӍi ( $n34y*+'␄N? UA6Ԝ ׏B'iI`ɨ8;j%؄u{LaBjd)ܱl%gu!KAfg1Wh2zHEfFF<2^*%G ӜoܖyPNsVi;2UrAr'_ fU1Z4ޫ9c\(+ֳ|U?hu `sDYGj|~5$a;IoAp6Rª>Rpj)3 0E]+(!&'}I>pK17\p$#s8YH'M|(MP؊pIJ^V7K[GԌ˖@qJV|vgT&۽ (UU'0㥸 |po:и0ȋ $ b(jiD٪: ./vfd袠2 osqCi@/3I,g"e4rX ^SF}h|ӠH*h`A0cHMeP:ND^FB.F=34)4BbdVbf %(FtR\GyTeڪPYM ^ ?95f#@z̸ k`ak)rK QDϸ~a< Y-d"¼Wԥvzߐ& wk佢.pmh,* Ÿ \3ӭ+eyq}k+8S!a,"{Hr9,)Kl(~Jt%1E܇©\ߟF> &"{5ցMSӵþDw}cAbXC&)dudht6ol.2(=TFgftMy%ÆW1d!vٔS^n$y)E&儸ࠔ7rJThmuΤ% w)"[Do-.92p;wD/h'd.mH6fk+h o6ۗȞ.{Cɭ\1Ȟ WSʌL.(UT %iN\`N^K C@@Wġƙy.Be143*[^V7-7|ڢzEVmLY`5fs;Uu = suSYʪ#Զ SRiQG5@csҍ^n,* ȲB#^ZV״xgpkґz5=71 %*8Ntd^ICLx֦#Zo":7KRW Cڦ#zZp(_|z_td^I 6ȸI=2NF$K*%tMRPR:cKÆp=383 X:eQԿshI^@if 5YrFi/4:"A\{<L=3V*kދ8#mSԴQjsD54&ͪez,@=EAX( py1p蝦\'KFὈ<<As"V0QX.(y+ ѫ9iH`AsJy ϱ]\U ܖAkq17|y-<嚐9G3_jhPZ4E桶Y6jI澈<~#ɦ1sK%J]rڍb8[{Hlsrɠwi X?-V3]#H[i#I1MZy 08o͉9pT"<VIG#YV/5.pV˼'澈L.IARK}y-Hbx₦53EcAV?ur@4L=6"yЎy}DSD= ϧ.ɘ8X~RU/Qµ޸JeKT/u8H)Պsnq"8_@5HpGœĊǿFŝgm~ #a栌_FOx$LReL}xV|eS=Wڗs< w逊VqדR, S Uӆ@"rz uR^|.!4}DB>aI+iE>[ Z$t 3<oc u u<5x *BQI*b#!tO{B="jPXFntg#l^'vvŽ?"nH+#7}v`k*l9 qWx^ f1C5x5sv]ڱqo9oRGD ^M@:vd^K+>(oMqGCf! woθ#z ϩ%+Q!<+4i,kjEc+\X h,'п2ܓ4IG7zϽ9LjswsAh\́*BC,"XtFߌ,mTs=!+481>7{ K+c3hg 4"x9.娀HjC2צBV?jy R]C+g4i zKF|V?9;6qJ@H~ E#m7t2gT՚Pl 2`R$wH~+=K:5iOshgB&JZ< ÁZP74,)&Qý<]EQL$t?{jsCX)'UR"9T (^qX)%jGcQ2:|_hM*Ep#xNv Gu>o,"iXT5ŵX$? Ny#@"n gT(z={*9)X`#ғ\7g-/c{famc;c_ NVKoM\+g/(Hk! ;j}~`{=Mz{/~p8ùğxd:ù7o_|˯>`(uB&挚iHz06f_u ^*.R?¸~R r_ߍOas^0IZ[vB 8Swon Tp'…sF RݓqۧӧQcQ)// 4B? (*R2@ 1;76/u;NC.=Ax[Cr:PTP7De4Z8ۑazJ?+_<4Txw0#iGՌ /;FNǞgn{tK[K7t,ե#)pc&N#YNS^DWPWШޜ#y\>+kV{R?ՄOM+>RjI#v{~&NLU9C6RX+L9Fۅ`">D=ͅM+JMO{_Vdg%_.cu: pÂ* BhBtk1OR^*;B){S`*D }ISP;֐-;0PER|D nޱ9TEbnZc+1Tx)., /'d"*D)pڦy!)gFR|tnWq2^F)VCht+.- C[΄,3)temJ'Њhl$#3Ns!9[QAҋqa8>e`@ qnE|!m Q 8׹&z2'%bҋaSZ\J/UDmxetˏu %EnFZAuL2(|1^S|6B9nJF{)s^N =$L"¼ v]Iʜ^ @I<Q6N60vaIp_@Ey/)!:7,,"WqmI6g,"{1N+lW1B-8R,"ךNYPuJ&Eqs=!,";EE:*8s~3^Sg9]̤[ݮAiO?4"'WoZVEfմ04w&qEVtA0{g\FU4wQ-,k6Ȩp-Rš- kuEy.u#H2,j ?SdD@HXFayv3&=nȮ}Ț.ogb_Ƞ@d3YJQ'"ZRK}[X:) ,+b[krC&4"j2q[2UŅmrZ躢\#l85/5֮z]VޭM;lf*`xyd:0Z_ʻ1K:YDn K@\udB7QeL;2[9'm򗩕E-|;ݚvd^Q:4/I%g,ư#zZ:v\35[Wmבz=]w_v% d3*ӎipEMcƴ#jzwYSzZ.iG.gr`>!&e܁z=LQO1$+1r+*!3語05PEYw`H뤚<YtPA^68xl/t!f#O>e5*/`0Aᎈ<2xpG AE j wDQ: )qGD ^QC#S#=ys1W <$MJW`l`n!授VL1㥄7/Ԃ}Uiuໜ)xi0*ND{ wDa0Up/dJ=f<L آXr"n`+8x)"<$)$Z#HO q})T`N˃Bah-s%t<V&'lj$ ,1EqrY6t6w^8`Xz(g+/Kx,4O db Hr U_(mlR奈t<44>wѓMLx<6]b7 a(|}祈s,VIu+QR@8&-f_Ix_k̃ɶYҶ]t"XmI<MIx1aFNQN# )Ecz`»q}DHx,\3<׌d __>\%rRD8ؼsc?$hH)bqLB |Xz⍞]᪋+iצso7*եګx"JH[r54E6_՚rB-!N6y!mhvux?)޴0_DkgʲIQ?J5Ea:=5}yM]7N5Wv08G >bOx஬_|9 4ƫWI،(ڋ8!`Aa;2k8W^Di++9gP^Dg H$3 Iۆ6 68i*^Df]*3s6"2;n`l=!wy]t^<KMji+i6;?| fH.b0n}oUwi"^qr E v_J?7:797 s ^S51o T%F:̷ї%ܤdž"8vrf2~H( Eaa)5+Ҥr\D`f+lhG' ,kaO9X(-ԘZt Y?O^4clad7{F# (qk=r糊D#gK%ycр!==$i cI4"HVv4|Pǔ.gC#~xရ+mB"20H*B*G&< !CL@Ba yr5q^oGE*t:eoQG@Df{CH EeWZP"([ycn6לC" hxV EeQ̕urf<Ң>>KU{4E汦Ñy֞hƽ.U"ZX{(n}6"{/[2i&"kR i fx4H*(J$Rx{eԱǔQ ~G#tZ\IC :x r/ĎxC7<qjQ,\LEȇr$`EiiNrḀ<&!waP3]qqy\X*+yƓa<UOnqy,XPNʖ"g|U:gY[CMmF)܀AqyX]ܤV3}wgrMDr EqY @zg/eI7gA{hO0]|Y YƚK|~iq<>3oY}r%SrZ]99Tea2 oƘCj4i~pG#7kv굺`gk,z:x8B62P]IPJrd^`Ilr-Gj2J觛Up4I%-92S'y5;Ksk/-/E m %ۓqwFcɋ_8*0c]X&}wh.:َץX)PC)L Ƌr*=*dƼx1f\1ҘWd:^ӿaeV>5ةKla`l+2/dw7p6pEp#7Lڸ"ŸNF}wg@Cu/}QS,"YCv'JҾ҈~l/^Y #[Qn}oIjKGr~DQRyb/|`Fj|ΫgNRHpQH$l?ڈxo#H>(񽭨a$ w/ꃥa3Ƞ ^DK.1Wk!Fa%b$ U~CMGL;$2`D޴GZ{x,f&Mʿݷ+j2ģIN yxkKM5rIurSV6hzUz[=>G(xo^RzU(qnELe{|7?凗_~ js?~Ňo>Ԕ &=h_mk~ x__|^K;Σ/y/,k¯m+uqSK?|;^m~x9^X^g|f~CCi[.{}^;_dzS=~G~o>}AP/_?}_5C/ /A90_{ןwQNeKx>I%X>^x߆忶(߿͟>޿#{@?O4J׿|q$Ox~7a:ƨ ӛa]ˇoo?|2 ~D2?,c#AzNy1׿]滏Ahɣ؍8rC1ү ^lch50?63-o/)hp5f~;Xݹ=׿|gY?|1_c=_NĘ&E}㿰XBem,_fԄ/?%߼,qendstream endobj 305 0 obj << /Filter /FlateDecode /Length 166 >> stream x337U0P0U0S01C.=Cɹ\ `A RN\ %E\@i.}0`ȥ 43KM V8qy(-xǡ7oݺu;GGBS! 4 endstream endobj 306 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 166 >> stream xcd`ab`dddw441%ZX2@цA%G?g%Oբs'N1yrCgWWkܟ{+;[[%[zZ5 Hh6y򴉝*'O|>g7W7w7P;>endstream endobj 307 0 obj << /Filter /FlateDecode /Length 29071 >> stream xݽK-q.8?bA qYUF{m@uH"EREZ Owxҏ{/wn~K~{|nێޏmyx[wKokwr[;{z۲GUԷWɈ?sUx j^rHFUG{;ɈjWm/@,~|w)=[O5LJ?c)U wIoLJ_oOS[:Mwo??}xwgo;nVNxkvTzZݯsU.hJFUr Ӏo^J)8܊`{_T4/46@=5Ԅk ٭V.Q [`0*'Nx|7_|'ȯ3?f=η#ڶt:~nO@8:yf,U^)6ۖ#zM4y4H~ˉF⩔ho tn#uG-tc t|k| ޷淭Qm'?Y/hcr|}kgI|f{a N* x?S=*vxs|P Ŝ}So'onwzt6iO'6m˩e_pe  3ek"bMMn EN5q)9Ϸ\8HG qS@TT)hpҊ?Ý 5%w}[;Ja]-@V*p@UTz3750wA4o5tM\͇~< pѷ Uvkj' "*$BUԂl'2pFk7vbtXtJFUhSU2b:+mJFƫg}=fK9(y4Vv0$p}C5YkdlU˖^W tp@]bAk䲜p#-KySY@3jMwTݘxg5)돲r!'V./ڇ~"ql pA çpdHȉHMҪ&lh" ;tgU3X^5h!?N, ߏBh^~Ӏ[;R"ք݈x)1\MqhM)0hZM88T+6{'Cl=1~8rV,'pc#Eufze2KB`677cszH(A^yσ'v-柀xvzA lO0Ė'o:t&-o:?' %rtHg+4q88ha$n^h}  FNYmH Dwdza838} Y*¾'f !+._A5x^xWiJGUWxEK.sU22^50GUC ~L3D ~{oLp:b*1Wo8o1(u_нF:!Yka@ `7tgARoj?&C(@]}.?.I#PFb*)BBŞi/* Pc$PcX!Ċ=jX%V%i-bGE=Xc%p i . {#Wp$F\NJEv c$Zu']E:;-I[!-1DP!GڇhzWF+ZS^]h!Zl>0NJ%q$V&Ċ0r~Ŋy%V,nĊ0RU9Xz`F2yk@^p}i2Fvb\>GYIC.F8<\.IIWN6L9K\i ̅m&e6|zGIH8Hҹ ƉYIQ+0)6FtlnKQ #M VacѭKVmtCcƯ.6FHl4X,!֊eb[C@D3I`1ѭA&Mt[kD7v$*64im4^6a &a^nE`ێ<`&bێNno.& 0r"N_c0@=ȃC.a s #;B} 4G"F`םc0r]:7:Ks 5]uLU:2^%*p W:\Sc:_v EҶ/H]#|L'&o'j)v.t^ۿ`:/i[Bd, WI6 ;%q #]%q #Y>I܂%8%-^s-sr )IF,hKFhIےbS!iFQmaJ#y[ɚ^mCر ۆ/OJF ma@2ۂ<0HpIF I@Tm<.Ama-d+m xema`(Y[QG0|ˆZhڒ v]0qmaDsϒƹS@ּ(gma$J6z,gnad/-HP[-fnW"J30E,ian䩉[]-eﰝ֎ cԦ#Wd;\BbJjUDZ%22^%qp8* eK船*fd᪏l+n}Ld[1A("!hJQ1WRcmV?Ķ7~dl[ފ3`rv G/^-.Tɺcl[[:EnG\BxGb7ynuOMbꎺ2%\; *}75 %xŞHF# HK`-P!˛Usu hҦ]#iÝDoof `DMo`bH¿7 ' 0"8A8A8Ak+{)A%dґ* نtdJB*uxJhg_ĽrΎkU|!x+aX]b+l5JhS[ 3⌕k8`Sj$*ґWTT1eFUq"1,49?Jh EEݐJ E0%hH#Yߓ,qEt  ###### ^######## ^#Ku6.m}`IZD.ucˀ~Sn∮ctՎ %rcp,ٖey9?]{gZav\&Wٱǚ~;] hMK" }4IaNG:c<&7F.",\p XLwldvpi|7!KGxCԏ2[[Wz)i?{\|3.NJy\s3KxQ./r"1l& AЧ^Nv%fN i6=閝*Q'"dI pQ -Ex?h&:<;L>G _=/rhpd0 Ƙ'#zPu|yR7*dz$Td|$N>CMގ3Vg9)yu|/ aWI^8xƳ}hS酣K0 xFo o UW`7FNMA!]!_iHm/~"RO"(ӽ1п?hQ1ytx|itrO7f?v&u1x6M{*(ΐ0Mӣ@XX,-YF=Yh(f$#Hn}D^v$6P96[FHO\Tp;{:r@"rieͽJ+K96 {km;t߭ӟ<5pF֑ 3q_Q1HO]x;OF|;WTJR2@'kCn>'aUÍgD/y Yd  |q$"Tz;.2=ǐ~;׳SQ;..5s9 ,~WJ \pt&q1AgaR=[aYbLɏ(4QIĥ2'lK'e៤X'L FGCHHLII"=@#Y\(+|4̹<B#Y\kgĄ}nW̞y|YFPXiq ӡ6Bą~Lӡ6B)Bd=\K4 w"\ʸPxKC9>u;hwYvZDb t0~.iI-"{1-hZfQ~WV+QMY(tza&26u V˨Ey? !OZ!jlE֠.M6n`ZJ;dh`4"BЊZZ8A`h#PkYTS(;|7@;;=gB(-_ext$FUO{/x;;\O ,#DEu)aJX(~nĔCM?z]uh!=ǏA0RP1)GvGRDǔ6P0NE2ǢM)KHlH(b/Ц`~q_7Uf(F H&WeL EeK8)qXPP/^ [RhOjCAi9(/1訧MՉ"_H߀)Cxs2n%WP2  0581Q2V ؜*y - 90sOA٣ܹ (ɖ_L(i?d'"HaQy <- E%Ϣ]gF9P1]`yF7:Kzj/V ЀhI=E$uKk& {E4ѵN'~K&R]Dc^ Ua(@a$&{(ǟx."1Ѣ_3Y(Aj0DXXAZQhQhUj Sxż Ș)7."bƼWFDA ptylIuSC ty,nBE\qw*vrE솵8ݛnU.2]='3,ETE4aoEîh852Ph0ڴĜ=<ɍ5]"9#VXZQ?ХgDKG;퍶ZM CE(YHiCdZbx3 E{;ȉigĊ4Ekiy, nة[DZD SUj""XydҔe<䦵K;'nά5hE忲'3,?f$O Sf-呴+܇ 7iӖMHTB#ś0%Y*-"-uvmRe5x$<!]ˁ-2x4t)ly-"-'ʩ)$oԞ xhqwNiHrdP(u#8G)NükqPdDLJ܊8Gʆ CFwҎY!#`@&qծ3ɳ/G>:t~"U:dI]Vt煽!{aEbnz5]$~QYDS W {&]'&X#`qjdKyظ$:gq2YRS~{-LDl/RnlzE,eǰdh`,b)bDdKyHYϟ8ַ156Dl>E,C*'k^#8as:YD)t:]VB`'bR<|JxHTO2C^D bSGǯa^B-_Dy'fKh&dFs"<8[fEEx,X8H_D\`94o= <4O;N\>d69,g &ZTKzjIuVʼnΞZ.&|sK {A30^rpB^ ȼ\,XN4 h;ek reH㽄d: 3g: jm^H 7p{]`R:)-%ҮaJzs0k?il /tgUL6A'j-HO'#A ǕerNO+Mz] gE\֨rV6 ̤ MJ)*NlDizۤđ:ӻ^ ҺE:Ua GesϘEpIYkÒ@)0Ђ0!2M X5r‘z iil5jB`rs-}F5rs 4\ iZhڬE~tV.J֨hM >Itճ@hn C*4,!/u %yX>QtvPHhj]uV"-䳠=W tZi8;^  E P)U@-8Of|jYF~x-aqZtU~oߥgͲ!r2;|X˵6H3lqy7ЦYZ%-es}lCҐ!{#o -`-:;m$AObx"ESKP-R=Հ)ԫ]uY )BɬK>7Y$E(q|:b 9)B[TnXݱm8IN.<=v`ߐ{uz{{w\ `WY@않 @5[)B4YOܱ-S&FBTc]K~L?+HhYxn/=kzT+@luOvL?9?N*i +H6JW+dhnsq.v_493 'Wl* f?TrGKf?; X>f0}1 .}sU>:zYbyqiuF_e:ԾuFDwaFO1̥C;LO=>Nr^[=2m}~?K_|=坞ZkSHQWn WZwʰmK|$\*6~Op%6nu]p/5w? <pi??~xw 1vg.t#t@wa?_}|q4#Ħ8@$?LSų6@p9J,{|{;5)/񪄫LmJGUg}/_ǿ\'sA]BƫddjaV"fI}9m` `P~zɧg8CPO~  >v𸙋stflu:2ڳ*LZ z}zhAW}E ?ʂ^ :d^^c-h?1ۍ ͏G,($4ٿ4RL<c"~²TȲ%h6IA2xU$\?6=X>H6T20_buqq7:7g˳=j7U.vdx7Shm7&}ҍw^Kح%F7>a4VkA7;QMGc yv\"e w Rq2 x3;ǚdu.0肜UVM:5肜U.Y]tW8Q S42sS|0|}@- YA CY . QX''h66I'm#DgFo)!} 1%́91;Ȼsxq\ia2'6nFF|]rg>o3(x=}yJAd%KmG iacdL/U8|ѱpw%Wni9?ЫJ#o "\F)&Wng)ʓTǹ"?YcsY-v@Z[ƞjwl6@K ҘuژEB ɐ֬WQ,4r({n|,R)i?|flhG .',&Hf!v'M~q9|Mbn?T>w=m$O,"^# '[xU.2l\!FIWpZOH5gb {vOurp, A!C*e1MoVe~ VydB+E&\J(y,~fgmr,r:g/xh,a&K PsjzݰIh%쨯=SsfS;}&߶ܾBD2h*#7Ь\Tif?b~64|O3hrp`a)9£/)/Phո#ީ/`e̷@:A$h3ܫo(؜W7A dӾNBX2Q"cbjjA^&ۿ~*"sU=#l'sQǵ' eQ$e l ӿmcrSwqGeBA_W+7OI;@kb#H .ΟDX2/gbU:Z}etaG9JrI!"937iDv?6w>h[݌>XwGםĩ8^õuNUqg'}Pهj5׵I71k"B;mqȭ -Q" @^ǫшNH_O>`۵פڽ*֖'T1ϦF΅jCш&!-L/憛D}%disjVmXE!XI(bmt`I8U3F"u߷Q{I"](/rJwQ&uTOܟ$XSEB|:m4)׍n·n7KO ~ĸm T fdZV"M2A2GJqk-R$/x8$Ĵ=|c:VM-q/vjEE$(*ȻR [U=#!!!n5sNB.{ Ş:G%$u9e [&}t5s7[:yePRF]SL "_de'HS'(rl=L$Tݝ{XeG~2vj']gEI'js^@n9n*M&hHSԴ0m.r4i% VN08Y_*s^HuyԦ4V#eB%pp]=˳c8)tԪN ]jHY= 4>^;qRIcΘնo',\&/<Եjݮ#KK+&C6[II W,eDtr2":pXV-_N#b/ G5YEMLV_D\%w>JC7,eeh"/ XK!b'\XN\񀗎0Cc+"X.8r%ǍHz\C}~52ܓ-Yx~rʜ*"&p6UŲT}°A劈<JDRWPE@N~&?$6sL!`RVhB٢-Q?g<OXv0ήEx(-ˮ퉌"Xq[kե"t#V%߉'5ET燎J[a>KFx Ӏ,B[&(bf˘xrBmx D+iܘ*:墈gfdUcWrpX&X ߆&ϿDz0Q@3^."ҟ F(`2,E$㥿 V%DьGOV^m Ő4"duTÇHv$Qx9,޺LZ4QL-ys9-El/dߓب'?vlXTm Ki~]bakg(H޲y2wlCe3p\Db_.W_զ<9k,cN&cO4qG]?8H*po(r%ŜMS<%v6'(^0|DKtyECaOymmor~Ṉ&k|Md9(r褡<jFg"_dx>dǃṈr YJ{zExcH\Da`q^UeyȲ\Da_ϛhgbgky.b10_I m`0tyE*B-t9-MΒGWo.b21zQ5+z4=z[QIq3n1v[j;G9Mriag {]+4bJ0݇-?pd,qF4a"Lv{E _HCIqѬbpqnG7#RtPZh.fxK+zY=󅱧c|<y꡻U&fX@ )#N= 7GtOݚ9ZDZQ O-d>E<įck5xtpf "_|_U[l.1'~S~de`&/ G"zBuX\@a^ՠМ&[:uSn : E ѥÌV6ے\`]8$fdwJe0?\a\;hNAEeN~ʫ*"nud).11xFiNg4浿U!يPZE;6o*+ F\aki: ]y~&: ңE=ɝzc FLAfHI Vu+;R D!v/<ھObG-9V>* ߎXåQz@e;w1a.2/P[bS].2/ߗ'DMe.2/~A(׎y%дl1 y).%ļY5{6+4z>ʼn R 0E/{$Eu_wC$FT(́+I :7"lM̃.Qh]9tdɪt啬@#r7gj֖?nAc܌Ͻ>hď^wuh6i7ͩ4 G{R!1>5:/Y4/ >-EE={1IU E[@e^s{:[oh-"/'yI6_OUic-b//7&vm l=C”%8<+OpW'lNJS4'~susrEu_&{ #<E*;,em]ɇəOGqyt-lU>TP!< $tL?I'TK4.1`׎K0MY&xczRjVfO{\1@PdWu%<VۉM|Tӑ]dގ N m*9*r_-+Ŏdp߮.>n0t⣈k<fxM2"_T6 Q2{kfk,JM:NeG8 GϘ"Y:N|qbMmCNNRf(*o-rV;H(I3=x߻ CX7񊗷j!gUwBXf Wǵy\o ]ػ'bŪIorV#D`hfZ?Ui'bj0펤$ iDq _p>d+Fo7t<L"ȸ[4LF,et!yjZDZv͌#E\R:X(#=NZ&{:ƈ 辦"xj͑9vSB8(#' 󑒸uqr F_|j C <]5Αz׍W9Pޠ͑z2kS^h>GE4}D@HϑzE˟ڑ(rY#m)}C6|IOI#eP5nҝ|"tiѽ|;8~2I#mR_ [' ~0 4id:RV/{hΑziV?T+o-r֠ϑz9H|z)yI#MⱫ>elBqHWd~{utP0V"UrZD}ngҶHQgJV"=rIashjϼuNLz4aYǫIz>)[I^DKfG~q硋+/mTKHzZ/:E0äm&yWeR26qзHF>d(@Zu tɋȤk|󖵉ѷ@rBJGXeϟeQwh)]x:UoXvhCt7ĉ]fV(Ct?A{m.;dk]F")kc5֜M[MA}iir`. NKØx:_ !@ҭ啤KV!"\PrU~Bvl̒Ә"0F *LO*Dv?ZT_*Dv?fd U}9}:FXHl\g;^Itݯ$~'JKBkZ&b0xdT-YkYɲЌp&pUGKዅf;7ɼ@8zv~&ٓxK|`B3E߳ܮhz57Z(nTh :^/cK Ž}u9g, 2i:CT 0m{֦R^;KnN_9: Կ#~:p{+H 8IJ<6K EOѲ_r삥GoXGoyixJZG/(Z>h'}A0zy O l;_4DMPNrPutMf{rKeH42^V"tw\XrH4x4i';alg*F&_fV|'0%:cyeooᾀK?>ûWma x䑱cswއ^_㇯>O>?}8LI5k)[Jg'*Ĵa(j<*)|u\C%:2\p52^upDO% \#Uƫtdjq^WDң6F[+ȈZ#€O>MJx6%|`D!VSwA(@_#ܥJFU|7&$c*v*K$v`{`Q-v^ `z+> ?K 6(c%-7=?-}`'5wJn#fx5ǚ`ExGp>f-#xFS1#0K% 0nyw3­;c_tڑM|.jbfrwJz䜸(0q6\T@2xJ۸<\je ym*WejhdF:oAݧm`cI8y͍$uLhpŸdiJ2x 0utIItF8ɗ( 髰Om3O4:$j@;/pOi΍6 kkxӚH? ǛⶦFgLEE+13ZPwkd4;zCx52\f^W]#UXdҍmF^W:>b=ƶќ/XStl]#/Faڶ˶]W mpG6:m{%t%F.Kz 72ٶIo"[~`d1R r?h>7pلv<Dn x =s 5~OO1${U@;{w 70^,%M~PvF2gn+ $ IlsMTd7pm0vm(8IXk\H>]e;Ɓ0rRb#O-S-#>7xهO ӝ36=\dxoKv,8{J_a}sRh l ~߹xhy|zt ^3㗾`S' fcS \|' ^Eȃw tNXWIp,ԧ>1KGU:ZP]cIYWPGbrɴC~IxZ;P^XT2:xIq*-Y\ZPF lm Z8 +N{BC(Iǫꀺ)Ǎ`o*tew2Z+V1z괅\Mö:=F.AtLގ aTwuc ߶NnuV{S% n߾qBdhiix散<6n73 +L]ݞ㫽T_~Xut ^hEGQvPJ|밬sͫ68d[ gTn򣙽a$N~rj}0ί +>Vrn.W:NI:<+|ܪ &#i &*k])Fdx$MZȤpusO _ʢڊV'9%YGo/!(̬#a7g-eմw$Kg48@"w$J*`}} Am V<*wS;{+|M-" \@_؂GrMAS? 4I3m!ſ=*~ NV;.M$,ۆ "P[<,A(Ŝ/A͠>IE.śSzdsS?{.Ak)ndjsU8K)w Ӵi+ʚ. bȃA!gi[(g$kOaSY F(N1XBE6  ojB?NTmBǘ::T# \Q~&$V \ B]I`5@m/"U [^n@t3rZdjD?rX%eBX? TN u.ў } 3r昱0QhBt/U\d5Xd7e!BЂЅҴQnЧ5uTU~0gR8t@(Z3sRn 85^,7P5hCu?V K=;J 7>K3 mާ&Ry9(Dv/"(0u&&,&E (*]6ku,?'y~-#`!IC6p6y-  IIO )(G7sn6$b5.R'/PT>FusP]9RT.'?Upފ6/:S5ҀLU)hú%IqYKib`5Ei5.R'/u?˺*т?i ոHTvC}bT.R'/!y΢+&.r:y! CH+&T6GIJ}) ݨʳ"ZŻRKu HYꋧu}اHYڻɺyc9RUj~n(xtihf`t=0imzI䌫1RRHQ|־ n4́z,&;kis^BBpL1k:Isa\{W] h|^${4q^: iMg:) 5I'b~^ z=p ; ϮTG Jx1:ysAۦ+CHQHA5ېZ.Fl'{y'OIf={ƲDDNk?{9TOD$rh^@RL<qÀI %#OD$ųB@,nJ( G7+? KX[:YXKg XOBÑ)"^8CK!1$qOG8/1D8,2̲-j*ϯt-ѻ *XjñNTȬ}jRB^uЮJ^h*xжx4.G"؅(o={}܋+cx}s"N¾eĐ Dⅽq4zH<xQ/R)–u"FXpCĜX'"@Oi$1*$ړ;N)^ |X}cy'/ aLxs,D2_t -q=1XD H\5c/}+fZT3NTyYE<対dAXصKnfeN zX墈g<~7VEx'Ӱ8QD5 x6f]atCCG|-{.B\Ttw8QSYClm͠"@>r]Dda jK{˚h.1u kd-p1.VKWRU⺈&l5)c6Ktyh$!_"|)K\ذR*o.1/!*!͏4Q1<q=|X3Q7tUGTZMr9ᯒ!E8[lI."0'E QU˒-E ſx]q7wٛX.`0eiO);#E@>Ln}Kry|)-ϵZx\FG`/kl!GJ ,}dkVH)%:b_ 1C{oE4% GL<^-4q;-fRH0w)XvH#GZ& X~鰧v2rYDI'X4bHh][80xgL[Eyhݯa*hʖў:EߛMhρK(`;!lt3n3YAkeh"z[GhXp7nDqa.2{v@Kr]eA]6MXClQi/9Ĕt}96É}>vYB(/3UTӵS0^fb OwZ-˴m_-E\!JQ-,?]ec] 77W{>xP̥Eb7mj(X.뾚h)R oud=u]I@=iĔ^wlڞ4piē^ x_>FDu>JuU2c`m|G3obl>0? k!<Բ< 2MĂ?Ixc`$8ƐաXnsxЖ""sXW"SML鰑"װB]]wY X̃k0ctylF:֨8n-sylZ̓t! ;l:DtyhZ9w_*YBKt9p Onqw)x#i(O 4]H4b \ ;v AvG0} (۰>Phď]ޝDUĠ;zpl4x~\,?zp(sNZO'G*S84G/[ťl2E! z`x"S,$stm47Գ Xh̃ ,m.1{o;m.ýuE,}fy,6%9$Htyti]DBI~rE&s$汥rI;mGI.b05ru"/HM']AcO=9Er9XR_;[K/Ή"2.E%OhkrE_jsjImˋ_3n3Jݬqˁ\^LNmH%)0-EoKx̢D|$[_ E兿 vh5,IOD/^j-h)(b'->NZ0 Ƌ~9_))Bx7lxT9ċedV)%,<qlVe E㥿Xw>Հc⡀c&=紓O(jkY(/'eO.Zd10Ϋ&Ґ/{2|VqOGC8 AQ&;$DTGgR<EDe-`%g(maln)Rj{⪡<q5߁ҭDH#`A zfV%?EDkJ wcS7h{og֒&k)""cbTrr?t2E@^B☝WHb䊈x{:IIz x{5%~xY|ibqAm8tB{[6fia9U'#?0 kHKz:uTI^wɇmV#M5'3Ykt.LSVM0i&E'm3f9T/ խ237We4 hLyu*n=* )8:G$Oގ&=Id wt?(s^>L'X)y+n9T/ yM6A&{֍*GjųxYٟ U-Fen4!BLIs5ؼ/w ^Bl<(]I""RGKyq-bF" 4f߭4>{j#Ϟ@U.>H3uiCt?ɎS0't?ՆnrPop>^I*5=^x҆~m2 l'4mҨ߂5¢{ RZ^,Ffg<Y`;_ۣ T#ʾ,u -kkE?*]J߯ LTb;EKJM  }"KD.8 P`oHȜXڡ] ~#Udl,Y)=pDjC7I.e[$e!ſ"FQFnvmN(l.h^Q?*ǵ4quW LT2n4ڹ:`)‰{s}phj (E0Ъq']_P p2M6F2Q~ꁷjy1i({E=|MVԑj VrKFԑD; Jb+h'YIa&bڋQGbt+Jf:f݄TeAҁ7l2&c+H eŵsGʨ~FЁc2U )IWdL{-V$h'f>B52"g)|F4 EE AeNFdgPd !LoŀiOxrң̄E1CbYsߖ//NX4nW/:-xaM7V jN ;[оP(s&<<~|_?G^0ӿ?{ ޥ/?WogF =sx5jxIP'konwpI_2S wAvl/{|\Oݿ+Np>ބ.yd=LJ0_㇯>O>?}|ЪM3/p "Ԅ?ɧ>p-_|.)L r`ro_xu6Yn `}7p_I?n[w?}_}ҷ{~_~;3LS %<o=x/̡s|>齮w?Ioy[-Eŀ[S~)ßs}w7g߾^g e?}:8],qFn(>_?MW߼ۊ|).G}| #R[~{?>}M+܋yC8w}Ywzey7Mo$~~o_]z__ /_/A~?f|~ׇ~?Ͼgd=^/4N7[o?gn?}^g w;sÇixA߃_?k 7}M#w4q0 0տѩ^n8C|͟ahuWoo?Opz;xo-{z +^o5Ew^d-# ,;u>Ҷ _:I_q6.[P׉ c?A@Œx/^endstream endobj 308 0 obj << /Filter /FlateDecode /Length 1995 >> stream xYKoFB/j! &-!~$6,Ɏl5ߙ}KRE&gg=ߌ.9K_~Y|]v;-,~y'RE:"0X:# ~-w՚3ɹZEw?Wk>tw i-D_IB{8gZtbぽxօ>|"BwgzQdJk|9Uj)T]v ptg()ZP>z&2IGgz~;<'av@VoBfnd`*ڛ,;kUfDړ LvG޿ii)pP~~8~`R^>}.@ެTXD*ŕ4Pj텅dj3EDǢ_h##u#ʛEzHTJlTR)^گc[=cgR bgƄuMjL |,kN҈M^x<>!QkLfCzeM=4͕E Y]$d{x)ؕR2q S#9kt5돵6"9O+2fNgM%DtCVC7]t<#:hpt")nw^+p6fB۞'h'6\vdW7akBܵcοE$!ҕ{sZVWS~) 5T G&ST$FS2gvּEPSGj47}TM V4Ș@RNJEuPOkMMi2J:)xSsX51>]׈ٔ(V̅:\AfqzHԱP4aB_4iЖp;+$E|"yR<0+TIaMrU`;rvb (jj\MBG`ruz &yvfw3XvmdH6اo&!ۼuR&L߅M`zwmLԽ|kƦJ92 ~1arW8T|AU^~8 "CҳW)l24 mIaeEzύ9DߣnY5BKޣ/^|-u݉1:^{N[\L P{!~v!0'37q AhrtgrF7f9)S1%_6!& شn4̀Ds1Ja+秡A)xE>=%ә #`L31hF<\8>I絧=ibVwQ guZ dx*}>n*ݶbV \"G M$W+goe%endstream endobj 309 0 obj << /Filter /FlateDecode /Length 1825 >> stream xYIo[7WE<+(,)[7xInvR(j8|_<-e8-,~~c\Rܼ_|ȤKh[nvw\٨w #Y՚sG=Jʊך1)pkϘP|8#?\)ڮj5}`;#p7sqwo"[bA/i~bTwc\#Xa8'7 0#6d@ gz $bFV7z\qGh. ;ͽΠ5vWVcLs]b`Ò%2 .3Wq[tgHvU4\-:>F:Tͳ%W3)cf *k@$&J]a(HG= !̝=% {2Mz 62^oBz#kc9,kFxU%:IϬ츫])Hۗ`:K^FZuxvS8˙bp[!EnfI㨙Ja ,浱!srZD!/Ю./mvd1`d8KiU6]?D4zHGH\ҨKM0ƁgEQ;ɞ*BȎ17YGƙ 7LQ5&L o*&ciׅfV&"v3y,U-puk>O"KQ Z ȌV% 1oh Us"{ n"/Z:Cn#[mH`#~jBwb]RNmC0g4Zǜr]R U2?UzW~YV×Uf N|{5Mĭ2 %nm"1 |m4@1k&pm7T T k~} l۪oHÁAYŜ/mSlSrVtȻhNۧm4]֕d#,3f<ߓmPBbj4M>Afzg<(Gg u_8Jz5κ#rϋPD>Pq9:9} #ybђDG ?ԑQܑ)$Y571mn}vq"ZUiD~D)%cf :6_Z[ñ1gಓ} 4ZOݜْJ+ 깙EiNbK49}x۷;טeI:ʜ2;šh..&Nlno$<|&a2>[Fm C(4[B2{ Ѡ0'qꯦ"Ѥ,e 9kl1$PYy9q&u6D ~m=@+@Zww.Ljhk^tݽ z''Wv̈́ؒP6Ʉ*zد endstream endobj 310 0 obj << /Filter /FlateDecode /Length 562528 >> stream x_cWv{?DEE NS/dnj#= _u&UTmnٽ7wDa?lcG. @.d዗7⟾8>&?7i.7fO/~~NiNo~v۾=||ON߾yo--iٗiC6o]/>]~z~r]tyǿٖm:J>|Obo?ƍ~w7zA;~YOe4ɜͷOVmmʻ|=]ͻ6o^}Kxyy9_߶/l@Kַ?_Gtoaǿo_eo?~Ժ ~Oc|Ӷ2g?`CW_9r=_}p'v܇8g/ڿ>p|^1p~)so.e~Ҍ???S9yOm^3沴KgyW>~z9)󧃞}zC7y_oMte[dw{M{yk3}?my:r>o_ j^~O^Qgݿ{IGpx|rJ>>ؿszy>j~鲝0_}ιFϏs/Ws{^}m)Ͽu~wiY۷?޾?]ױgϾsL,=K{^&=<9_|fy? \uZe>~'?_Ͽ r۶}xx}?/O|?[UjOe}hS{ оg{|g3]ߓ/_ٵ͟]{!]mu_Hۛ G^t^gyՇyYվyS//WQ\ej/yϞۯxw{9~?m|pJǻ7h-c7>׳]]oyn//7_ S{lgn;m74;Oǧ=j_xmE_}:M֧W'zfx{vgk O=/< m'~x4?wpnWon/ש}~`~&_Y >jy#_?5ۍz Yo|rW1? ~Zntݡ;^طGC.^;|s^~c?/{̮/mf/n?0^?c^z7h|Ծ O4}oO_}?w?]~_~_ow^ ߯~O_o/?W?>o|?wooo+?_os?|/+^|[o: ^ׇ݇o,OՇϷ{g>~#YAq3?~>A7ź>Kyyk{m/OMEyާ޷W'?ZK's{4.w?|i7/zsO{w~W7O?fxn}ﾹ}Z}ן O}emUzܢ]{R?~'d?;t_?ϟ۳4.K??>t8Կ,ź?qo/䯟_ۓwO?#}_/=oϫ?~1߾ojӲ^>vOW/KOW?~^O_l˛弼iݮo]s//7hў;n3n}_74ǿͻLvjߖ'U~)t^?r9Vȡ}鎕?rޯ-.r^he+f9SEFmuY\ZFm.|z9M{^siOt8ϥ`\h֗si^}>'U[NiG^Uݡe_*}U5'ȫ*:__wK_ڗcϴ],/+p9x?ѽn%MO|\vx#o1>ﳏ_p9%>>o'࿇޴y|sWK<6ro%nO_}yo>}y|ܾC~gwsf=]ۓի|n _w]7Oo߬1e켾L~ ֻ{?ɿiy߼ܜwiWkdjr7z_On9'PkvS{罴+w[o_o?.E7B~ۗp/^;y?rmtsͻ6ڮ.{\7?|p6wWݾ٬z͏b][ڟW|71L;=G~P]d9VȡjO=X#jl9TsWx|+nj;uz;.>ݹ(/m[no\0w{׆>r| <ګv~&Ǖ:|Qu|or\ph.z9FȱjtGg}xկ~3sIڋioK]M?㛗̦߼YmOv9wz伷wO>9Vs{*}U5EqȫjnWȫ/cyUgt{3tno۫M Ү]]gs^w/xߑ[:~9>֗~/0}ׯ#>e7zA|Fҗ릟r/:~շ_^/O|/9[_}+69t}ww=o^8_/'f{klvm]ۚ_uඵ.e}~Al:DWMsN:/:SGR+:+zZs._Qڵ+rGw5ҮuUuyYuWՃyiW厺ܮI[/w&IK. jRuMzG]wOuWޮuv]](wԥ_rx/Is.Qv]K.'KjG]Q~]>튻Q~]OZUzG_(wԮ5+rR.wԯ/Ԯ5+5+2+%w~]*'m/vk/T;jjo5+zG_&,wԮ5Q[5+k97_q_v]_q~]~YQS.v풻QS^Q]b]/˵_rW[krGuW;|孵+rG]wX^t~]Ou=KwmWS9]q;rG]ڬ|0w+uvV~Yw`KfI|EK/z]bԯ˯JV-[C.u^Q}WԵ]po^Qs.WrW/+jnn劚w`ΗsnzR]q+j^z1]qWO_pW/]p7֯/J.ʯ\.'zCz,/PsDŽe jWzZ/BzU`5rAzS~]>zz~] Zv~]Zڮʥ]m jW^PKڮ(Z/-Үf2-՝nWrZn^Fz9uxR._j_v]._j_v]._j|+z~//?[Z{X._hڅv~]~Q^NK..崴r9|fw/.ݴ3 Ut"Zݴ+$GEYuv*lMگIT>2z= ի`mrZev=iz]դ+^Nk.%/_K|krZ%vjjrZ5vy[,'r9"r9"| z\o]dWiWe_cW֯W֮kꫲkr;mMcv]>?P v]>JӥN[.ro>/inToGϮ_c_v]n_cWGkrR.e~NOmJ@֯ӺiW]ciS餭N[ˠ~K~}]}v]nF+!ТN?;RFSv]n_aW_k,඘iW_aW}մr;"4Q9i~-gEvkr;|%vwTFK~]Evv=Փz;"+.rR.~]Ev񥻼<d4Js=|>)"+MEO&҄I4i&MO:(M47wP4J&҄I4)҄(&EVYiRd & JI4aR*M44i& J Ri$+MJ&ҤIVYiͥ҄I4i&M҄I4afI&D4)ҤHJ+#pPI}4i&NIR4J&Ii )MdI41ěҤIV4J'Ii$)M41ҵ/FRYib$I&NҤJQIwJ&Yi$)MJYi +M$ Rib$ 7J'Ii$+Md&EV]G<:(Mz4i&NI{RiYi⤭Q4i&ZJ&Yi$+MzGҤIV8iwT*M41;*&EV]J'm;ɤT0)&FkRi$+MdrGҤAV8iwT*MdI41ZJ&Yib;*&EV]J+MdzGҤIV]J'ҤA\T4J&Yi$)M;*&\*M$I4i&FKRiRdѵQ4!ҤIV8iyQO'mJI7grGҤAV8iwT*MdI41ZJ&Yi$+M;*&FSRib;*&=V8iwT*MJ'-JI7'I4qZT4J'JI&FzGҤ;nI41J"+MzGҤJ&Yi$+M>g4i&FKRi +MdzEҤIV+i+*&T8i}XQO'J\TYiIKRi$+M$zCYiҍYi⠥P4i&MIR4J&YibJ^P4~[i⤵^P4)hT*MdI4qR/(+MJYib *&MIKRi$+MdzAYib3)&i+Mcѵ^N4)Ҥ;nz9ҤIV4IJ-T-TrJI4i&NZJ&Yibt-S*M4ݔJT4J#)Mz7Ҥ;nz7ҤIV4IJ-rJIfI4qV/T4J'-rҤJfI&}V8IJ#)M41)&MҤIV8i& J Ri⤵@*M9+Mdz;h*S*Mr;mVvJI4i&NZJnJ&Yi⤵N4i&A۩ѵN4q^oT4i{Mէr;Ĩ)&T0)&NJN4q^oT4J'vJI4q/-TtsV4J'vJI4q\o'+Mj41zէRoTXi$+M)&ݜ&NZJ&Ii +M4ǓJ٤vRPiFJS*ME4ҼGTJS*ME4#b"TTJS*ME4#B"TTJS)M54#b"TTJS*ME4#b"TPiFJS*ME4#b"RjPiޣBi:"鈔"THi:"鈔"T@i!#RHi:"#RHi:"#RHi*B鈔#RHi*B鈔#RPi:"鈔}oՠtDJ)͈Xi:"鈮TJ)MG4tt8"鈔"THi:"鈔"THi:"#PnHi:J)MG4t4;#RPi:"鈔"THi:"鈔fD4tDJ)ME4tJS *MG4tDJS*MG4TJ)MG4TJ)MG4tDJ)MG4tDJ)MG4tCJ)ME4tDJ)͈Xi:"鈔"THi:"鈔"THi:"#RHi:"#R@iA鈔#RHi*B鈔#RHi*B鈔#RPi:"鈔Q4tDJ3"VHi:"鈔"RnHi:"KXi:"#RHi:"#RHi*B鈔#RHi*B鈔#RHiJ )ME4tDJS*MG4tDJ3"VHi:"鈔"THi:"#RHi:"#PnHi*"醔#RHi*B鈔#RPi:"RPi:"鈔#RPi:"鈔"THi:"f44tCJS*MG4t #RHi*"醔ι #RHi*BR/'VHi*BR@iA鈔#RPi:"鈔#RvR@i!*M7SXi:"#RHi*B鈔#RHi*BRHi*B鈔#RPi:"鈔#PjPi:*o4tDJ)MG4tDJ)ME4tDJ(hXi:"鈔#RPi:"鈔"T@i!THi:"#RHi:"#RHi*BRHi*B鈔#RHi*B鈔#PjPi:ǐtDJ3"VHi:"#RHi:"#R@iA鈔_[4tDJ)ME4tCJ(M54tDJ)ME4tDJS*MG4tDJSJ )MG4Q4M4#|v$筰|vg/gf얙f69,1rv0G3R` QrX^ aar9l-G#[GXZf$6[1HZ9r8èr4#EhFr [aaH9TI(3'3'G3RNf$6"䰰˩a'9dHr0 $z*n6r80r!/7a,7.^ #l3 3b1$ΰb؊ŐntOg{X ߆𞚽g,bH6a6!6{mxnKҶ g gXg gس gl`+B5`XtmXحX )ֆ3Ն3l3b-XF$QOkR gg,ZH6a6a6kmLV~6ggZ$glxO3b%$3ΰ10XV#teb.VB s [X Ȇ3LŕWBQa96b#} Ɔ3ƅظXHlxO-3b# 0 ΐ Xlx#``[Ҁ gg,J0v_ゟ<_kzg,JH5,LŵX 3,3̺3b'tFH5b5a5;!ָx'$;Xk\NH5a5a5;!iV첆33b'$ΐv#`k_gNHv5=36 E1`)vB"ѽLa5j9.$9)4a&̱9Lh3u06s<'ixNLh 3MLh2ʄ(sd$Ʉ19 2ߖ9&I9bI s01V*D0`I I~ %4˩^?9KjZr[v0,z@0\Kcp s-ے9W8^gsD-i%4<Ƨ3F>wK#b %5suy%̱9•4g?UOCJcYIs+sUR#V9T4GTJj$*<csДSœ gsD)i^np[v4g+N*J#DIcr$90ǀ:'a$YʭvIjI8 $5r뤚9|N$ԬI0 s%a$٪XJҜ:)%a$̱f-N*Ic$IRn$XHRs-NH#au$͙˭6FRs-NH[,XEҘ:i"aI$͑9{uCo+9$͑9Ɛ0:)!1Znd[A#HwsG['xNZG['#ܖ#s1kuR9#G3['#4\˭y#̱nf.NFhLʭ>wFcsiȗi1&,Ica9#Y˥2R3?,gV.Kٜ\:˥ F4g)NEcsiZE%E;'"1[9V4Gh,EjB,R+'"esE+'"4Is a"Yʕc8HqU& 5吥7I7xNA& 5So Ҝ7Ia Y}^Ƙ Ҝ/ m SA& ̑1so!1w/5KoRgn siVԁp[Ɓ4g)M@#c iZ 9s5ZޣF20" Eu`D#bx  ޣFH0"V1Ga(K{TP FX0ւ=*`DL#b3{T Fn0"1=*`D#B> [TBE(!! "DP*BF;BE ՠ$)"*BMsBE !(T0"&*BTBE +T0"*B[BE !/TD0P*Bbx c"U0"v*BiSCE"ĆPFPzCE8ɡ"4FPC5!<"FPT拓*BDE(!A "DP!*Bx !""FQbDEa="P$F$QDE#bY"t&F2QDEh#bu"䉊'F@Q EEHQT)FNQBEE(!UGUTXQjň+*B"1YTfQňX-*Bݢ"\TtQh/*B"1`TQFEh#bĨ"dcTQJFEH#b˨1"Ԍ3*ZUƈ4AӨQcD]UFE#b٨i"7FĺQFE#b"$8FQ*GE#BfWKG5H#b"Ԏ1wTQGE(QAyTQLj=*BcD,!}TQLjX?*"cD ՠTRȈA*BdD !TDR RȈB*B 5"T RȈD*BQ"R`EAHEH#T82"֑G*BI5($oNɈI*B%dD$]THIEH%#b+ԒKF^RIE(&#b2ͤ"DPMFlRI5'I5S ;dD'!T~2"PP*BB eD(TR:ʈR*BI)eDl)!TRqhS**o,*#bRM"DPUFĬRJE+#bYi"WޛBW*B^}"TRˈY*"e"r0TRRˈZ*Bl"TRˈ\*"sѥ"T1TRKE(/#bz"—ѰTTA=*"$`FS*LE0Ì!"bFSbLET {LE2ȌI"2je*" LE2!T23"f*BLE3T@3"jh*By*h"4J)(&LJI4ixAiRd9ҤIV0)&LJI&D4)ҤJ"+Mx4aP*Md RiRd 7gI4aP*MJ&Yi¤T0)&MҤJn.&LJI4i&LJ RiRd Q*M4)ZN +#pPIzoJ&YiT={J&Yi$)M$I4i&FRxsR4J&Yi$)M$I&Fh~J#)Mz4q&EV:(MV4J'IiT>14i&N҄I41҄o_IR4J&Yib$I&FFsJ+Md4q^TtsV8iwT*M$zGҤIV4JQ4i&NZJ"+MJI&FzGIÎz2)&LJZT4J&Yi⤭Q4i&NZJ&Yi$+MzGҤIV-JI&FzGҤJ&Yi⤹Q4i&FzGI{4i&J&Yi$)M;*&\*M$I4i&FKRiRdѵQ4!ҤIV8iyQO'mJI7grGҤAV8iwT*MdI41ZJ&Yi$+M;*&FSRib;*&=V8iwT*MJ'-JI7'I4qZT4J'JI&FzGҤ;nI41J"+MzGҤJ&Yi$+M>g4i&FKRi +MdzEҤIV+i+*&T8i}XQO'J\TYiIKRi$+M$zCYiҍYi⠥P4i&MIR4J&YibJ^P4~[i⤵^P4)hT*MdI4qR/(+MJYib *&MIKRi$+MdzAYib3)&i+Mcѵ^N4)Ҥ;nz9ҤIV4IJ-T-TrJI4i&NZJ&Yibt-S*M4ݔJT4J#)Mz7Ҥ;nz7ҤIV4IJ-rJIfI4qV/T4J'-rҤJfI&}V8iS*M41)&MҤIV8i& J Ri⤵@*M9+Mdz;h*S*Mr;mVvJI4i&NZJnJ&Yi$)MdI4qN8(MvJz;ҤIo>)&FN4N҄I4qVoTMvJz;ҤIV8i-S*Md~oҤҤIV8iS*M$z;YiRc>z;ҤJ&Yi⤭N44q&NdI4qZnO:(gڻ\ҌTgi*³4Y8KSTgiFgi*³4YY,MEx",MEx#:KTgi:4Y,MGt#:K tDgi:4,MGt#:KStCgi:Y,MGt"KStDgi*³4]gi:4Y,MGt#:KStDgi*³4Y,MGt":K ҼGY&8KTҼGҌJ3"VҼEҌfD4#byά4#b+{T(͈XiFJ3"Vf44#by +͈PiFJJ3"VҼGҌfD4#by +͈XiFJJ3"VҼGҌfD4ay*"TTJS*ME4#bTTJS*ME4#b"TPiFJS*ME4#b"TPiFJS*ME4#b"THiFJS*ME4Q4T׿PiFJS*ME4#bB?QJS*͈Xi*B"TTJS*͈Xi*""TTJS*͈Xi*U(ME4#b"TTtwT4ҼGTJS*ME4#:TJS)hXi*B"TTJS*͈Xi*BhwT4#b"TTJS*ME4#b"TPiFJS *ME4#b"TPiޣBi*BfD4TJS*͈Xi*BfD4TJS*͈Xi*Bf44TJS*͈Xi*B"TTJS*͈Xi*B"TTJS*{T(ME4TJ3"TjPi*B+MEzGJS*͈Xi*B"TTJS*͈Xi*B"TTJS*͈PiJS *͈Xi*BfD4TJS*{T(ME4TJ33*ME4Ҍ"TPi*B+ME4ՠҌTzCJ3"VPi*B+ME4TJ3"VPi*BfD4TJ3"VPi*B)"RjPiFJS*ME4Ҍ"TPiFJS *ME_SJ3"VPi*B+MEz9JS*͈Xi*""RѰTJS*͈Xi*B"TTDJS *{JSTBi*B+ME4Ҍ"TPi*B+ME4ՠTJ3"VPi*B+ME4TDJ3V+͈Xi*BhS4#b"TTJS*ME4M4TJS*͈Xi*BfD4TJS)hXi*BfD4TJS*͈Xi*BfD4TJS*͈Xi*B"TTJS)hXi*ǠTJJS*ME4#b"TPiFJS*ME4a_[Ҍ"TPiFJS)M54Ҍ"TPi*B+ME4Ҍ"TPi*B*M54ҼET4VJ3"VPҌfD4oQ4#b+͈XiޣBiFJ3"VPҌfD4+hXiFJJ3"VҌ=*fD4#by +͈XiFJJ3"VҌ=*fD4#by +͈PiFJUJS*ME4#b~X*͈Xi*"fD4TJS*͈Xi*B"TTJS*͈Xi*B"TTJS*͈Xi*B"RѰTJS*{T(ME4"TTJS*͈Xi*ЏxTJ3"VPi*BfD4TJ3"VHiAfD4TJ3"VzGJS*͈Xi*BfD4TJS*{T(ME4TJ3"VPi*" +ME4TJ3"VPi*B+ME4-*fD4TJ3"VPi*BfD4TJS*͈PiAfD4TJS*{T(ME4Ҍ"TPi*B+ME4Ҍ"TPi*B+ME4Ҍ"TPi*B+ME4TJ3"VPi*B+ME4TJ3"VPi*By "TPiFJS *ME4#bRBi*B+ME4T;PPi*B+ME4TJ3"VPi*B*M5SXiA+ME4Ҍ"TPi*By "TPiFJS*ME4#b"TPiFJS)M54#BPҌ"TPiFJS*ME4ՠҌ"TPi*B+ME4Ҍ"TPi*"yo TTJS*ME4#b"TTJSWTҌ"TPiFJSѥ^NTJ3"VHiAh4"TPiFJS*ME4Ҍ"RjPi#Vjz7JS*͈Xi*BfD4TJS*͈Xi*"^NTJS*͈Xi*B"RѰTT>XiFJS*ME4Ҍ"TPiFJS*ME4Ҽ7TJS*ME4#b"TTDJS *ME4a"TTJS*ME4#b"TTDJS *ME4#b"TPiFJS*ME4aJS*{T(ME4Ҍ"TPi*B+ME4Ҍ"T~oJ3"VPi*B+ME4ՠTDJ3VPi*BhS4TJ3"VPi*BfD4ՠTJUJSJr Bi*B+ME4TJJS*ME44#b"TTJS*ME4#B"TTJS)M54#b"TTJS*ME4#b"TPiFJS*ME4#b"RjPiޣBi:"鈔"THi:"鈔"T@i!#RHi:"#RHi:"#RHi*B鈔#RHi*B鈔#RPi:"鈔#PjPi:"鈔fD4tD׿Hi*B鈔#RPi:xtDJS*MG4tDJS*MG4TJ(M74TJ)MG4t4;#RPi:"鈔"THi:"鈔fD4tDJ^(VHi:#RHi:"#RHi*B鈔#RHi*B鈔#RPi:J)ME4tDJ)ME4ݐtDJS*MG4tDJ3"VHi:"#RHi:"#RHi*B鈔#RHi*B鈔#PjPi:"鈔#RPi:"鈔#RPi:"鈔"THi:"鈔"THi:"+MG4tDJS)M74TJѥQ4TJ)MG4b鈔#RPi:"鈔#RPi:"鈔"RnzEtCJS*MG4TJT(VHiFJ)MG4TJ)MG4tDJ)MG4tJ )ME4ݐtDJ)ME4tDJS*MG4tCJS*MG4tDJS*MG4TJ)MG4Ҍ#PnHi*B鈔#RHi*B鈔#RHi!hs.Hi*B鈔#RPi:ˉ#RPi:醔#PjPi:"鈔"THi:"鈔"T@i!*M7SXi:"#RHi*B鈔#RHi*BRHi*B鈔#RPi:"鈔#PjPi:*o4tDJ)MG4tDJ)ME4M`tJ3VHi:"鈔"THi:"#PnHi:#RHi*B鈔#RHi*B鈔#RPi:醔#RPi:"鈔#RPi:"T14Ҍ#RHi*B鈔#RHi*B鈔#PjPi:"*+ME4tDJS*MG4ݐtJS *MG4tDJS*MG4TJ)MG4TDJ )MG4Q4M4>(ͥIYi*z2)&LJI4ixAiRd9ҤIV0)&LJI&D4)ҤJ"+Mx4aP*Md RiRd 7gI4aP*MJ&Yi¤T0)&MҤJn.&LJI4i&LJ RiRd Q*M4)ҤJsxAibk_9+Md4q&MҤIR8HJYi$+M44i&MIR8IJ"+Mt틑&EVIiC`4)h.wAiҤIV8IJ'ҤAV4J'Ii¤TIiͥIR4J&Yib$I&FFsΩ4!ҤIV8IJ'JI7gzGҤIR8hwT*MdI41ZJ&Yi⤥Q4)ZTYibtwT*M='Ri¤TJI4i&NJ]zGIR4J&Yib;*&MhwT*M41;*&=V4J'JI41;*&NeI4qVT4J'Ii⤽Q4Ri$)MdI41ZJ"+MJI&MIÎz:iwT*M9+M;*& IsRi$+MdRT4J&Yi⤭Q41JQ4!IkRi¤T8iwT*M9)MdzGҤIV8iwT*M41;*&q+Md\TYib4;*&=V4J&YiaG=$I41ZJYi$+M+*&Mh~XQO^Q4ᎧIÊz:iWT*MzEҤJeWT*M+*&MAk4Ƭ4qRoT4J&Yi$)MdI41 V/Tt4qZ/TYib4 *&MҤIV8i& J 4YJ&Yi⤥^P4i&MIk4J&Z/TYiIsRi$+M$t~X*Mz9ҤIV4J'-rJI41)&DVLnJ @*Md&FkRiIsRi$+M$z9Ҥ[ҤIV8iS*Mdz9YiRcQ|ҤJ>}+M)&EV]J&Yi$+M4J҄A4qZp &ݜ&MI[Rib4)&F{6+Mz;ҤIV4J'-vJI7gI4qZoT4IJT ZoT8iS*M=I[RibTYJt*MJ'mvJToT8iS*Mdr;ҤAV8j*M9+Mdz;ҤIR8h&5V=hS*Mz4i&NJnJ'-vJI4i&ZtPIt_TgiFgiޣ,͈,͈,͈,[Ty4#4#4QqfD|fD|fD|=44#4QqfD|fDxf4|=*ҌҌҼGYMxfD|fD|=*ҌҌҌҼGYYY8K3">K3"KUgi*³4YY,MEx"KSҌTgi*³4YY,MEx"KSҌTgi*³4YY,MExfD|"KSҌTgi*³4Y8KSTgiFgi*³4YY,MEx"KSҌTgi*³4YY,MExfD|QY,͈,MEx"KS ҌTgi*³4Y8KSҌTgi*³4YY,MExfD|"KSҌTgi*³4YY,MExfD|"KSҼG|MY,͈,MEx"KSTgiFgi*4Y,͈,MEx"KSTDgiFgi**o|fD|"KSTDgiFgi*³4Y,͈,MEx"KSTgiFgi4Y:KSgim4AyohFB3Ѡϼ5όuf43AyofF23]f42A {&3$Ѡȼ7 2A qHPcƘѠŌ)a BhaF ްŒf4h0ى` a~ h_FR K5/AwإRj]FR K%$.ApjH[FR YK5D-ՐrjYFR !K5d,jWFR J5+ՀijVvjUU5*ASH Tsƨ!N4e4)ՐTCR IhR!Ge4(TBR hPP!@d4'LaTC0jH!xa4Հ:TBP h!qa4 7TCP `H^( AhbjHFP C5D Aajօj![ha4( ,TC0dj@*!TLa$H Ր(TC0j!M0a4h %TC0jj0#TC0Dj!Ba4ՐT|0ԃj!d7,TCn0djH !4`4HՐT`0jr߰TCX0j !) BA5TJ0Dj!"`4ՐTC<0ԁj!h`4$ TC.,PD*p,)Q@2&$:p|sHaRAB"ARd$H Ef  4R&%VnXY  0) M2I)aRAd3H \Al& $Ar&%văYRAGǓTߜ !M2"I˩z!M#I8HҤI#aB9iBdNH q@!N(Ȥ#]b犬 1+' RdY\-;n\H qx!N _H i!N1Ii 1ͥ2Ib4ΐ&b$iH!F FsڐsCdoq^$ts68iwTC$vzG%7JS_x+M]jK4yJSZiR*M\J(&>n+M^JK4u&Q*MVDx>7JS߂VJRiFmkK.FmK4u&~ԥVߨ4ZioVB4~oVͥ4qi+MFmK4u&/}oV:J.ԥVDJS7j+MJ~Է.䥏JSZioVuQ4u&}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]JCj{OCJSZiR+M^JK4u&T4V4Zi}VJSZi~ZiV8Jy?P[iR+M^zVJSZi~ZiҼT[iL+MqJSVq?N[iR+M]JCo}4>i+M]jK4yq?N[iR+MqJ&6moVJ(&~J>i+M]jK4yq?N[iZiR+M^4u&/=ǩL+M筕P+MoKqJS&8mK4u&/}ܯS+MJ[iZiR+M^_4i+MulIqN[iR+M]z_4i+M]jKuJSRi?ӷ>]_&:mK_봕.}^<_43uJ_V&/}ޯVDo봕&/}ݯVJ봕[[iZiR+M^zޯVJ>שL+MG[_4 hK4y~ǵ:mK4u&=JKU^\ W/tT\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+A4Xi bBGJ3f+A4XiJ3f+ V\i b9ȕf+ VA4 bJs+ VA4XirJ3f+A4cXiJ3fC5D+:* VA4 bJ3 WA4XirJ3f+A4XiJ3f+ V\i bJs+ VA4 bJ3 WA4XiQi bJs+VA4 }QGJs+ VA4XirJ3 WA4XiJ3f+A4c'ʕf +A4XiJ3f+ V/tTA4XiJ3f+A4Xi b9ȕf*VXiư bJs+ VA4 bJ3 WA4XiJ3f+A4Xi=ʕf*V\i bJs+ VA4ҌaEJ3f+A4~ߏQiJ3Hf + Uc\i b9ȕf+ VA4 RJ\iƼoQiJ3f+A4Xi b9ȕf*VA4 bJs+ VA4TiqtJ3f+ V\i b9ȕf+ VA4_4Xi b9ȕf+ V\iҌyܯ+14XiJ3f+ V\i b9ȕf*VA4 bJ3 WA4TiqtaJJ3f+A4Xi b9ȕf+ Uc\i zT\i b9ȕf*VA4Ǹ bJ3 WA4XirJ3f+A4cXiJ3 ǟ2JUΠV߭rJԥVJKUB4*M]jK[iVB4j)JS&4qh+MjK[i ǽ?P+MJԥV&.mK4Ziĥ4u.ĥ4qi+MV@[i z;W*MZiR+M^z~z4u.T:JSZiǥԥVJRiR*MVD/'ZiԷ&/jIqQU[iR+M^JK_V:JRiVD4q[iR*M]jK4Ri $=CqQUԥVJ7j+M}\+M^ߨ4u)&=7j+M]jK4.Fm)J~jI~ިo.mK[i=7j+M]jK4y|ԡVߨ4u.$zoVJqQ[i $zߨ4-hK4y~ԥVD&/}oT+MjC.uQ[iTJSZi=7j+MVD4u&/=yyQ[iZi|ԡVqQ[iR+M]jIߨ4u.J~$ߨ4-hKJFmKC4yyQ[iR+M^ߨ4ZioV[iR+MJSoVDJSZiR+M^zF}w)$zOV:JSZi~ԥVDM/δ$z4>8mK㴕.ԥT.qJSZi~Ziʴ$:Zi V4ZiߏVJSZi:ġ4qh+M^z9>.uJ|$:_VD봕.ԥV_4q4u&/=i+M]JCNuUD봕&/}ݯVo~{|$_| bJs+ VA4XirJ3HWA4o WA4XirJ3f*14Xi b9ȕf+ V\i bJs+VA4 zCSf+A4Xi bBGJ3f+A4XiJ3f+ VXiư b9ȕf+ U14 bJs+ VA4XirJ3f+A4XiJ3f*V/tTE4Ti,RYJHf+"T54Xi,RYJ3f*"UE4Xi,RJHf*"UA4Ti bYJHf*VE4TirYJH-RJHf* VEW.TJSZiR*MJC4u&Q*M~\*M]jK4y)&/jI?jIJS߂VJS&FUi oK4y)&/MC4u&/ĥ4RiTJSZijI{(&Q*M} ZiR+M^JK_>&/}oVJ.ԥVDJSZi~jI~Q[i $}Q[i?o7ĥ4.ԥVyQ[iP+M^zoVJSZi=7j+M]jIߨ4Zi$zoVxߨ4y7K47j+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&/ԥ_4Ҥ4u@m)J~ԥVJJġV4JSZi~ԥVJJ~JSgZiߏVB4䥏qJSZiR*Mz8}{mIq?N[iR+M]jKqJSZiV@4ii+M|ԥVD4۴VqM[iR+M]JCqJSJSZi8mK4yq?N4eZi?o4Zi?~+M^z܏VB4i+M]jK4y~ZiV8&/=JSJSZi:mIvN[i}g+MuJSZiR+M^zܯVVJ봕.=i+MuUD봕&/}ݯVo~{|$v:'cNa:r2Fv1&cTM(|71J&c`r {1%0Q+T2F1$cIa%H2Fd1,$cHƨ<2FudcFƨQ.rU1"ǰQ"2FA˸Qr c1J!cTBa2FV1 c@(2Fd !cT?(~Q8c10{Qq %1*c7.c$a1D5b b!lc"ƨD1Fb2Uc!ƠA Q2,Ca1cƨ=0FaucƠ: Qtp 1 ǰ7Qn01׏K1O1 cƨ20Fa1, cƨ/A^" cƨ-QZ8eaucƠ* QTp1 ǰ'QN0F11J cTaH0Da*1c(!QA8aCXƜG(|1 c a6j0F`1LcT ^0F`ۗǰQ*Rp Ct!cP a$F0F` 1 c(:0Fq`cT( QY`̛?ߗV ~9h@\2PR/ u} .m K[ 5FPP+Afġ u .m*(VXPZ 悸.5ĥ-qiA]j3(h .m6Ku .m9K xPPA? WAHu\B]jDK_O_.#ԥ7꯶P_xB]j]K yPZRC\Ɛ(!>n+C^JfK u!QJCD/o>7P߂憺ސFmrksKա.%;FmxK-u!~gPDQ " >y".mHߨMu-.5FQ#~Hԥ&&yQ[%RDFm(2~MԷq.N䥏>Q(o&uQu"}ovPR*FmXR+RsE]jHߨ-,oFZԥfRE<ߨu"/}oԀQZ0=7jF]jĨKy~c$zߨ-7j[F} 3~6gĥyqQ[44PFzoVԬ>7jFDmƍԺ~ojHvQ8[Q9R+G^JKu>o%#?,uԥƎu#?OԷ~6y#/=yu?Q=}OԆB-7}DmKu)#=>$=jH]jK y).ԥDSB|ԶC~6jIq?P[DRH]jK"y|6ġv42RF~6ԥ֑<@~&FRgIߏfB$7䥏qTRJRbIz8}{m/Iq?N[LRI]j3KqjRMӆ@-'iiI|6ԥ֓D'۴PR#J]JECqڎR֐RZR8mKK)yq?N)eS?o-*T?~6$JU)Ԭ~6ԥԴ>שq%m]CWˁ ,q-,u%/}ޯFDo봙%:}6$_M-u.5:mnkoK .yyN\RKu篫+$z_ /y~6ԥSK%}qN`6u~6䥯uSZb|ԡƘ~KusL}\{L]jKu$Sd:ʔiI~eM3um&/}ޯ֙晼_ 4u)5:i|JKkq_oAp?p Aq:fyq_Xr)Ar19 8cBǨ : <8ˎq1< >qqA~ c88A  O@q2#AZ @q% NA_#  Aq2{< NBqrG! Y B0d!8 9ېAouCqr!8ąAONDo1ĕA Nd"y)2SA܊ X kA ^d#y12AڌȠ:f#9ÑA\ t oGq<2A HqAr'$! Hdw$u,Id $8&9kA d%_X d7%yT2A KqY2Ӓ-q Kq^r%801 dG&293Aܙ d&yj2[A Mqo28 nN1: Nqwr'c<Aޞ }Qd'y2A\  oPq2+3< Nhf:+AiqI4ްv4XirJ3f+:* VA4XirJ3 WA4XiJ3f+A4XiҌa9ȕf+ V\i bJs+ VA4XirJ3 WA4Tiư|,RYJ3f*"UE4XiҬQJHf*"UA4Ti=;E4Xi,RJHf*"UA4Ti bYJHf*VE4TirYJH-RJHf* VEWYi bJs+ VA4_4XiϿA4 bJs+͠+ VA4 bJ3 WA4XirJ3f+A4XiJ3~J3 WA4XirJ3f+:* VA4XirJ3HWA4XiJ3f+A4Xi b9ȕf+ V\i bJs+ VA4XibJ3 WA4Xi| bJs+ VA4XirJ3 WA4XiJ3f*14Xi b9ȕf+ VA4 bJs'+ VA4XirJ3 f+ VA4ҌaJs+͠uTA4 bJ3 WA4XirJ3f+A4XiJ3~\iưJ3f+A4Xi bBGJ3f+A4XiJ3f+ V\iҌa9f + VA4 bJs+ VA4cXirJ3f+A4XiJ3~J3Hf*V\i bJs+ VA4ҌaEJ3f+A4~ߏQiJ3Hf + Uc\i b9ȕf+ VA4 RJ\iƼoQiJ3f+A4Xi b9ȕf*VA4 bJs+ VA4TiqtJ3f+ V\i b9ȕf+ VA4_4Xi b9ȕf+ V\iQiJ3f+A4Xi b9ȕf+ V\iҌaJs+ VA4XirJ3HWAVA4_4XiJ3f+ V\i R9ƕf+͠[G9ȕf+ V\iҌaJs+ VA4XirJ3 WA4XiJ3f+?4TiO+/ jͥ4qi+M]jK4W)JԥV&.m)Jh+MVB4Zi[JԡVP+M|\+MjC[iVJĥ4uP+M|V.ԥV&.m)Jh+MVB4eZi_&Q쫏kK4y)&/ԥVJRiP+M]jIJJSZiR+M^JK4ZiϾD4Zi_&/jIqQU[ig*M^JKSiP+MjK4qi+MT4y).ԥVD4Zi!8ߨ*M} ZiR+M^JK_>&/}oVJ.ԥVDJSZi~jI~Q[i $}Q[i?o7ĥ4.ԥVyQ[iP+M^zoVJSZi=7j+M]jIߨ4ZioVԥVqQ[iR+MJ7JSZiR*M^ߨ4q[iR*M]jK4P+MJS߂VJQ^ߨ4q4yyQ[iP+M^ߨ4u.$zoVJSZiFmIvQ[i}oVFmK[i~ǥԡV<ߨ4u&/}oVB47j+M}4u&Fm)J~Է.ԥVR*MjI84u.DmK4>yE&4yJ~j/&/='j+M]jK4yyP4a4yqP[iR+M]jK4u.$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ޯVJ>y=* [i߯VuN[i翿uJ>_4EoK[i:mIvN[i:mK4yyN[iP+M^>.:mK4y~Ziʴ$wTEuJS߀VJ>i+M}\+M^zܯVJSZi|4Wݥ ?- nif4-:4- nif49[A f4qK3[A- niiK3[- nif4-A f49[A oiqK3H[1|cKH[E f4Y- niaKF[A,Җf4-"miiKH[A,Җf4Y􆝲"miiK3[E,Җf4Y-"lipKH[E-"mi_)*Җf4Y- ni?U-"miqKH[E,Җf4Y- niaKF[E f4-͢f4Y-͢FyKH[E,Җ oiiKH[E f4-"miiKH[A,Җf4Y-"miiK3[E,Җf4Y-"miqKH[E,Җf4kY- niiKH[E-"miiK3[E,Җf4Y-"miqKH[E,Җf4Y-niiKH[E f4Y- niiKH[A,Җf4-"miiKs4Y-"miiKF[E ff4Y-"miiK3[E,Җf4Y-"miqKH[E ҖfDqKF[A,Җf~Y-"miiKs4Y-"miqKH[E f4Y- niaKF[AҬіf4-"miiK3[E,–f4Y-"miiK3[E,Җf4[E-"lihK3[E,Җf4Y-"miiKF[E?ThK3[E,Җf4~ߏ4-"lihK[1,Җf4Y-"miiK3[EҬі niּo4-"mi=[E,Җf4Y-miiK3[E,Җf4Y-"lipKyf4Y-"miqKH[E Җf4Y-1,Җf4-"miiK3[EҬіf4cY-"miqKH[E,Җf4Y- niaKF[E f4Y- niiK[1,hKH[Y-"miqKH[E,Җf4Y-niiK?4Y-͢:yK[5,–f 4Y-"miqKH[E f4Y- mihKH[/tliaK8+A4_˕ 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+ VA4 bJs+ U14XirJ3 WAouTA4 bJs+ VA4XiQi bJs+ VA4Ǹ bJ3 WA4XirJ3f+A4XiJ3f+ V\i bJs+VA4 bJ3 f+ V\i bJs+ VA4 bJ3 WA4TiqJ3f+A474XirJ3 WA4XiJ3f+:* VA4XibJ3 WA74XirJ3f+A4XiJ3f+ V\i b9fDҌa9ȕf+ VXi bJJ3f+ V\i b9ȕf+ VA4 RJs+VA4XirJ3 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+A4Xi R2GJ3f+A4XiJ3Hf + Uc\i b9ȕf+ VA4 bJs+ U14XirJ3f+A4XiJ3>J3 f+ V\i bJs+ VA4Ǹ b~K4 bJs+ U14Tiq~wGJs+ VA4 bJ3 V14XiAWJyYirBG9ȕ W\iAW9ȕ W\iQir9ȕ  W\irB4ǸJJs+A4Ǹ|Js+:*A4JJs+A4|Js+:*A4J* VA4 bJ3 WA4cXirJ3f+A4Xi b9ȕf+ V\i bJs+ VA4 bJ3HWA4XiQi XirJ3 WAW&/}oVJ.ԥVDJSZi~jI~Q[i $}Q[i?o7ĥ4.ԥVyQ[iP+M^zoVJSZi=7j+M]jIߨ4ZioVԥVqQ[iR+MJRiR*MjC.TuQ[iTJSZi=7j+MVD4u&/=yyQ[iZi|ԡVqQ[iR+M]jIߨ4u.J~$ߨ4-hKJFmKC4yyQ[iR+M^ߨ4ZioV[iR+MJS&FmoA+M]jK4yݥT:Jq>Q[iP+M]jKJSZi}D}>'j+M|[i'K_&Dm)JS_x+M^zOVJSRiP*MTV<_4u.2.ԥVDSi|V[i~jIq?P[iR+M]jKjC[iP+M@mK4yq?P[iR+M]jKjIvOSin34i+MV[i8mK4u)&䡯_&8mK4u&/=i+M]jI~>N[iҤyߦ4 JSZi$zoV[i6mK4u)&=i+M}Z+M]jK㴕.8ҔiItj4yq?N[i $z4u.TyN[iVr`+M}\+M]jK봕&:mIuN4>i+M]jK4yqN[iZiR+M^zޯVJ>y=* 4i+M^_4uT:mItyܯVĥ4y~$z_4y~ԥV<_4u&/RJSJSZi~ԥT&/=i+M]JC4yyN4翸f4Y-"miiKs4Y-"miqKH[E f4Y- mihKH[A,Җf4k-"mi%niiKH[E f4Y- niiKH[A,Җf4k9[[E\-E\-"mi.yKs 4[[E\-E\-"mi.–"liiKs4aKs4[Y-E\-E?oihKs4aK3[J"liiKs4aKH[~Z-E,Җ"li.–"liiKs4aKH[~\-E,Җ"li.–f4o4aKH[[E\-E\- ni.–"li.–f4aKs[5\-E\-"mi.–"liiKs4aKs4[-E\-E,Җ"liaKs 4aKH[[-E\-"mi.–"li.–f4aKs4[[E\-E?oihKs4aKs4[[E\-E,Җ"li.–"liiKs4aK3[[Y-5\-"mi.}Q\-"mi.–"li.–f4aKs4[[E\-E,–暷ҖliiKs4aKH[[-E-E,Җ"li.–f4aKs4aKH[~\-"li"li.–f4aKsrH[-5,Җ"li.–"liiKs4aKH[[~Ҍ梟4`KH[[Y-E\-"li梟V`KH[[E\~[E\li.yKF[[E\-E\-"mi.yKs 4~[E\-E,Җ"li.–"liiKs{0k[E\-E,Җ"li.–梟4kyӖf4aKs4aKH[[E\-E\f 4V[Y-E\-"mi.yKs 4Y-E\-"mi.–"li.–f4aKs4-5\-"mi.–"li.–f4aKs[5\t"liqKs4aKH[[Y-E\f4aKs-UniiKs4aKH[~\-E?oihKs4aKs4[Y-E\-E,–li.–\-~-4|Js+A4Js+A4_4JJs+A4|!Wc\irBG9ȕ Vc\iQir9ȕ  W\irBG9蝕 W\iQir9ȕ  WXiq]f+ V\i bJs+ U14 bJ3 WA4XiJ3f+A4Xi b9ȕf+ V\i bJs+ VA4_4XiϿA4 bJs+͠+ VA4 bJ3 WA4XirJ3f+A4XiJ3~J3 WA4XirJ3f+:* VA4XirJ3HWA4XiJ3f+A4Xi b9ȕf+ V\i bJs+͠:* VXiư b9ȕf+ VA4_4XiJ3f+ V\i b9ȕf+ VA4 bJs+ VA4XirJ3f+A4XiJ3f+ V\i zoQi bJs+VA4 }QGJs+ VA4XirJ3 WA4XiJ3f+A4c'ʕf +A4XiJ3f+ V/tTAuTA4 bJs+ VA4XirJ3 V14XiJ3f+A4XiҌa9ȕf+ VA4 bJs+ VA4TiQiҌa9ȕf+ VA4 b(W14~չ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+A4]r\Y\TH?1u1ᮨ',!.WJ3 WA4XiJ3f*1434XiRi b9ȕf+ VA4 bJs+ VATJs+ VA4 RJ3HWA4XiJ3f+A4Xi b9f + VViPiCKJs+ VA4XiRi bJs+ VA4 bJ3 V14XirJ3Hf +A4XiJ3f+ V\i bJs+ VA4 bJ3-f*"UA4Ti,RJf* VE4Ti bYJHf* VE4Ti,RYJHf+"UE4Xi,RYJ3f*͢'\i,Ti,RYJ3fHf* VE4Ti bYJHf+"T54Ti,RYJ3fm\i bYJHf+"UE4TirYJHf* VE4Piư,RYJHf+"UE4Xi,RYJ3f*"UA4Ti,RJHf*"UA4kTi bYJHf*A4Ti Gf*"UE4Xi,RJHf*"UA4TiҌaYJHf* VE4Ti bYJHf+"UE4Ti,RY(WE4Ti RYJHf+͢rYJ3f*"UE4Xi,RJHf*"UA4Ti RYs۟(V54Xi,RJHf*"U\i,RYJ3f*"UA4Ti,RJf* U54Ti bYJHf+"UE4kTi,RYJHf+"UE4Xi,RYJs+"T54QYJHf* VE4JFfU bYJHf+͢qrYJ3f*UE4cXi,RJHf*"UA4Pi֨J涿M4Ti,RYJ3f*"UE4XiҬQYJ3f*"UA4Ti,BJhycJHf*"UA4Ti bYJHf*14Ti,RJHf* VE4kTiҌaYJHf+"UE4Ti,RYJ3f*UE4Xi,RYJ3f*"T1434TirYJHf?4Ti,RJHf*VE4o bYJHf+"T54Piư,RYJHf+"UE4Xi,RYJ3Hf*"UoTE7UƷJo`ҠVA\:&.JSZiR+K*MVԥVt*M\:P+MSi j)J߂V8t*MjKjkC4qTt*M]jKĥSiR+MVSiҩ4u.ĥSiҩ4ZiJSP*MV߁oo&Q'.TJSZiR*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;&/ԥFJ豿QjIQԷ.Ǐ7K:>&/=7T:Ju*M]jK4u*M]jK4y鵿Q$oԩ47TFJNK:>.QԥVJu*MVDu*M}4u&}N)J趿QԷ.ԥVFv)$zOԩ4u.DJSZiTB48JSZiR*Mzx~=g{NItSiR+M]jKq:.$\SiҤoө4 8.$JIJSVtߦSiR+M]JCq:>.8JSZicZiʴ$ZZi &/=TB4>TJSZi}ZiЩ4qTqTVJ^t*M:Jk}^4t*M]jK4y)&:JSZisNK4yuV@|4>TNԥTk}NIyө4EJNKu:&mNK_t*M]jKu:[ǵԥV_SiR*MS+MVD?GW_SiJSZikNkKu:.ԡV<\_oo毗Ѷ9[oli oi_mi oi-[9[oli oiyKs4yK-A-1|eKs4yK-A-A|eKs4yKs4h-A|eKs4qKs4mK3[A4- nif4c9[A f4yK3S0A oiqK3[- niqKs4-A f49[A -[A ([- nif-A f49[A oiiK3[A- niqKs4nliqKs4-A f4F˖f4-A f4xK3[A oiqK3[- niqKs4-A f49[A f4qK3[A- niqK3[oliqK3[f4-A f4yK3[A oi}o4xK3[A oiqK3[A- niqKs4- nif4F˖f4-AҌf4yK3c- nif4-A f4yK3[A oiqK3 ni'[1- niqKs4- niѲ- niqKs4-A f49[AҌ nipK3[A- niqKs4-nif@-[A- niqKs4- miͲ-ni[A f4yK3[A-ni]DpKs4-A eK3[-niiKs4-A f49[AҌy4cn۴liqKs4-A f49[AҌf4yK3[A- niqK3H[cyKs4- nif49[A f4f f49[A oiiK3[A- niqKs4- nif49[AҌf4yK3s- nif49[AniqK- niqKs4- nif4liqK3?겥9[A oiiK3[A- niqK3[- nif4-AҌfs}-͠4vݷJ3 WA4Xi| bJ3 WA4XirJ3f+A4cXi=UirJ3Hf +A4XiJ3f+ V\i bJs+ VA4 bJ3-f*"UA4Ti,RJf* VE4Ti bYJHf* VE4Ti,RYJHf+"UE4Xi,RYJ3f*"U\i,Ti,RYJ3fHf* VE4Ti bYJHf+"T54Ti,RY(WErYJ3f*"UA4Ti,R9ȕf*"UE4Xi,BJHf*"UA4Ti bYJHf* VE4Ti,RYJHf+"UE4TiҬQYJ3f*"UE4,RYJ3f*"UE4>Ti,RJHf*"UA4TiҌaYJHf* VE4Ti bYJHf+"UE4Ti,RYJs+"UE4TiҬQYJ3fF,RJHf*"UA4Ti bYJHf* VE4_ҬO+UA4Ti bYJHf*A4Ti,RJHf*͠UE4Ti bYJFf*UE4Ti,RYJ3f*"T54Xi,RYJ3f*"UA4Ti,B9ƕf*UA4Ti,RJHf* U54.uBf+"UE4Xi}쏓+"UA4Pi֨,BJHf* VE4Ti bYJF V5mrYJ3f*"UA4Ti,RJf*"UA4Ti bYJHf*VE+ VE4Ti bYJHf+"UE4PiqYJHf* VE4TinpV54Piư,RYJ3f*"UE4Xi,RJf*"UA4Ti,RJHf*VEUE4,RYJ3f*"UE4Xi,BJHf-UWA4Ti bYJFf*VE4Ti bYJHf+"UE4TiҬQYJJJ_wJs+7Z*A4J/*A4JJs+A4h4Js+7r9ƕ WoT\ib9ƕ- W\iRir9ȕ WoT\ir9ȕ- W\iRir9WVi b9ȕf+ VA4} RJs+ VA4XirJ3f+A4XiJ3f+ V\i b9ȕf+ VA4Ǹ bJJ3fJs+ VA4 ? b9ȕf+ VA4 bJs+ U14XirJ3 WAZ* V\i b9ȕf+ VA4h4Xi b9ȕf+ Uc>Xi bJs+ VA4 bJ3 WA4XirJ3f+A4Xi b9f + V\i bJJ3f+A4Xi b9胕f+ V\i bJs+ VA4Ǹ bJ3 WA4XiJ3f+A4Xi b9ȕf+ VoTA4XiJ3sJs+͠Z* V\i bJs+ VA4 bJ3 WA4Xibs۟(W14 bJs+ 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+A4b9ȕf+ VA4 RJ3 WA4XirJ3f*14֟7W\i bJs+ VA4 bJ3H,f+ VA4 bJs+ U14TiqJ3 WA4XiJ3f+A4Tiư b9ȕf+ VA4 bJs+͠ + VoTA4XirJ3f+A4XiJ3f-եJ3f+A4Tiư R9ƕf+ VA4 bJs+ VA4XibJ3_UA7U[70yiP+͠_.JNK4uoP+ViR+M\:&.JS&Щ4Zi joA+M:ĥSi ǵԡV8t*M\:.ĥSiҩ4uP+M|ܩ4qTJSZiҩ4qTB4N)JS(L+JҷJ(ǵԥVJRiR+M]JRiP+M]jIJJSZiR+M^JK4ZiD4ZiԷ&/jIt_ߨoVJRiT:JSZiR*M\:&Q*M|ܩ4y).ԥVD4Zi}?7[oA+M]jK4ykNkK:.FJSZiR+MFJSZicN)JsN)JcNKo/NK$zoԩ4u.FJSZicNK4u&sNK4u*MVDu*M} ZiR+M^oԩ4u&FJ7FJSZiR*M^ߨSiNK4u.$zoԩ4Zi}oԩ4-hK4ykNkK:FJSZiR+MFJSZiR+M^zoԩ4nu*M:4y鹿QĥSicNKC4y蹿QԥVtߨSi $ߨSi oK4u*MVD:4u.7K4u&c}NC4u&/='TJ'TOKOԯ'TD:P+M}4y?QԥVJ JSJ u*M]jK4y).ԥVDSiҼT[isN)J?PԥVJJNC4iu*M]jK:.ԥ:P*M>M/δ$Si Jt*M]jK4yqן;&}NK4u&/=TJs}N J涿M7TJ(&sN/&/TJSRicNOkK4y?NԥVV24֟VB4oKq:P+Mq:.ԥVt_V8t*M:&/=8>.:J趾N$Z_W+M:JSZiR+M^zө4q4u&/=TJ?^_lķJsNK_t*M]zM_/TD:J_4qT_SiTNԥV\_SiP+M^z*M}\+M]jKu:.:ҔiIwTEu:4u&/TV_SiR*MjCuVi^_Viv_u~l[A- niqK3[oliqK3[A- niqKs4- nif 49[A Җf 4yK3[A- niqK3[- niqKs4-A f4cF˖f4-"miiKH[A,–f4Y-"miiK3[E,Җf4Y-"miqKH[E,Җf4Y- niiKH[EҌf49[E,H[A,Җf4Y?U-"miqKH[E,Җf4Y- niaKF[E f4-͢FyKH[A,(oiqKH[E,Җ oiiKH[E f4-"miiKH[A,ҖfsY-"miiK3[E,Җf4Y-"miqKH[E,Җf4kY- niiKH[E-"miiK3[E,Җf4Y-"miqKH[E,Җf4Y-niiKH[E f4Y- niiKH[A,Җf4-"miiKs4Y-"miiKs-͢f4n,Җf4-"miiK3[E,Җf4Y-"miiK?QҬіf4Y- niiKH[E-"miiKH[A,Җf4Y-"miiK3[EҬy/4kY-"miqKH[E f4Y- niiKH[E f4-"miiK[cY-miqKH[E,Җf4Y- mihKrB[A,Җf4Y?N,Җf4Y-"lipKH[E f4Y- niaKF[Ys&oiiK3[E,Җf4Y-"miݴY-miiK3[E,Җf4Y-"lipKhyf4Y-"miqKH[E f4Y-1,Җf4-"miiK3[EҬіf4cY-"miqKH[E,Җf4Y- niaKF[E f4Y- niiK[1,hKH[Y-"miqKH[E,Җf4Y-niiK?4Y-"miqK[5,–f 4Y-"miqKH[E f4Y- mihKH[oliݰ{Js+7Z*A4J/*A4JJs+A4h4Js+7r9ƕ WoT\ib9ƕ- W\iRir9ȕ WoT\ir9ȕ- W\iRir9WVi b9ȕf+ VA4 RJs+ VA4XirJ3f+A4XiJ3f+ V\i b9ȕf+ VA4Ǹ bJJ3fJs+ VA4 ? b9߿߬LWA4XirJ3 WA4cXiJ3f+A4nTA4 bJs+ VA4XiRi bJs+ VA4Ǹ bJ3 WA4XirJ3f+A4>7j4 bJ3 WA4XiJ3f+A4Xi bFKJ3 WA4XiJ3f+A4Xi b9ȕf+ Uc\i bJs+ VA4XirJ3 WA4XiJ3f+7Z* VA4XibJ3 WATA4Xi bJs+ VA4 bJ3 WA4Xibs۟(W14 ܟJ3f+ VoTA4XiJ3f+A4Xi b9ȕf*VXiư bJs+ VA4 bJ3 WA4XiJ3f+A4Xi R6KJ3 WA4XiJ3f+A4cXi]\+A4XiJ3cJ3 WA4cXiJ3f+A4Xi b9ȕf*VoJ3涿MKJs+ VA4 bJ3 WA4cXiJ3f+A4Xi R9ƕfJs+ VA4Xir?NK9ȕf+ VA4f4Xi b9ȕf+ V\iҌaJs+ VA4 bJ3 WA4XirJ3f+A4Xi b9ȕf+ Uc\igXi| bJs+ VA4XirJ3HWA4o. WA4XirJ3f*14Xi b9ȕf+ V\i bJs+VA4 |}O4+gg^8ef7d^d^֘-żƉ0nR4 //EKOĭ剖W7Nfy)X^}J+N*/o4qʫ'іR4SQ^8 7O^8ՍM^6WxYN~$/n|+$)m#/o4oI7C^H yy6"~FoxEy-^s+Z9^$77^[x6hњFR_#ֈD nvZ$\S-^HxyƊ"hx->8/÷:O47%^Z^#^~J[e8$'p-/o4;e8ֆ7p:KZ|./ /Ek *2qz«'&e867^xe8v7p/oe8&ⱼ '-2&O Fke8FsyNw}ky]hw}⵼ FJ_pO9}7]hw-pKќZ|./ ..o4Ỿ22rS]xe8z7p:.oлe8m卆y7Z]x-/myNw-4xx7pһX^S]~JrmOXޅӶ]hvyU$m7ڳ]hv-dY8 ڀsyNv)ڭ],bFsmծo'$gW}yNfvyf'?=oʮ}yNQvy9卶d7˓p*MȮŧ]c඼`FkkTZ<Db_i E8m卆a7R]x,O.?1卖`7^˓p o<'%hu-R4XSy]&^syNuyef]7˛РĩNs쉸.?[7^˛p­kqpk7XZܗ7dZ7h]hu}㱼 'ͺvY7e]x.oɱ.oź>q&Z|.o‰o|-oɮ.o~xM8յX<7DVW_)nkyNXu-n˛p_˛pb-o<&Do˝tSM]h4u}㹼 'V}yZI]&Rx,o).͢.oZބSC]~JSM8P'?]xM>]V=v%| b4S FPAhIXC1 b5YT˨ QG1 b%Pj[RA,9 b7t* TAlQ rIĘ*=UAV b^5ȅU# vVZ RpꍖHU WEJTa) bUFEV"uYEJTg1*RULHVc"ZEJXm)*RU|+W""u\ALTs)*BìHeWAxE z)*RRHW"5`ET1+RV$,UX°aEÂX)+R'T趿QƊԌ1+R9Vx,X"UdE %+RNVHQY"eEb1+RfV,Yz"%gAΊ=+R~HZ: hEъI bV2HqZ %j5ԊU+RVbH wkEJ׊T1`+RVH%[c"lEJڂX)l+RV-S[""tn1L݊T)x+RH["oALT) b WHE\ vqEJT r WFH\J r5劔+(sEX)+RGW.5]"5uAT)+R_ĮH]B v5bqW.]һ"wA )+R71^z"%yE+RBH^:"zAը RWrH^ &|E+RWFQ_"}E+RW/_z"%E8+BW/`""uEJX),R,Fe`oU T"XJH`[qr1Xh0`ՃEc)#,RIĘH=a"UA (/°涿M 6,RpX0a"ŇE BQX19b"EA&N,BFhycXHb"UA .)_ bXHcR14i,RIJHqc &Ek:uaXHc"E@,RY21dz%E"F,RYB2d:"1%3j&Mr9YxHd"UE )R1,RQY2]eʢ[,>X),Riزe"T1 /^),RHfR ֘E 2d) RY8H}-fMVirJ󷕻AĥSiR+M]jy}[)JUJNKj t*MVB4Zi[JNC4qTB4q4u&JNK4qTt*M]j)Jw*M\:.ԥVt*M\:P+MSi zҼ|4/}4~q4u&/=l?*M]jK4y(ԥVD4q4uSE?JRi $+za9&Q*M} ZiR*MVDVi oK4y)&/}Y0[iP+M^JK$J;&/ԥVJ(m_}}Uԥu_/䥯:>&/7TJu*M]jK4u*M]jK:P+M:P+M:&/~Q\:&.J蹿QԥVJ^u*MjK:.ԥVD4q4u&cN)JsNoA+M]jK:.$ߨSiFԡV<ߨSiR+M^JK_u*M|ܩ4y).ԥVD:P+M:4u&/=~Q^zoԩ4q4y鹾QԡVtߨSiR+M]jIJQԥVߨSi7TD_u*M} ZisNKFJSJSZisNK4y龿QjIQJSZi7TB4nu*M} ZiR+M]jKooRiP+MDJSZiR+M^zOԩ4u&Q*MDJ_4yDJ?Qj/&/='TJSRisZiZicNK4u&/ԥVJh*M@JS_w+M^zԩ4ZiTJSZicZiЩ4q&sNK4y?PԥVJJ涿OSin3ө4t*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.:JSJSZisNK4yuV@|4>TNԥTk}NIyө4EJNKu:&mNK_t*M]jKu:[ǵԥu:.oRi}Ziʴ$;:JS߀VJ^t*M}\+M^zө4u):}4/}4U\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+ VA4 oRiJ3f+A4Xi bFKJ3f+A4XiJ3f+ V\i b9ȕf+ VA4 bJs+ VA4XirJ3f+A4cXiJ3f+ VoTA4XirJ3f+A4XiJ3f+ V\i R9ƕf+ VA4 bJ3 WA4XirJ3f+A4>7j4h4Xi b9f + V\i}oRiJ3f+ V\i zoRi bJs+ VA4ҌO+V\i b9ȕf+ VA4h4Xi b9ȕf+ V\i bJs+ U14ҌaJ3 WA4XirJ3Hf +A4Xi b9ȕf+ V\i bJmJ3Hf +A4Xi b9ȕf@- V14u. WA4Xir?NKJs+ U14TiqJ3?NKJ3f+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+͠ + VoTA4XirJ3f+A4XiJ3f-եJ3f+A4Tiư R9ƕf+ VA4 b_ bJ3 V14XiE[tCy}4[ j*Siҩ4u.Ҽjyq*M]jKĥSi RiJSP+MVġSiP+M\:P+M|\+MjCĥSiR+M\:&.JSZi ǝJNK4u&.JN)JTB4C4*K*MZiR+M^z~zUJSRiP*MjK4RiRiR+M]jK4y)P+Mݗ1VD4-hK4Zi7[/.TglC4y)&.J(&>TJSZiR+MTB4>xԷ.TQǵFJSRicNK4u&sNK4y鱿QjIQjIQ׏7KĥSi=7TJSZik}NC4y鱿QԥVJ蹿QԥVD::&sNK4y龿QԥVDu*M^ߨV:J^u*M]jK4y)&Щ4qTJSZi=7TB4>7TԥVFz鵿QǵFJSZi}NK4u&cNK4u&/7TD:&FJS߂VߨSiҩ4y鱿QǥԡV<ߨSiR+M^oԩ4Zi}oԩ4ԥVD:P+MFJS߂VJSZiۥT:J>QԡVJu*M]jItD^u*M|'K_u*MDJSV؟SiR+M]JCjkC:._SiR*M]jK4Ҥyԩ4u@JS&}NK4u&/=&JZi<TJu*M]jK4y?P4in4V: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_SisNK4yuV@|4>TNԥTk}NIyө4EJNKu:&mNK_t*M]jKu:[ǵԥV_SiR*MS+MVD?GW_SiJSZikNkKu:.ԡV<\_oo毗>eK3[- niqK- niqK3[-͠4yK3[A nipK3[- mipKsН[A oiqK3[A- niqK3[- nif4-7Z4Y- niiKH[E f4k-"miiKH[A,Җf4-"miiK3[E,Җf4Y-"miqKH[E,–f 4Y-A,Җf+EE f4-͢?!"miiK3[E,Җf4Y-͢FyK[5,Җf4Y- ni7[E f4-"miiKH[Y-"miiK3[E,–f 4Y-"miqKH[E f4Y-͠4Y- niiKH[E f4Y- mihKH[A,Җf49[E,Җf4Y-"miqKH[E f4Y- niiK[1,Җf4-"miiKH[A,Җf4Y-"miiK3[E,Җ oiiKH[E Җf4-͢f4Y-"miiK3[E,zo4Y-"miqKI"miiK?QҬіf4Y- niiKH[E-"miiKH[A,Җf4Y-"miiK3[EҬіf4kY-"miݵY-"miqKH[EҬіf4Y-"miqKH[E f4Y-1,–f4Y-"miiK3[E,Җf4kYt9pP- niiKH[A,'oiiK3[EҬіf4cY-"miqKH[E,Җf4>[Ys&oiiK3[E,Җf4Y-"miqK[5,Җf4Y- niiKH[EҌf- niiKH[E f4-"miiK[cY-"miiK3[E,Җf4Y-"lipKH[E f4Y-͠4Y- niaKF[E f4Y- niiK[1,hKH[Y-"miqKH[E,Җf4Y-niiK?4Y-"miqK[5,–f 4Y-"miqKH[E f4Y- mi|4h,iKo5m WoT\ir9ȕ_U\ir9ȕ- W\iRir9ȕ WoJs'+A4h4Js+7Z*A4|Js+A4h4Js+7Z*A4|Js+14 bJs+ VA4XirJ3 WA4XiJ3f+ V\i b9ȕf+ VA4 bJs+ VA4TiqJ3-f+ 7 WA4Xir bJs+ VA4XirJ3 WA4cXiJ3sJs+͠F-f+A4XiJ3f+ VoTA4XiJ3f*14Xi b9ȕf+ V\i bJs+ VA4 bJ3 WA4XiJ3fkJ3f+ VoTA4XirJ3f+A4XiJ3f+ V\i R9ƕf+ VA4 bJ3 WA4XirJ3f+A4Xi| bJ3 V14XirQKJs+ VA4XirJ3 WA4XiJ3S VXi'ʕf +A4XiJ3f+ VoTA4XiJ3fkJ3f+ V\iҌa9f + VA4 bJs+ VA4cXirJ3f+A4XiJ3f+ UoTA4cXirJ3f+A4XiJ3fEJ3f+A4>i4XirJ3f*14XiJ3f+ V\iҌaF4cn۴TA4 bJs+ VA4XirJ3f+A4Xii4Xi R9ƕfJs+ VA4XirJ3 WA4Xi| bJ3 WA4XirJ3f*14XiJ3f+ V\i b9ȕf*VA4 bJ3 WA4TiqaJJ3f+A4Xi b9ȕf+ Uc\i T\i b9ȕf*VA4Ǹ bJ3 WA4XirJ3f+A4cXiJ3J7JJ3 WA4Xi| bJ3 WA4XirJ3f+A4cXiJ3f*V\i b9ȕf+ VA4 bJ3 WA4^4 bJ3-f*"UA4Ti,RJf* VE4Ti bYJHf* VE4Ti,RYJHf+"UE4Xi,RYJ3f*"U\i,Ti,RYJ3fHf* VE4Ti bYJHf+"T54Ti,RYJ3fm\i bYJHf+"UE4TirYJHf* VE4^JHf*"UA4Ti bYJHf* VE4Ti,RYJHf+"UE4TiҬQY(WE4TiJHf* VE4Ti bYJHf+"UE4Ti,RYJ3f*"UE44Ti,RJHf* VE4Ti bYJH WE4Ti RYJHf+͢rYJ3f*"UE4Xi,RJHf*"UA4Ti RYs۟(V54Xi,RJHf*"U\i,RYJ3f*͢D,RYJHf+"T54Ti֨,RYJ3f*"UA4TiҬQJHf*"UA4Ti bYJHf*14Pi֨ bYJHf* VE4TiҬQYts4Xi,RJc\i z,BYJf +"UE4Xi,RYJ3f*UXiɕf* VE4Ti,RYJHf+"T54Ti,RYJ3f*"UE4cXi?o4Xi,RYJ3f*"UA4Ti,B9ƕf*"UE4Xi,RJf*"T14Ti bYJHf* VE4Ti,BYJHf+"UE4Ti,RYJ3f~Ff*A4Ti bYJHf* VE4Piư,RY~KՕf+"UE4XiҬQYJ3JHf*"UA4Ti bYJHf* U54TiRiTi!i> z61{$wN; 4q}oy&LgN;'ͼsLt02aZe4ʼɼ>sLiy}01?9&δƼ>sb;ĝwNy}焘g Ή0q &4s ;'iymN~ &%H?ηR&gĝfRw]NKIr3).q%InJm;-q$ԝ0 -eWd0G[d?{KIb R澽:J|+qu$ԝi+qi%δԝwNW)NU;*qM%4IQ ӠRc1F澽:jJSN[JIJ;_sBJ|V;JyΩ(q'WdĝFv絾:g5ԝgZ?}}uN;W甏29#4{ĝVZ_W7NFꜶim}uN؈?{Fiֈ;uNFi(4L{FiΨ;91#ext~39!|:Fyxt~>:'bIaZ0kn;9"^ĝċ:\ߜ:Xߜ-NEi;q"4YbQ>9Wė\QwsbE29"4TĝvXVgNx}s}rN; u>9'Oĝ։8Qw4Q䶾8&m#e>D0m57Iԝܜ w#NrDyxn~;gyN(s_S"NCDi;9"4Bܞ ^"9䇸P&s}mNztwRc}nNsjr;-u>77ĝ憺XƆ m e0 ng;9!L#C9!0ĝs_ߛgN]x}ą\~B|VBiX;9Ym{oNT(7&29A!'ĝ愺XߛNSBy q'7yY~[[D(7'!ԝ9!~ow^{sAc}oN:xr u絾7'͉uk}oN2;-u繽7ę悺Ymq<愂NPg{J߽<7ĝZߛSc}oN;)qa<[xy[׿m7v-ۍ8ۍmۍ8ۍFv o7v-ۍ8ۍFnAn|eqqqhnAn|eqyqhnAn7ZyqhnAnƿhn vcy1ۍAn v o7i1ۍ n7qq n7vc8 n7q1ۍt_ߨmq m7vcFvc_ v o7q1ۍ n7qq n7vc8ۍAnvcy1ۍAnƠF-ۍAn n7qq n7Ѳ n7qq1n vc8ۍAn v o7q1ۍAn n7qq n7vcAnvcy1ۍAn v-ۍAZy1ۍAn v o7q1ۍ n7qq1n vc8 n7q1ۍ n7vcAn vchn vc8ۍ1n v o7}oԲAn vc8ۍAn v o7q1ۍAn n7qqcnn7vc8ۍAn vchn vc8ۍAn v o7q1ۍAnƠ`nn7q1ۍ n7vcAn vc8ۍAn v o7q1ۍAn|e1Hۍ1n n7q1ۍ n7vc n n7qq>in zӲn7iqAn vc8ۍAnvy1涿Mvcy1ۍAn n7q1ۍn7qqAn vc8ۍAϛy1ۍAn v o7q1ۍ n7im n7q1ۍ n7vcc1n Ӳ8ۍAn vcy1ۍAn m7p1ۍ n7qqZ_e1h? n7Ѳ n7vcAn vcx1ۍATAn vcy1Hۍ1n vo7q1ۍAn n7qq n7vc mۍA7l7* V\i bJJ3f+ V\i b9ȕf+ VA4ҌaJs+ VA4cXirJ3 WA4XiJ3f+ V\i b9ȕf+ U14h4Ti bYJHf* VE4kTi,RYJHf+"UE4Ti,RYJ3f*"UE4Xi,RJHf*"T14TiJHf[J3f*"UA4>Oi4XirJ3f*14T\i bJs+ U14ȕfmJ3 WA4XirJ3f+A4Tiư b9ȕf+ V\i bJs+͕͠ WA4XiJ3f+A4Xi R6KJ3f+A4XiJ3Hf + Uc\i b9ȕf+ VA4 bJs+ U14XirJ3f+A4XiJ3h?J3-f]f+A4Xi b9ȕf+ Uc\i T\i b9ȕf*VA4Ǹ bJ3 WA4XirJ3f+A4cXiJ3J~^+ǿKZirTt*M]jK4/}4Zi^ܷJSZiҩ4qTB4N)JSP+M| ZiЩ4u&.JS&>ġSiҩ4u&.JNK4ZiNKԥVJNKj t*MVB4eZi^UחUD>.TJSZiR*MJC4u&Q*M~\*OٽǙ͚JO `Dկ7J6 ,Rg ?›K4u&/TB4g_TB4Ri[JRi $oԷJS_x+M]jK4yi*MjC4y)&.J(&>TJSZiR+MTB4>xԷ.TQǵFJSRicNK4u&sNK4y鱿QjIQjIQ׏7ͥSiҩ4u*M]jK4y鵾QԡVߨSiR+M]jIߨSiR+MFJS&FJS߂VJu*M]jIQ䥯jC4y赿QԥVJ7TSiR*M]jK4u*MVDu*M} ZiR+M^zx^zoԩ4q4y鹾QԡVtߨSiR+M]jIߨSiR+M]nYFJ趿Q$ߨSi[Ju*M\:&/=7TT:Ju*M]jK:P+M:VJ辿QjItߨSi[JSZiR+M^zx]JC4u*MjK4y?QԥVDO[ڟSi ?&/=&=TJSZiR*M]jK4Ҥyԩ4u@JS&}NK4u&/=&JZi<TJu*M]jK4y?P4in4V:JsN)JS_x+M^ө4u.Ǐ?v*M8JSZiR+M^zө4u&8J&mNo4u&Q*M6JS_x+M^oө4u.8JSJSZikNK4y?N4eZiZi ?~+M^zө4Zi}ө4u.:ġSiЩ4y4q4u&/TDu:&:ZiTJSZicNkK4y鹿NԥTZԡvqR;N]jImRMhl 5N$z8u'/WtԎsNK_+֎SqkNǩK8y)'/}8qtԎSq=GtB8>Gtԥvhqqs}NǩC8y?ZԥvԎ?ZԥvԎ^NItߨq}o8-hK:'.u:N}\:NjC:.FS'FS_x;N]jItߨq $o8-hǩK8u'/=Q.ԡvD:ԥvܟqR;N'-zO8񅟎?'tD:P;N}8y?Qԥv ՎS֎ u:N]jǩK8y).ԥvDqҼtqsN)Ԏ?PԥvԎՎNljC8iu:N]jK:.ԥvv4}S_t;NiI?Njǩ/'/tԎSqן;'}NǩK8u'/=tͥyS;N6߀qR;NtDm:vtߦqR;N]JCq:>.8Sqcqʴ$Zjǩvq $qR;N]jKujljCġqsˁqqR;N^z8nt:Nuz$8u.:S׎SqsNǩK8yuz{gk$uDt:N^_qϲZ_qgt:N|ѧĥqkNIt_q:Sqs}NǩC8y_8q8u'/=tԎS'ϟb}t:N}qR;N^z8q8y鱿Nԥu:'=[oK~l  qq3{Aв= qqs8=A g89{1  qq3H{1= qqs8= qg8=A g8y3{A煖="qi3{E,g8Y=qqH{E,za,{E,g8Y="qqH{E,g8Y= qiH{Eg89{E,ҿǨH{A,g8YUW8="qiH{A,g8Y=q_Ł" ti3Eg8Y="qqH{E, qiH{E g8="qiH{A,A f74Y oi~HA|ӖWiH{E g8Y= qhH{A,g89{E,g8Y="qqH{E g8Y-qi{1,g8="qiH{A,g8Y="qi3K{E, qiH{E g8=΢g8Y="qi3{E,g8Y="qqH{E gmY= qiH{A,g89{E,g8Ytߟ(qqH{E,g8Y= qhH{E g8="qa?P,g8="qi3{E,g8x{5 g8Y= qiH{Agѯ#  g8=΢qg8Y=qa3{E,g8Y="q$g8q涿M,g8Y= qiH{E g8kY= qiH{A,g8=΢8Y="qi3{E,g8Y="qg8Y= q{A,g8="qi3{E,g8Y="qq{5,g8Y="qqH{Eg~F{E="qi3{E,g8Y="qpH{EX="qi3{Eg8cY="qi3{E,g8Y="q}aF{EвYtvq^h8s;οh8s; - wq^h8s; s; - wqqys; - wqrys;A8/t8qr9wq b9g; vA8 RÎs; vA8qrĎ3g;A8q3g; vq b9g; vA8Ǹ bĎBKĎ3 b9g; vq}xq3g; vq b9gЯ2agaA8q3?ZKĎs; vA8 bĎ3煖3g; vq R9g; vA8 bĎs; vA8qrĎ3 u1 blM6:g; vA8aĎs; vA8q^h8q3g; vq b9g; vA8 bs; vA8qrĎ3g;A8q3g; vq by bĎ3赿Q8cq3c3 wA8q3g;A8q b9g; vq'g ;A8q3g; vZ: vA8qrtߟ3g; vqa9g ; vA8 bĎs; vA8cqrĎ3g;A8q3g; uY: u18 bĎ3 wA8qbÎ3xq b9g8-g;A8qư R9g; vq bĎs; u18/3涿MKĎs; vA8 bĎ3 wA8cq3g;A8q R9g wA8q3g;A8q Ry bĎ3 wA8qr3g:18q3g; vq b9g:vA8 bĎ3 wA8qqaĎBKĎ3 wA8q3g:18qc]:A8q3Hg ; ucq bĎs; vA8 bĎ3 v18qE[tAKs #51J8cTp^g170ތQts 16cmQh3F&1*6cl\3Ffb1l5cjƨԌQ9f2U14ǰьQBs 13CTg^qf 1*3kf֠ˬA*(Mf52kc(ǬAY-fR51ca ìAY3F f 1 0k_ Q|Y5/k՚? e %5eL 1-kP[ AkԲe BtPYʲe$5(,cXgye ŕ5h+kVƨAXYYV5*kT QQY2D9e jĔ5h)cR֠AHe *D1j(kP֠Q@Y~d 5H%kPJO_r2d d1&kM֠A29,0A/\d b1J%kPJ Q'YLd "55H$k~/$CH֠AY:2Fqd 5(#cF֠A*Qd $1*"kD֠5d bȚ(,A Y2Fd갂A d 1k?֠~QXc 5k=Ơz,$1*k<֠wQXڱc Z1LkP: tA̱c "55HkP8 pQX{X1qc 5(c6֠kAQcMc 5k3 gQX-cR5k~0cb,A c 1k/֠^AXv淟'+x t5cT-| $1*k~K++VAXV1Fb J5c)^) RF䶾6,k(ƨOAX:1Fqb 5(c&% KA(Mb 5k##F~{EQX!b :e5k!ƨAAXq5kƨ=AzX0Faa Ú߫E5hkƨ8ApXްajĆ5h c^ 4Ag̰a "41J kP/Y.A\8ma 1 k +AUMaIa5g2'QMX-aRšK5w!kP "ACa 5kP A;Xte Gdkԥh67s}NިCy?Zpԥ&Ƒ?ZrԥfΑ^uJGh֑kNoAsG^z q<=PGzou#/7ꤏBm>7ԏ›?RGFR $mNoA+H]jK yzw)%5$zOԉ!u5.5D RZDE.5:(SReH| 3>餙N'ԥϟe}{鵾N$<$OK':L趿N'䥯u:.:ZSkҿ9lZlRM^zӉ6u)&שݦLM?=鴛4ԥ֛_opcN©Ki8u'=[oK_$ /@^h Aw@ _@ A䅖)Aނ1 -k<9{<y!/B$ oB^hUA] -Ð 9ӐZ!yr!yB> DB OD^hوA^29;89K6ĭ EZd"A^ dd 7#y42A n Gq92ӑA܎ Gq>r#8  NHdG$"93Aܑ d$xJ2[Aв&9 8(9ȋA J}+达Qۮ KqY2ӒAܖqɠ%%UܛoH1\ oLqd2+<3teh2K<5ĭ Md&7 -A dG'yu2Aڝ .Oqz2ۓ<> Od(@?ZeG(B93Aܡ e(y2[A<㓃> Oe(dUܤ (Nljw}]A 2e)M9A\ < Sq2 A Tirg*Ster*Uı U\e*8X9ȋA feG+y2Aܭ2\ NWqr+c^Aޯ п8 A Xq23c! .Ye,8f5A e-q2?Q޴ Zq2tԎSq}q8qtrtv:SqtD_jIt_qR;N]jKu:>.:SqH|8>tNԥϟe}{鵾N$q,BÎHgѿ9VwA8q bYFg:vE8q bYHg;"uE8qQYBKYtS:A8/tqr9_uqr9煖s;A8/tqr9qq9煖s;A8Ǹqr9煖s;A8qr9 wZ:A8qr9wq b9g; vA8 RÎs; vA8qrĎ3g;A8q3g; vq b9g; vA8Ǹ bĎBKĎ3 b9g; vq}xq3]_{ 3g;A8qư b9g; vqGk8qrĎ3 wA8qq bĎs; vA8Ǹ bĎ3 wA8qrĎ3g;A8q3g; vq bĎs;vA8 bĎ3煖3g;A8q b9g7mRͯbĎ3 wA8qqĎ3g;A8q b9g; vq bĎs; vA8/tA8qĎ3g;A8>Gk8qrĎ3g;A8q3g; vq b9gmqư3g;A8q by bĎ3 wA8qrĎ3g;A8qưĎ3g; vq b9g;Π;~+ wA8q3g;A8q Ry RÎs; vA8qrĎ3 v18~vq b9g8-g;A8qư R9g; vq bĎs; u18/3涿MKĎs; vA8 bĎ3 wA8cq3g;A8q R9g wA8q3g;A8q Ry bĎ3 wA8qr3g:18q3g; vq b9g:Θ!vq bĎs; vA8Ǹ ϰ by bĎs; vA8qrĎ3HwA8ϱ. wA8qr3g:18q b9g; vq bĎs;vA8 ѷOҠvAo.NǩK8uuB8o.ĥq8qSP;NvġqP;N\:P;N|\;NjljCĥqR;N\:'.Sq ǝNǩK8u'.N)ԎtB8qʴ;ҷ(ǵԥvqR;N]JC8u.$OÏKǩK8u'/tB8g_tB8q[Ўq $oԷS_x;N]jK8yi:NjǩC8y)'.('>tSqR;NtB8>xԷ.K:tt@8int:N|NǩK8q=tq}NǩK8u)'=tvԎ^t:N]jKqj)ӎh֎SqcN)ԎsNǩK8u'/ש'NK/NǩkǩK8y鵿N$8Վ辿NԥvԎt:N}\;N]jKu:.ןq}8ykNǩK?k}NIy8ENKu:'mNK_t:N]jKu:sǵԥv_qR:NS;NvD?-z8 hǩK8y鵿Nǵ:SqP;NzӷK:wn29knq.q5p p^#c9p/o^C89ۛ.on^Ƴc9Nnn^{c89kc8yom.m^Cc9F3C,#1،.lh`3F1ukh[s 5csFYv5pV3F1ՌѦNjhQ3Fc9ihLs 4c4%1Ҍюff4c9#1Ќфe{b491όvNg|_fl曒2c41̌bf3p/3s!ZˌXneh*3FKc8s[!dh%s G2c1\Ȍ@f1c4ych3Fۘ1e c`sg1cQ̘/4E bf0c11Œf0p3F;1 `h3F1Z_hr /c4~M_^˗1^h2F1ڼ-^hr.knqm[e -7/]|ϐg.cr9#1ڸe.p2F1u[h2FӖclaZ^Ƴ1ZѨe6-h2D1=˘e,p2FS1ZѐXh2F+c8b MX|ϐ,c_1Z ve+p2FÕ1ڭVh2Fde+c4X1Ze*p2FS1ZP嘛v*c0S1 Fe&*cP91ڧ<Sh2>DӔcLaRhr W)c4JM1"e)cGyQ`2DccE)-Qhr w(c4C1 e̯ZOh~r 'c>ۓ1 Ohw2C:mNd'c48>7d&/íɐxi2FCc3Ld6&c411d%c.91ږѴ.KhX2F1Uɘ7%pR2F1ўIhM2Fcc%)-I`H"ޑьdV$c4"91тH`?2D1Xrxd#c49ˑ1ndf#p52F1ڌ,Fh02F{c8Eh+r "c!܉Yh%2F#Fd&"c91ڇGk X8r1c+A91t1c[ Ǝ\;1w bx%x b1 F1=r?ZKq ƏA?r2 'Al A 2dCA,!cn21 אA!Cr"2Id -Qd fA"9 b4r ƑA#G R Br6A$XIr&N2 AL%J0Z2d{ \L1 b39d fA&/A*'cNr;x2dA'PĄ2 e?Yr3 vA )  bL95erA *Ǹ bRĦr VA*UrX2iVi+Wr_2 'Al,Y2He C Z bl9ȵes A .Ǹ Z2e v^ bz9e ֗A//A 0X`13f+A0a0 R9)f[ Ƙ\c1 b s &Al29 R,3] A,3f83uf133,4h^hi4iL3fC j R9Ƶfs͠:- AL6lrj3f17Xn1 b9f 曃o1 bĄsFA8- 5|8-I|$yq8u.ҷSԥvt:N\:P;Nq j)Ԏ߂v8t:NjljKjljkǩC8qtt:N]jljKĥqR;Nvq8u.ĥq8qS~߁ouD?ǵԥvqR;N]JC8u.$JɏKǩK8u'/tB8g_ԃqԷ'/jIt_ߨovԎqן7f;NjK8qtD8qtԎSqjI1Ct_ߨo~ %vt;N}wo8ykNǩkK:.hSqR;NhSqcN)ԎsN)ԎcNK֛Kĥq=GtԎSqk}NǩC8y?ZԥvԎ?ZԥvD:P;N:8u'/7tԎsNK_ՎSqkNǩK8y)'/}o8qtԎSq=7tB8>7tԥvFߨqqs}NǩC6yͯz8E$z8u.h?Z$q[Ўu:N\:'/=Gtt:Ԏu:N]jK:P;N:h?ZjItq[ЎSqR;N^zx]JǩC8u:NjǩK8y?QԥvDO[ڟq ?'/='=tԎSqR:N]jǩK8y8u@S'}NǩK8u'/='q<tԎu:N]jǩK8y?P8in4v:ӎsN)ԎS_x;N^8u.Ǐ?v:N8SqR;N^z8u'8'mNljo8u'Q:N6S_x;N^o8u.8S֎SqkNǩK8y?N8eqq ?~;N^z8q}8u.:ġq8y8q8u'/tDu:':qtԎSqcNǩkǩK8y鹿Nԥt:ީLeV*h2D1BTh2FcNqlShr )c4L]R*eF)cI91Z e (/9Qhr (c4E% Qef(cB9F#!ڠu @ c8@Odx{2Fӓc<N`vrW'c4:1d'c79s1X e5r[_/Mhhr w&c431d&&c091ؗ Ѽd%|j\2Fے1e KhW2k{n*NJhQ2F1ړ9IhLr $c4%% I^;1ъdF$pC2F1ZGh>2C8MGrd#c1\hd6#p22!^Eh-2Fc1ڊé-E`(rw"c#ZHe-D@d!c4u16d !p2FÐ1gzr W!c4 M1"d!c9s1Zd p 2FK1@h2F#c -@5d er9x%vpA-~pA./$rDx"p;A /pSAn /Ą\bN8=ᅖpAN /4rU8YᅖpA. 9-r\8uᅖpA Ǹ00a#A 3 bh8ȥaR6 bnp ALrt0 wA X1=0aA1@ R8 b FZ* fAsnCA."E1Cy{.5̯=Pp];A8q3k3 wA8cq3g;A8q b9g:v/3沿MKĎs; vA8 bĎ3 wA8cq3g;A8q R9g wA8q3g;A8q R2KĎ3g;A8q3Hg ; ucq b9g; vA8 bĎs; u18qrĎ3g;A8q3h?Î3蹿NKĎ3 wA8q3g:18qc]:A8q3Hg ; ucq bĎs; vA8 bĎ3 v18qA[tAq3g; v/tA8q3g;A8q b9g ; vq RÎs; vA8 bĎ3 wA8q3g;A8qaBKYHg;"uE8q,BY3g:"uE8q,RY3g:"uA8q,RĎHg: vE8qaYH wE8"uA8q bYS:*uA8q,z;"uE8qQY3g:"uA8.厳Hg;"uE8q,RYs;"uE8q,RY3g:"uE8q,RĎHg:"uA8q bYHg: vE8q RYHg;"uE8qrYHg;"uE8q,RY3g:"uE8q,BÎHg:"uA8q,zo;"o) REh:"uE8q,R9g:"uE8q֨,RĎkq bYHg: vE8q,RYHg;"uE8q\7g: vE8q,RYH wE8q bYHg;"uE8q,BY3Hg:"uE8q,RĎHg:uA8q,RĎHg: vE8q=g:uA8q,RĎHg: u58>p]: vE8q,'wE8qQY3g:"uA8q,RĎg:A8k.䎳Hg;"uE8q}o;"uA8q֨,RĎHg: vE8qaY~cĎHg:"uA8q bYHg:18q,RĎHg: vE8kqaYHg;"uE8q,RY3g:uE8q,RY3g:"t1838qrYHg;"uE8q,RY3g:΢s8q,RĎk}qaYHg: vE8q,RYHg:uE8_h8.8n?;? Kqt:N\:.ԥv/8q~.ĥq8qSP;NvġqP;N\:P;N|\;NjljCĥqR;N\:'.Sq ǝNǩK8u'.N)ԎtB8qʴq~$ʟ}q8u'/tԎSqP:NjǩK8qqR;N]jK8y)5'QKS'Q:N} qR:NvDq oǩK8y)'/MǩC8u'/ĥqǝqR;N]jIS'+7]Ǚ_Sߓvvu:N}\;N^z8u)'GtԎSqGtԎnu:NvDu:NvD_u:N^zz\:'.?ZԥvԎu:NjK:.ԥvD:.$8q}q[ЎSquNǩK87tߨv:Ԏu:N]jK8y鹿QǝqR;N]jItߨq $ߨq[ЎSqcNǩkK:]7tߨqR;NFSqR;N^zo8.u7M_q{Ҏu:N\:'/Gtt:Ԏu:N]jK:P;N:vԎ?ZjItq[ЎSqR;N^z]JǩC8nu:NjǩK8y龿YԥvD_o[߬q ?'/Yo/=7tDoA:vt۟qR;N]JCjǩkC:.ԥvSqR;N8iu:N}8y?PjItqR;N]jKjljCġv4:.@SqR;N^T;N>Mǩ/δ$q tqR:Nzz=`$8u.8Sq}8q\tSq$o86SqR:N8i8u'/=tԎnԎS'P;N8S'8SqR;N^S;N:'8>.:貾N$zӣ'uNǩK8u'/tvԎt:N]JC_CFGIN:S:h?s_q>'.t:N:t:N]jKu:sǵԥvt_qR:NS;NvDh-8 hǩK8y鱿Nǵ:SqP;NӏK~6v=Z8}qs8y8ys8y=A=Z8ys8y9{B qqв9{B q qв9{9{/q qв9{9{ж= qg8=A g 8y3{A  qq3{Atg89{A g8y3{A= qq3H{c= qв= qs8=A U׻D3@=A g89{A  qi3{A= qqs8.qqs8=A e3{/qq3{AZ8=1 g89{A  qq3{A= qqs8= qg8=Ag8y3{A  -{A  qq3趿Q qq3{= qqs8=1 g89{A g8y3{A=΃8 o"4{A|e3{A  qp3{?Zg8y3{A zֲ= qg8=A g8q3沿Y qq3{= qq= qq3{= qg8=A g 8q3{A  qq3{= qps8= qg89{A g8_f g 8y3{AZ8y3{A=q}I qq3{?Ng8y3H{1 zbSf8=A g89{A y3沿Mg8y3{A= qq3{=q=i g8y3{A q߼9{A g8y3{A= qq3H{/qq3{A= qqs8= qg89{A Ӳ9{A  qi3{A= qq3{= qg~{A|e3{A= qq3{= qg8ϱ.{= qg8c=1 g8qq3{= qqs8c=?h `#cKĎs; vA8qq bT9g; vq bĎs;vA8 b3 wA8qrĎ3g;A8q b9g; vq RÎ󅖎Hg: vE8q bYFg;"uE8q,RYHg;"uE8q,RY3g:"uA8q,BÎHg:A8qϿE8q,RĎyqW,RĎHg:"uA8q bYFg: vE8q,쏖;"uA8q bYHg:A8q,z;"uE8cq,RY3g:"uA8q,RĎHg: vErY3g:"uE8q֨,RĎHg:"uq,RĎHg:"uA8q bYHg: vE8qư,RYHg;"uE8q,RY3g:"uE8qlq,RY3Hg:"uA8Gg: vE8q=Gg:"uA8q,RĎHg: u5bY3g:"uA8.厳H wE8q bYHg;"uE8q,BY3Hg:"uE8q,RĎHg:uA8q,RĎHg: vE8q㎳g: vE8q bYHg:uEBg;"uE8q}폓;"uA8q֨,BÎHg: vE8q bYF v5mrY3g:"uA8q,RĎg:"uA8q bYHg:vE7vA8q,RĎHg: vE2E8qqYHg: vE8q,BYg ;"uE8q,RY3g:"uA8q֨,RĎHg:"uA8qaYQYs;"uE8q,RY3g:"t18qcuĎHg: vE8kq}8~$}tYHqg ƝE;w1,RYHqgΏQڳH -gE矟jA=_h=sk?h=skZjA=|skA=_ȵמ\{R{r9מ/Ԟ\{rBK9skA=_h=skZjA=|sk1= bsk ֞A=X{r3 מA=X{3gk ֞\{ b9ȵgk ֞A= bsk ֞A=T{q3 -gk )9 מA=X{r_=X{3gk ֞\{ b9ȵgj֞A= bskϠh-gkA=X{3gk ֞/ԞA=X{3gj1=X{ b9ȵgk ֞\{ bsk ֞A= oR{3gk ֞X{ư b9ȵgk ֞A=_h=X{3gk ֞\{ b9ȵgk ֞A= bsk ֞A=X{r3gkA=X{3gk ֞\{ H% BX{3gkA=Gk=X{r3gkA=X{3gmsk ֞A=ok֞\{ b9ȵge3 -gk ֞A= bsk ֞A=X{r3 ֞1=X{3gkA=X{a9ȵgk ֞A= bsk ֞A=T{R{a9ȵgk ֞A= bsk֞A. מA=X{r?NKsk ՞1=T{q3 מA=X{3Hg krsߦ b9ȵgk ֞\{ bsk ՞1=X{r3 מA=X{3hsk ֞A=X{r3 מA=X{| b3 מA=X{r3gj1=X{3gk ֞\{ b9ȵgj֞A= b3 מA=T{qa3gkA=X{ b9ȵgk ՞c\{ ?ǺԞ\{}=?eL@9 R4S1=X{ b9ȵgk ֞\{ OR{Ҕg Ɲw]>ǝoggyS}ez_sRwN; =q;?2OV?G;mC'?{Hi;#uzs'm$4m #q]$4ԝ (wD\Bc}Nk>=Bsbg:'甎Qwns2Gi;u>9ME.3#8ҼQ{}nNӶ_sFݹ q]#$kԙۯݙ_ˋtFܜw4N{Fݹͩq1ܜi(rY_1~'?#bI(s__0kn;9"4_ĝԋ:s[.⣚.NEyq٢"HEWEn;9"LcE9"Tĝs]ߛfϜJ)}IY-q<29qs{oMe{sDi;u綾7'JgIĝ&s_ߛ$NzDzoޝy<Q{}oN;9!"<~;9z䶾7'A c}oN~(sYߛs}oNz;-u羽7;ęf3?e #tBD|u>B'8ĝ:s]ֆ e~;s[S⟼!3ԝPwn#tCIa3 u=B?w~ԅo_U%-Aޒ d$%B˖d$%-Aޒ d$yK2[A7mIqKr$c%-Aޒ d$c%9[Aܒ oIqK2[Aܒ- nIqK2[%- nId$%-Z$%Y- nIiKH[Eڒ d$k%-"mIiKH[Aܒ,Җd$ d$%-"mIiKH[Aܒ,Җd$%Y-"mIaK2[Eڒ,Җ oIiKH Sړ{N֞ړ?ZjItS{[SZ{RkO^z]JC=nujOjK=y龿Yԥ֞D_o[߬S{ ?'/Yo/=7ԞD:PkO}=y鶿Yԥ֞ړSړnujO]jK=y).ԥ֞DS{<Ԟ[{}N)ړ?Pԥ֞ړnNC=iujO]jK:.ԥ֞t֞4}S_tkOiI?Nj/'/]ԞSR{;'uNK?N8SZ{}ө=Z{\ԞSZ{$oө=6SZ{RjOө=i=u'/=ԞړnS'PkO8S'8SZ{RkO^SkO:'ړ8>.:ړ貾N$zӣ'uNK=u'/Ԟ֞ړtjO]JC_CFGIN:S:ړh?s_S{>'.ړtjO:/}h4+uP}=y>Yԡ֞/~Ԟ֞ړujO]JCj)ړOE:=u'/='Ԟ֞t۟S{RjOjCQ{~|s˶g=y3۞A -۞A g=y3۞Am n{q3۞m n{g=mA g=y3۞A o{q3۞Am n{qs=te =_h,Ҷg=Ym"m{i3۞EѶg=Ym"m{q۳H۞E,Ҷg=Ym n{i۳H۞E g=жg=Ymn{i۳H۞Ym"i3۞E,ҶgX=m"m{i۳H۞A,Ҷg=Ymm{i3۞E,Ҷg=.m"m{q۳H۞E g=YmA,Ҷg=m"m{a3۞E,폖=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=m"m{i۳H۞A,Ҷg=,Ҷg=m"m{is=Ym"m{i۳F۞E ҶA_)"Myi5.۞E,Ҷg=Ym n{i۳H۞E g=mϚfq۳F۞A,Ҷg=Ym"m{is=Ym"m{q۳H۞E g=nm n{a۳F۞AѶg=m"m{i3۞E,¶g=Ym"m{i3۞E,Ҷg=Ym"l{g=km"m{i۳H۞A,Ҷg=YmϢ  g=mϢqg=Ymm{a3۞E,ҶgC۞E,Ҷg=Ymm{geYm 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,Ҷg=Ymm{a3۞E,Ҷg=Ym"m{q۳H۞E g=kYm n{i۳H۞E g=mϢ=9۞E,Ҷg=?5,g?0i۳۞1,ҶgѿVo{q۳H۞E g=kYmn{i۳H۞E g=жg=Ym m{h۳H۞/l{ k=|skA=skA=_h=skA=|!מc\{rBK9ȵ ֞c\{R{r9ȵ - מ\{rBK9ȵ מ\{R{r9ȵ - מX{qmgk ֞\{ bsk ՞1= b3 מA=X{3gkA=X{ b9ȵgk ֞\{ bsk ֞A=_h=X{A= bs=oX{3gk ֞\{ b9ȵgj֞A= bskϠh-gkA=X{3gk ֞/ԞA=X{3gj1=X{ b9ȵgk ֞\{ bsk ֞A= b3 מA=X{3gkA=X{ bBK3 מA=X{3gkA=X{ b9ȵgk ՞c\{ bsk ֞AZjA=X{3gk ֞\{ bBK3gkA=cX{3k3 ՞1 Bo-sk ֞A= b3 מA=X{bs,מ1= bsk ֞A=X{R{ bsk ֞A= b3 מA=cX{b3gkA=X{3gj֞\{ bsk ֞A= b3H,gj֞\{ bsk ֞A=a"X{r3 מA_ԞA= Rs'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?s_| \{~j4+B bsk ֞A=Ǹ b/~u= bsk ՞1=T{q3gkA=X{3gk ֞X{ư bmgԞds=X{r3gkZj ֞A=X{r3 מA=X{3gkA=X{a9ȵgk ֞\{ bsk ֞A=X{r3 מA=T{ư|,RY3gj"՞E=X{QڳHgj"՞A=T{,RڳHgj ֞E=T{ bYڳHgk"՞E=P{ư,RYsk"՞Eqj ֞E=T{ڳ fHgj ֞E=n@E=X{,Rڳgj"՞A=T{ bYt-מE=X{,RڳHgj"՞\{,RY3gj"Ԟ1=T{,RڳHgj ֞E=T{ bYڳHgk"՞E=T{,RYڳHgj՞E=X{,RYsk"՞E=X{,RY3gj"՞A=T{,RڳHgj֞E=T{ bYڳ趿Q=X{,RڳHgj"՞A=T{ڳHgj"՞A=kT{ bYQ=T{,RY)"ŝA;?R{ bYڳHgj ֞E=T{ok՞A=T{ z,RYڳH מE=T{ bYڳHgk"՞E=T{,BY3Hgj"՞E=X{,RڳHgj՞A=T{,RڳHgj ֞E=T{ڳgj ֞E=T{ bYڳHgj՞EڮBgk"՞E=X{}폓k"՞A=P{֨,BڳHgj ֞E=T{ bYڳF ֞5mrY3gj"՞A=T{,Rڳgj"՞A=T{ bYڳHgj֞E7֞A=T{,RڳHgjϠj"՞E=P{qYڳHgj ֞E=T{,BYڳg k"՞E=X{,RY3gj"՞A=P{֨,RڳHgj"՞A=T{aYQYhίtZ"՞A=T{,RڳHgj֞E= bYڳHgk"Ԟ5=P{ư,RYڳHgk"՞E=X{,RY3Hgj"՞/ԞET{v~֞Bߧ x=.SZ{Rkϗ~ԞB=?܏SZ{ҩ=qԞB=N)SPkO| Z{Щ=u'.S'>ġS{ҩ=u'.NK=Z{NKԥ֞NKj tjO֞B=eZ{~=?_Q{O֞ړR{RjO]jK=y(ԥ֞D=q=u.ԞS'QLS'QjO} Z{RjO֞DQ{ oK=y)'/MC=u'/ĥS{ǝړR{RkO]jISwg~!֏Sߓ֞ړR{sNkK:.hSZ{RkOhSZ{mN)ړ{N)joAkO^zz\:'.ړ?Zԥ֞ړujOjK:.ԥ֞D:.$֩=Z{}oԩ=-hK=y麿Qԥ֞DujO^zoTkOjC:.=S{RjO^zoԩ=qԞSZ{7ԞB=7Ԟԥ֞tFߨS{Z{}}NC=y麿Qԥ֞ړ趿Qԥ֞ړujOFړ蹿QԷ'/7ԞtjO^oԩ=q=u'7ԞړujO֞DujO}=u'uN}N$֩=u.GݥԞ:ړ趾Yԡ֞ړujO]z^7ԞD:'S{כsNIt߬S{ ړnujO]jK=y?Y=a=y?Yԥ֞ړR{RkO]jI4'cN'/?US'uNK=uyS{s}NC=iujO]jK:.ԥ֞t֞4}S_tkOiI?Nj/'/]ԞSR{;'uNK=u'/Ԟړ{}N ړ沿M7Ԟړ('}N/'/]ԞSR{mNOkK=y?Nԥ֞t֞2=o=Z{'/ԞB=ԞS=y麿N=qԞ8tjO^rԞ֞ړtjO:ړ蹾N֞Du:.ԥ֞t_S{Z{RkO^ө=u)']No=':ړtjO]zYַtjO)̯|O֩=5ړujOdړujO]jK:íǵԥ֞tߟS{RjOOVkO֞D-O֩= hK=y?YǵdSR{PkOO֏KoOӲm{ mAm?hmAmZ=ys=_hmAmo{ -۞9۞cB˶ o{ -۞9۞B˶ o{ o{в9۞B˶ o{o{A۶g=9۞AMq3۞mn{g=mA g=9۞A o{q3۞Am n{qs=m m{g=B˶g=_mA g=mm n{g=mA g=y3H۞1 o{q3۞te3۞m n{jIm n{qm n{q3۞m m{g=mA g=y3۞A o{q3۞m n{qs=m n{g =9۞A g=_h g=y3貿Q˶g=y3۞Am n{q3۞m m{g=mA g=9۞A o{q3۞Am n{qm n{q3۞m n{gF-۞Am n{7jmσ8)A ”秿ݶ=9۞A n{\7۞1m n{qsГ۞A g=_h g=9۞A o{q3۞Am m{ps=cm n{g=9۞A Ҷg =y3۞A o{q3۞m n{iem m{ps=m n{g=9۞1 mA g=y3km n{g=cm1 g=y3۞A o{i3۞/mϘ6-۞Am n{qs=m n{g=cnl{g=9۞A g=x3hmA g=9۞A o{q3۞A|e3۞A o{q3۞mn{is=mA ӲmA g=y3H۞1 o{q3۞Am n{is =?em~},Z=mA g=9۞A Ҷo{q3_p9۞A o{i3۞Am n{'km n{qs=m n{g =m۞AߢogZ1L=cTz(Q2Yzd5('kNƨA6Yjr?kL A1`d rՒ5_VdJ5a&Jd %5($kC #kPG AYrY_!%#cE A(Md cD֠AY2F1d Z1*!kB֠A sY2 d 5c?֠~Accd5k=ƨyAX1Fc z5k!k>%HcT: tAX1Fc "41HKP8|1kP7 nQX>7,k6ƨk5j5iAX1FAc z5c3|nK2QXrY_v5cT1 bAc 1k>׋%k.(]AXp1Fb T555o/1 k+ WAXb R5k)|RAXFb 5c'|K'|nC&֠LA.Yb D1jk$֠HQXG,AX1F1b Z5(c"|ǬG Ab 5k֠=QzXsxaCc 9AqsoXܰsmذa R1 k 3QeXȰa % kš Tyᛙʢof*N`K0ԥ&P+#3ԥvtBC\:PSC 56jm(߂8tCjqK'9jsktCqdtC]jxK<ĥRCƇSu.5@ĥS I QP;߁!K?JD_ǵEԥƈtk#Gԥ R$PD]jH(*Q%RD^JK)&ϽDE'[>( P$oԏFQ_x#E]jKyT䥤tZEĊS+RrE]jK R, 5Y_.Y̯Q-{lQ-RE^zIqmy?Z^ԥIt߬P ބnu"J]jEK(y?Y )a-)y?YԥƔԚSR{J]jPI4E%cNSQ%/dB*uJ]jZKm+y?P+q8Ծ?Pԥ&tYR+K]jfKjhIsߧI-EԙƖDtrK\uNrKm.u)%~=No=]]锗R^mN}K/@-0i.tL|NK0a鄘[buNK1u)5&"tL]jKqj).h2SifmN)<{NK-4u&/]ש&JNK_PSRSjcNItY_k=`躿N'ԥ6hntM}\M]jKu:._[##$_psN>dh?s۟r>%'.ubNduN]jK:M5í'ǵԥtߟvRNOVND-O)< hKmԞtjO]jK=qԞtjO֞@j)S'Z{RkO^JK=u.Ԟ:SZ{ǥԥ֞ړx)PkOa(PkOԞԞB=SZ{RjO^SZ{PkO^JK$J퉏;'/ԥ֞ړ(7g~UkOnIt]'=u'/hSړujO]JC:.ԥ֞D:.hS'hS'hړ7NK$֩=u.hSZ{mNK=u'}NK=n蹿Q$ߨS{[SZ{uNK=7Ԟߨ֞:ړujO]jK=y鹿QǝړR{?ujOFS'FS߂֞ړnިujO}\kO^oԩ=u'/]7ԞSZ{7ԞSZ{cNItߨS{=7ԞFNK:>.FSZ{uN)ړ{N/.$oԩ=Z{]7Ԟԥ֞ړިwR{PN'\=u9Z{}NK=ެ豿Y~jO^z^zo֩=ujO֞[{mNK=u)''>''ԞSZ{RjO]jK=y/֩=ubS'uNK=u'/'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{Щ=yˁS{Z{RkO^zө=.tjO:=Z{]ԞSZ{mNkK=y龿NԥԞ4uP~ :.=~K:'~?Y}jO\:'/='ԞD:'/='ԞړujOjK[OkK=y?YԥԞSjfCZ{6@:ԞtjO]jK=_V{ |qjO]jKĥS{ :PkO֞B=#hCԡ֞tjO֞֞:NKԥ֞tjO\:.j퉏;'.SZ{RkO\:'.S'Щ=nV7So'q=u?=y)'/ԥ֞ړR{PkO]jIړSZ{RkO^JK=Z{/D=Z{ԏ'/jIt_ߨo֞ړR{Ԟ:SZ{RjO\:'QjO|ܩ=y).ԥ֞D=V{W֞DV{gSZ{RjO^S{Z{kNK=y?Zԥ֞ړ?Zԥ֞S{ $S{ $S{ǣ˥S{ҩ=ujO]jK=y>Zԡ֞S{RkO]jIS{RkOGߨS{}oԩ=#hK=y龿Qԥ֞DujO^ߨ֞:ړ^ujO]jK=ykN퉏;'/ԥ֞FړkNIQԏ.Ǐ7K:>'/=7Ԟ:ړujO]jK=ujO]jK=y鵿Q$oԩ=7ԞFNK:>.FSZ{}N)ړsNo.$oԩ=Z{7Ԟԥ֞ړ?ި.ԡ֞D:ԥƝ\z/ʿ՞:SdkO7W߬S{?'/=Y^߬S{7ԞB=fSZ{RjOzOVkO}XkOzO֩=u.ԞSZ{MI_S{nK:PkObSZ{RkO^z/VkO:'y/֩=u?/UԞSZ{sZ{ijO}ӭ=u'8S֞tS{RkO]JCӯlة=tjO]jK=y?Nԥ֞DtjO֞4m:'~ԥ֞D=tjO}=y龿Mԥ֞ړtjO}ZkO]jK=u.8iIyk)S[{cN)ړsNK=u'/ש'NKSSZ{kNIt[_S{}ӫ'}NK=u'/=Ԟ֞ړtjO]J5'?[8$ܟS{dS^?K:'~?Y7}jO\:'/'ԞD:'/}O֩=u'/='Ԟ:ړ/SSZ{sNK=y?Y=eZ{M_cN@kO]jK:>'/='ԞSZ{s}՞/}= ܶԶ o{q3۞Aвm n{qs=mA g=9۞1 o{q3H۞1m n{qs=m n{g=mA g=y3=cye۳H۞E g=Ym n{a۳F۞A,Ҷg=m"m{i۳H۞A,Ҷg=Ym"m{i3۞E,Ҷg=Ym"l{p۳H۞Em"m{?Tm n{i۳o=U,?Um"m{q۳H۞E,Ҷg=Ym n{a۳F۞E g=mϢhy۳H۞A,Ҷg=Ym"m{is=Ym"m{q۳H۞Eg=Ym n{i۳H۞A,Ҷg=m"m{i3۞E,Ҷg=Ym"m{i3H۞5,Ҷg=nRi۳H۞Ym"m{q۳H۞E,Ҷg=Ym n{i۳H۞E g=m"m{i۳H۞A,Ҷg=m"m{i3۞E,Ҷg=Ym"m{g=Ym m{h۳蹿Q7۞E,Ҷg=Ym"m{q۳H۞E g=Ym n{i۳H۞AO=kmσ4Y) MyW˶g=9۞E,Ҷg=Ym"m{q۳趿Y,Ҷg=Ym m{h۳H۞E g=m"m{a۳F۞A,Ҷg=m"m{i3۞E,Ҷg=x۳۞5 g=Ym n{i۳H۞AѶgm m{q۳H۞Eqg8y۳H۞A,¶g=m"m{i3۞E,Ҷg=Ymm{gmYm 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,Ҷg=Ymm{a3۞E,Ҷg=Ym"m{q۳H۞E ¶盒_ ~<۞E,zO=Ym"l{p۳h?m"m{g=m"m{i۳H۞A,Ҷg=cYmϢ˭ g=m"l{h۳۞1,Ҷg=m"m{i3۞E,Ҷg=Ym"m{^h,m]BK9ȵ מ\{E[9ȵ מ\{^h=B=sk sk - מX{qysk - מ\{ryskA=/Ԟ\{rysk1= bsk ֞A=X{r3 מA=X{3gk ֞\{ b9ȵgk ֞A= bsk ֞A=T{q3煖3gBsk ֞A`3 מA=X{3gkA=T{ư b9ȵgk ֞\{Gk=X{r3 מA=X{R{ bsk ֞A=Ǹ b3 מA=X{r3gkA=X{3gk ֞\{ bsk֞A= b3煖3gkA=X{ b9ȵgk ֞\{ bsk ֞A=Ǹ b3 מA=X{3gkA=X{ b9ȵgk ֞Zj ֞A=X{b3֞AԞA= b3 מA=X{r3gkA=X{3?Q=cX{r3 ՞1 B_o煖3gk ֞\{ b9ȵgk ֞A= Rsk֞A=X{r3 מA=T{ư3gk ֞\{ b9ȵgm3He3Hg kA=X{ b9ȵgk ֞X{ư zv= bskϠqZj ֞\{ask ֞A= b3 מA=cX{^ȵgm3 מA=X{r3gkA=T{ư b9ȵgk ֞\{ bskϠϛkA=X{ b9ȵgk ֞\{ b2K3gkA=X{3趾NKsk ֞A= b3 מA=מBJ$ߐj֞A= b3 מA=T{qaBK3 מA=X{3gj1=X{_n]jA=X{3Hg k ՞c\{ bsk ֞A= b3 ֞1=X{E[tW՞\{^h=skϿh=sk - מ\{^h=sk sk - מX{qysk - מ\{ryskA=/Ԟ\{rysk1= bsk ֞A=X{r3 מA=X{3gk ֞\{ b9ȵgMLk ֞\{ b9ȵgk ֞A=Ǹ bBK3!b9ȵgkϠW{W ? bsk ֞A=X{r3 מA=cX{3gkA=nԞA= bsk ֞A=X{^h=X{ b9ȵgk ՞c\{ bsk ֞A= b3 מA=X{r3gkA=X{ b9g k ֞\{ bBK3 מA=X{3gkA=X{ b9ȵgk ՞c\{ bsk ֞A=X{r3 מA=X{3gk -gk ֞A=askϠZj ֞\{ bsk ֞A= b3 מA=X{bs۟(מ1= bܟ b) Ɲb3gkA=X{3gk ֞\{a9g k ֞A= bsk ֞A=cX{r3gkA=X{3趿XK2K3 מA=X{3gkA=cX{m֞\{ b9ȵg8-gkA=T{ư R9Ƶgk ֞\{ bsk ՞1=/3涿MKsk ֞AmZj ֞A=X{r3gkA=X{3gk ՞c\{\{r3gkA=X{3gk ՞Yj ֞A=X{r3 מA=cX{3gkA=X{ b9F3_4\{ask ֞A=X{r3HמA֞A=/ԞA=X{r3gkA=X{3g?֥3gs3Hg k ՞c\{ bsk ֞A= b3 ֞1=X{E[t7c=X{r3gk -gk ֞A= bsk ֞A=X{b3 מA=T{ư3gkA=X{ b9ȵgk ֞A= bsk ֞A=cX{^h=T{ bYڳHgj ֞E=kT{,RYڳHgk"՞E=T{,RY3gj"՞E=X{,RڳHgj"Ԟ1=T{ڳHgB\3gjϢU{X{},RڳHgj"՞A=T{ bYڳFgj ֞E=T{,폖k"՞A=T{=G˵gj"՞E=,RYڳHgk"՞E=cX{,RY3gj"՞A=T{,RڳHgj ֞E=T{ bYڳHgj ՞5=T{,RYڳH מE=T{,RYڳHgk"՞E=n=T{,RڳHgj֞E=T{ bYڳHgj ֞E=T{,RYڳHgk"՞E=,RYڳHgj՞E=X{}ok"՞A=T{,RڳHgj ֞E=T{ bYڳHgjϚDQڳHgs\{,RYs<w!| KڳHgj ֞E=T{ bYڳFgj՞E=T{,RY3gj"Ԟ5=X{,RY3gj"՞A=T{,B9Ƶgj՞A=T{,RڳHgjϠj՞EoۮBgk"՞E=X{}쏓k"՞A=P{֨,BڳHgj ֞E=T{ bYڳF ֞5mrY3gj"՞A=T{,Rڳgj"՞A=T{ bYڳHgj֞E7֞A=T{,RڳHgj ֞E=T{ڳHgj"՞A=T{ bYڳFgj֞E=T{,RYڳ}&WrHgj ֞E=kT{ bYڳHgj ֞E=P{ư,Ϩ,R9ȵgj"՞A=T{,RڳHgjϘj"՞E[]{,RY3gj՞E=cX{,RY3gj"՞A=T{,RڳFgj -g_՞ H՞?Oj|:'.SZ{Rk՞B=ܷSZ{ҩ=qԞB=N)SPkOZ{Щ=u'.S'>ġS{ҩ=u'.NK=Z{NKԥ֞NKj tjO֞B=eZ{ |=_V{o֞ړR{RjO]jK=y(R{RkOԞԞSZ{RjO^J)ړ(&J)ړ(~=y)PkOF}=ԥ֞ړԡ֞:ړR{ҩ=R{NK=u.$JsN$ַS?֞ړR{hSړ^ujO]JC:.ԥ֞D:.hS'hS'hړ^?_.NIS{RkO]jK:hSZ{RkOhSZ{=>ZFړsNAkO]jK:.$ߨS{Fԡ֞<ߨS{RkO^JK_ujO|ܩ=y).ԥ֞D:PkO:~oNKoԯ^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ԥ֞DOԯ?Q7~jO^zx~?Q'Մo'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)'=~ԞSZ{}Z{Щ=qԞi=q=u'/ԞDu:':Z{ԞSZ{wf?Y'SZ{sNK=yN|=>'Ԟ?Yԥ_pk}NIyO֩=MNK:'mNK_ujO]jK:˭ǵԥ֞ܟS{RjOOVkO֞D?W؟S{SZ{kNkKu:.ԡ֞<\_oKj_.T^=/eϿfw=/Yxf'7=/IxY=/=xYe89c8yocX_es 1/]1뫳b(e9cybae<9[c8y.aw0p2^1'0ps 0pY/pr /k8uy/] _^ƻc8{9c8zyo^.^^Cw9scvy]N]^Kc8t9F;C8sy\n\ep9coy[[Ѷ_L[Ѳ[^ƻc8k9c8jyoZ.Z^A!ܳ~N`,/11ܲ)xr,;c8cyXܞer&,/1xr +pr +/1ZʿƻCnkVheY9cXyV^UZe9c=yOOOe<;9c4:yoNYpqr 'eor &pm2í1åxhr w&hf"^Ñ1/m.Le[{ ǵԡ֞8tjO\:.ĥS{ҩ=uPkO|ܩ=qԞSZ{ҩ=qԞB=N)Sg?O[ҷړg֞ړ?jO]jK=y(ԥ֞D=q=u.ԞS'Q2L:{PkOԞԞB=7SZ{RjO^lC=y)'.ړ('>ԞSZ{RkOԞ~=Z{tkOh}=3iK=y)'/}֩=q=y?ZԥԞ<S{RkO]jIS{RkO^z֩=Z{}֩=Z{}֩=yҩ=qԞD:.ԥ֞ZS{PkO^z֩=u.$z֩=u' }oԩ=>7Ԟԥ֞tߨS{RkO:'/}oTkOjC:.ԞQǝړR{RkO]jIߨS{ $ߨS{GSZ{FSQ=uFSZ{RkOFSZ{RkO^zoԩ=nujO:~=y鹿QĥS{cNKC=y蹿Qԥ֞tߨS{ $ߨS{oK=ujO֞D:~=u.7K=u'c}NC=u'/='Ԟړ'ԞOKOԯ'ԞD:PkO};yz;jOno2'='>'='ԞSZ{RjO]jK=y/֩=}bS'}NK=u'/='Z{<ԞړujO]jK=y鹿X=in5֞:ړsN)SxkO^:.ԥԞ<8zړ?Nԥ֞ړtjO]jI>NjIsߦS{pjO]jIړ蹿M7ړtjO]jK=y?Nԧԥ֞S{RkO^zSkO֞D럷֞B=?'/=ԞB=>ԞSZ{}Z{Щ=qԞi=q=u'/ԞDu:':Z{/zh+uP}=u'/='Ԟ֞ړujO]JCO֯^p[I?Y䥯:.~믗^ujOcNoԞtjO^zO֩=nujO^ڟS{RkO^zO֩=u'/_n=>.}~O֩=uwYړS'd=Ԟԥ֞_S{Z{cNK=u'=[ҷK}=R{r9ȵ מV{r9ȵ מZjA=R{r9ȵ מr9Ƶ מZjA=BK9ȵ מZjA=BK9蓵 מ\{^h=BK9ȵ ֞c\{E[3 מA=X{3Hg kA=X{ b9ȵgk ֞A= bsk ֞A=X{r3 מA=X{3gk -gk 8 מA=]9_3C(gkA=X{ b9ȵgk ֞\{ask ֞A= R{3gkA=X{ by b3 מA=T{q3gkA=X{3gk ֞\{ b9ȵgk ֞A= ߨ b9g k ֞\{ bBK3 מA=X{3gkA=X{ b9ȵgk ՞c\{ bsk ֞A=X{r3 מA=X{3gs3gk ֞X{ư b9ȵgF-gkA=X{ b9ȵgk ֞\{ bsk ֞A=Ok֞\{ b9ȵgk ֞A=/ԞAԞA= bsk ֞A=b9HqXj֞X{ư bsk ֞A= b3 מA=X{3gkA=X{ Ry Rsk ֞A=X{r3蹿X=cX{m֞\{ b9ȵgZ-gkA=T{ư R9Ƶgk ֞\{ bsk ՞1=/3涿MKsk ֞A= b3 מA=cX{3gkA=X{ R9Ƶg͵ מA=X{3gkA=X{ Ry b3 מA=X{r3g]9_bsk ֞A=X{r3 מA=cX{3gk ֞\{ R9Ƶg~gk -gk ֞\{ bsk ֞A=Ǹ b~u= bsk ՞1=T{q3gkA=X{3gk ֞X{ư bmgԞV{6AĥS{RkO]jҷSV{RkO\:'.S'Щ=Z{ jAkO:ĥS{ ǵԡ֞8tjO\:.ĥS{ҩ=uPkO|ܩ=qԞSZ{ҩ=qԞB=N)S(Lk?oKjOZ{RkO^JK=u.Ԟ:SZ{ǥԥ֞ړR{RjO֞D0QjO֞D=#hK=Z{7[o.Ԟ4ԡ֞EK$J퉏;'/ԥ֞ړ(_j|UkOnIt_o~&=u'/䥯:>'/GԞړujO]jK=ujO]jK:PkO:PkO:'/~7Ԟ[{RkOFS'mNAkO]jK=yRjOjIXS{PkO]jK:.$x~E:'S{륯:'}N)SxkO^zOԩ=u.%ݯySSړ'ԞړR{RkO]jI4'kNﻵ'/=ԞB=ujO]jK=y鱿X=qԞ8ړ湿Xԥ֞_S{RkO]jKjIs=Mԙ֞DkujO֞[{}NK=u)'=~V$ө=u.8SZ{}ө=Z{ԞSZ{$zoө=6SZ{RjOzө=i=u'/ԞړS'筵PkOoKq:PkOq:.ԥ֞t_֞8tjO:'/$_S{RkO^zө=ntjEoJ~dZ{'ԞSZ{cNgNK:.'C?[8$ܟS{dS^?K:'~?Y7}jO\:'/'ԞD:'/}O֩=u'/='Ԟ:ړ/SSZ{sNK=yLkO+zө=hK=y鵿Nǵ:SR{PkOzӷo/~iV{ryskA=skA=/Ԟ\{ryskA=/skA=/Ԟ\{b9Ƶ=BK9ȵ מ\{^h=sk - מ\{^h=skϿh=X{3gk ֞\{a9ȵgk ֞A= b3 מA=X{r3gkA=X{3gk ՞c\{ by bĿ3gп=\{} b9ȵgk ֞A= bsk ՞1=X{r3 מAZj ֞\{ b9ȵgk ֞A=/ԞA=X{3gj1=X{ b9ȵgk ֞\{ bsНgk ֞\{ bsk ֞A=X{b3 מA=X{R{ b9ȵgk ֞A= bsk ֞A=X{r3HמA=X{3gk ֞\{ b9ȵgk ֞A= bBK3gkA=cX{3c3 מA=X{3gkA=X{ b9ȵgk ֞X{'ʵg kA=X{3gk ֞Zj ֞A=X{r3 מA=X{3Hg j"ĝ~d=X{tg3 מA=T{ư3gk ֞\{ b9ȵgk ֞A=/ԞA=cX{r3gkA=X{3g߶`9ȵgZ- מAkԞA= R3HמA=X{r3gkA=T{ưkϘ6-gkA=X{3gk ֞\{ask ֞A= b3HמA7מ\{ bsk ֞A= b3He3gk ֞\{ b9H3_4} 3gkA=X{ b9ȵgk ֞\{ask ֞A=X{r3HמA֞A=/ԞA=X{r3gkA=X{3g?֥3ssk ՞1=T{q3gkA=X{3gk ֞X{ư bmg_՞?[lhPkHNK=uKjO֞?[K=qԞtjO֞@j)S'~=qԞ:N)SZ{Щ=qSZ{ҩ=qԞS'>ԞtjO]jK=qԞtjO֞@j)So'q=u'/ԞSR{PjOjK=R{R{RkO]jK=y)PkOe(PkOԞԞB=7SZ{RjO^SZ{PkO^JK$J퉏;'/ԥ֞ړ(PE%@<}_o~&=u'/䥯:>'/GԞړujO]jK=ujO]jK:PkO:PkO:'/~'/=7Ԟ:ړujO]jK=ujO]jK=y鵿Q$oԩ=7ԞFNK:>.FSZ{}N)ړsNo.$oԩ=Z{7Ԟԥ֞ړ?ި.ԡ֞D:ԥ֞ܟS{RkO'WڟS{?'/=X{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Ԟ\{}oR{3gk ֞\{ b9ȵgk ֞A= bskϘDa9ȵgk ֞\{ bBK3gkA=X{3gk ֞\{a9g k ֞A=Zԡ֞S{RkO]jIS{RkOhS'FS?֞ړujO]zgNkK_SZ{kNK=y)'/}oԩ=q4SZ{=7ԞB=>7Ԟԥ֞Fz鵿QǵFSZ{}NK=u'cNK=u'/7ԞD:'FS?֞ߨS{ҩ=y鱿Qǥԡ֞<ߨS{RkO^oԩ=Z{}oԩ=ԥ֞D:PkOFS?֞SZ{ۥԞ:ړ>Qԡ֞ړujO]jItD^ujO|'K_ujODS֞؟S{RkO]JCjkC:.ԥ֞SZ{RN;1~[x~ړujO֞D:.ԥ֞_֞8tjOjI_S{RkO^z/֩=u.bԞ[{LkO:PkO}=y龿Vԥ֞ړ?^_}^S{ԞSZ{cNK=>߾V<ǩ'mN=u'QjO6SxkO^oө=u.8SSZ{kNK=y?N=eZ{Z{ ֞S{ $S{RkO]jKujCġS{7!g#S{{hK=y?Y$O֩='ړ?Yԥ֞ړujO}\kO]jK:.'C?[8$ܟS{dS^?K:'~?Y7}jO\:'/'ԞD:'/}O֩=u'/='Ԟ:ړ/SSZ{sNK=y辿N=eZ{M_cN@kO]jKu:>'/=ԞSZ{s}՞/}=?oL{e<9c8929c89ye9cc9Sye<9+c49.xe9c9㝗yrs ;ps ;/1xs 7;hs;e3F{1?kF|:c4MuRg :C931ZHg6:p3F 1>sh3Fci-shs w9c4U1&g&9c91e1b49K17Ù/?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 :f1p3c}ua1Ō,fV1c491Č"bh3Fs1Z1mah s0Cn` fF0c91Zf//_h2Fۗc8} _ef/cz1ܼe/h2D{1]|o.hF1 Ѫ'F-2rM\e.co91ZѸe -/i,[<7Ȼ1ѪeF-p2F1ZAYƼКYh2FScd?ޱьX`2D1 Xhr +c^mWte +C4\yVƫ1MVhr +cWUXe *C4U1Nef*p2F#1ڨD.TlO91Z8e)p2F˔1]Rh2&qP;1g* Qh2Fkc8F-MQ`r(cC1\e6(c4A9 1#1d'c=9⦗'c4<1d F'ps2f= N^{1Mhk2FS1ZáL`frW&c42Ҧ'&pa2F1ڗyKh\2ےC8-e KhWr g%c*Q1ܔѤd%c4(9F{!њ_IՖ元^h 0pÿh 2p; - ^hi 96ps 7p - 7qux%;p - r|x>pA/ rx%B q31-D bq[ ƈA#ry"q 6AX%r.1abAN&1N:1yb \(1Q b8ȑb+ fA8T ԿDbxU bĿ1W^1bA2YW}1Z b8b A,9] bxq 10rĄ1 GAZ2 v2d b8-cc ֌A/A X41i1Qc151l b8ic ƍ\71o bq &Al9r b1 A,:u1csA<x bxy bq vA X>rQK8c A  br# VA Ar2)d[A!XC7j!D b9Md VZ vA #XFb62q בAA $ b"F2 WA$Ir(R2d[A%XK1^2?Q.&cLr3h2 gA&NВN b<zr A ( bBĆ2 WA(cQbHÒ2)e[A)>j) bP2I 5 BDW}r A,+9 b[ĸ2Hue2H}e A.,X bd9ȕe3 vZư zvl-9 bmr{ˠZ &\)aur A,/9 b{2 A/c`^fm3 WA0ar3)f[A1Tc0 b9Af &d1 b,s̠ϛAN3f1 b9yf \h1 b6|`^_tbN3 AL5jrZ3fz16Xl1f3f fm1 b9fƛA79 bĀ3 'Al8qqaĐBKĔ3?YKĚ39g{A:Xt)3Qg?%3agAN;v0 R9yg A,<9 bs+ fA<zb3_ŞAS{[[}= jS{ҩ=u.|[)}=u'.N)ԞB=Z{ ď'SZ{ҩ=Z{Z{PkO:'.SZ{ҩ=qԞS'>ԞtjO]jK=qԞtjO֞@j)j'|[I\kO]jK?۟o.ԥԞZjOLZ{RkO^JK_ujO}\kO^z֩=u)'=GԞSZ{=GԞړujO֞DujO֞DujO^zx~tjO\:'sNK=u'/GԞ:ړujO]jK=ujO]jIS{ $ߨS{GSZ{}NK=>7ԞQ=u'7ԞړR{FwjO^JK=u'cN)ړsNAkO]jKoԯ^ujO}\kO^zoԩ=u'/7ԞSZ{=7ԞSZ{kNItߨS{}oԩ=#hK:'.ړujO}\jOjC:.FS'FSxkO]jItߨS{ $oԩ=#hK=u'/=Q]JC=~?ujO^zOԩ=u'+zOԩ=ړ?_/}Oԩ=ujO֞[{cNK=u)'=>'=ԞSZ{RjO]jK=yԩ=}@Sq// }=>.bġS{PkObSZ{cNK=u'/='m7SgZ{}թ=Z{oK:.ԥԞ.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=jm՞\{^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Ŀ3gkAY{@A=X{r3gkA=X{3Hg k ֞\{ b9ȵgh-gkA=X{3gk ֞Zj ֞A=X{r3HמA=X{3gkA=X{ b9ȵgk ֞\{ bsk ֞A=X{b3蹿QK3gk -gk ֞\{ bsk ֞A= b3 מA=T{q3gkA=X{ b9ȵgk ֞\{ bskϠZj -gk ֞A=askϠZj ֞\{ bsk ֞A= b3 מA=X{b?Q=cX{r3 מA=X{R{ bsk ֞AZj ֞A=X{r3 ֞1=X{3gkA=X{a9ȵgk ֞A= ByA;_V{ Ry Rsk ֞A=X{rXK9g kϠ׿msk ֞A= z_ b9ȵgj֞A=Ǹ bsk ֞A=X{r3\{ƼR{3gkA=X{ b9ȵgj֞A= b b3HמA7מ\{ bsk ֞AkW!|%ogk ՞Yj ֞A=X{r3 מA=cX{3gkA=X{ b9ȵgk ֞\{ask ֞A=X{r3HמA֞A=/ԞA=X{r3gkA=X{3gп֥3gkA=T{ư R9Ƶgk ֞A= bsk ֞A=X{b3jϠ=hKsk ֞A=X{^h=X{ b9ȵgk ֞\{ bsk֞A= b3 מA=X{r3gkA=X{ b9ȵgkϠjA=X{ay,RY3gj"՞E=X{QڳHgj"՞A=T{,RڳHgj ֞E=T{ bYڳHgk"՞E=P{ư,RYsk"՞E qj ֞E=T{]ٯz?,RڳHgj"՞A=T{ bYڳFgj ֞E=T{,z-מE=X{,RڳHgj"՞\{,RY3gjϢh,RYڳHgk"՞E=X{,RY3gj"՞A=T{,RڳHgj"՞A=kT{=7ʵgj"՞E=,RY3gj"՞E=X{,RڳHgj"՞A=T{aYڳHgj ֞E=T{ bYڳHgk"՞E=T{,RYsk"՞E=T{QY3gF,RڳHgj"՞A=T{ bYڳHgj ֞E=T{yߟ(֞5=X{,RڳHgj"՞\{,RY3gjϢD,RYڳHgk"Ԟ5=T{֨,RY3gj"՞A=T{QڳHgj"՞A=T{ Ԕg"ĝ~ɵמE=kT{,RYڳHgk"՞E=T{֨,zv=X{,Rڳm\{ bYڳFgj֞E=T{,RYڳHgk"Ԟ5=y+מE=X{,RڳHgj"՞A=P{֨,RڳHgj ֞E=T{aYycڳHgj"՞A=^מ/B~?X{,RYsk"՞E=T{,RY3gj՞E=cX{,RڳHgj"՞A=T{ bYڳFgj ֞E=T{ bYڳģjϢj"՞\{,RڳHgj"՞A=T{aYڳ_rk ֞E=T{,BYڳg k"՞E=T{,RY3gj"՞E=T{֨,Ry,zOM 3}:'.SZ{Rkח՞B=_ܷSZ{ҩ=qԞB=N)SPkOZ{Щ=u'.S'>ġS{ҩ=u'.NK=Z{NKԥ֞NKj SPjO֞jח՞D˰>.ԞSZ{RjOJC=u'QjO~\jO]jK=y)'/jI jIS?֞S'm}՞[{RkO^JKS{PkOjK=qԞD=qԞSZ{j3_6ӷV{gSZ{RjO^S{Z{sNK=y?Zԥ֞ړ?Zԥ֞tS{ $S{ $JAkO^zx~tjO\:'cNK=u'/=GԞ:ړujO]jK=ujO]jItS{ $ߨS{GSZ{mNK=>7ԞQ=u'=7ԞړR{FwjO^JK=u'}N)ړcNAkO]jKoԯujO}\kO^zoԩ=u'/7ԞSZ{7ԞSZ{sNIQ$ߨS{GQĥS{ҩ=y龿Qǥԡ֞<ߨS{RkO^oԩ=Z{}oԩ=ԥ֞D:PkO:~=u.Ǐ7K=u'}}NC=u'/='Ԟړ='ԞOKOԯ>'ԞD:PkO}=y?Qԥ֞ړ Sړ ujO]jK=y).ԥ֞DS{<Ԟ[{cN)ړ?Pԥԩ=y?P;97՞ړ汿Xԥ֞t_S{RkO]jKjI?XS{n3=>ԞB=ZSZ{RjOx~=ړ趿Vԥ֞ړkujO]jIVjI?VԞړ('cNo'/ԞSR{}NOkK=y?Nԥ֞t֞2=?o=Z{?~kO^ө=j4+|PiK=u'/''NKNkK=y?Y$z_S{}Oֳ'mNK=u'/'Ԟ֞ړujO]JCO֯lķړcNKujO]z_/='ԞDd=qԞ|dړ}NKtjO]jKu:˭ǵԥ֞_S{RjOSkO֞D?Wt_S{SZ{sNkKu:.ԡ?sO=__V{/}m -۞9۞mAmAв9۞yes=ys=/m1T/0m -۞9۞cyes=yB˶ o{ o{^hmAm -۞9۞ o{o{~m3۞Am n{q3۞mn{g=mA g=9۞A o{q3۞Am n{qs=m m{g=ye3۞A? o{q3۞r3_+mA g=9۞A o{i3۞AmϠZ=y3}m n{g=9۞A g=/l{q3۞Am n{is=m n{g=9۞A g=y3۞Am n{q3۞m n{qs=cmA g=ye3۞Am n{q3۞m n{g=mA g=x3۞A zoԲm n{qs=mA g=9۞A 煖m n{q3۞m n{gF-۞Am n{q3۞m n{g=mA yr=q3}mA g=y3۞A 煖m n{q3۞m n{g=mA Ҷg =q3۞A o{q3۞m m{ps=m n{g=l{q3۞i2˔g)WZm{g=mA g=q3۞A"9۞A o{ղmA Ҷg =9۞A o{q3۞AmϠZ=/mϘZ=9۞A o{q3۞Am m{p3۞m n{g=m1 Zys=zUș ~9۞A g=/l{q3۞Am n{='k Ҷg =9۞A o{q3۞Am n{qs=m n{g=mA g=x3h?m n{^h g=y3۞A o{q3H۞cmϠ˭˶ o{q3۞mn{is=m n{g=9۞A g=q3cm/m{Ŷ,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"՞2#ǰ82l#! #/.r 1"/(r 1L"ǰ27ۣcCa yǐcBa ycBa9e\A?3l /r 1 ǰ10~1LǨ|20{q ˸yq 8xq s1;Q8eT:ְk/:me\9a8e8a8/ `xcX7axcg)0l1j"n0iâ2ǰgÜq k8fqS/q,fq86q8c/^ՋC/axcX.axwc-a8FE,xX W-|!&+k+axNJc*axc*a8FY*1ǰQD2.0P>2ǨN8qċ8Ms[%L1ǰJ(2n0I"2ǨGq k8Fq S1,/q ;1/ qz &_f)0@2ǰ>p 8=pË;pKKtx7caqxcan8FEak8qh8fqe86c^c1[^8¯} / N`K0ԥ&oP+-3ԥvtBC\:PSC 56jm(?8tCjqK'9jsktCqdtC]jxK<ĥRCƇSu.5@ĥS I QP2DvBחD>-.5FԈQ#RDJCMuM"QD~\D]jKy)a"/LjH%NjH"/=G?u)"GԂQ0=GDԊu:FDuRFDoujF^zx~tzF\:A#cNҨKmuQ#/=Gd:ԮuF]jڨKmuF]jHt8 p$ߨ8GQZ9mNK >7ꤎQu#=7R'`?Y'ԥ6huM}\M]jK)7u.ۏ'Cp[I?Y': .=믗u*N })9q餜_s9ysNЩK-:y鱾NԡF/~dv԰tN]JCuj)Ӽot OxRO^zөf2Y"mdq$H+E,N ei)HSE Xf24Ľ" fi1HA,-jff3kY"-gq:HۙE zf3Y .hiBHE ff4!"-iiJ[cg:Y"mti3+E,Ng:Y"muqHkE,^g;YnvgYA,pg;8Y"wi3E,€g <4Y/~#A\,Ҍgv<8Y%My=cEZ,Ҝg<8YE"MzqӳHEZ,Ҭgv=k4Ye -ӞEs=R{r9ȵ מ_h=sk - מ\{^h=sk sk - מX{qysk - מ\{ryskA=/Ԟ\{rysk1=V{ b9ȵgk ֞A= Rsk ֞A=X{r3gkA=X{3gk ֞\{ b9ȵgk ֞A=Ǹ bBK3!b9?=X{3V{X{3gk ֞\{ b9ȵgj֞A= bskϠZj ֞\{ b9ȵgk ֞A=/ԞA=X{3gj1=X{ b9ȵgk ֞\{ bsk ֞A= b3 מA=X{3gkA=X{ by bsk ֞A=X{r3 מA=X{3gj1=X{ b9ȵgk ֞A= oR{r3gkA=X{R{ bsT{ư b9ȵgF-gkA=X{ b9ȵgk ֞\{ bsk ֞A=yߟ(מ1= bsk ֞A=X{^h=X{ b9ȵgk ֞\{ bsk ՞1=a3 מA=X{r3Hg kA=X{ b9ȵgk ֞\{ b2Kt[3gk ֞\{'ړ?Yԥ֞ړujO}\kO]jK:.ۏ'Cp[I?Y:.=믗tjO}NoԞtjO^JK=ԞNԥ֞X_S{PkO^zjO}\kO]jKu:.:iI7YEu:~=u'/=Ԟ֞t_S{RjOjCuV{/ׯe3۞m n{qB˶g=mA g=y3۞A n{p3۞m m{ps=mA g=m n{q3۞m n{g=m -۞E,Ҷg=Ym"m{q۳۞5 g=Ym n{i۳H۞E g=m"m{i۳H۞A,Ҷg=Ym"m{a3۞E,Ҷ o{i۳HGE g=mϢb۳_m"m{q۳H۞E,Ҷg=Ym n{a۳F۞E g=mϢg=Ym"m{q۳H۞E,Ҷ o{i۳H۞E gQjO^¶g =Ym"m{q۳H۞E g=Ym n{i۳H۞A,Ҷg= 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{i3۞E,Ҷ o{i۳H۞E Ҷg=mϢg=Ym"m{i3۞Eg=Ym"m{q۳H۞E ҶgDq۳F۞A,Ҷg=Ym"m{='۞E,Ҷg=Ym"m{q۳H۞E,Ҷg=Ym m{h۳H۞E g=m"m{a۳F۞A,Ҷg=m"m{i3۞E,Ҷg=x۳۞5 g=Ym n{i۳H۞AѶg) MyqʳS~n gZy۳H۞A,¶g=m"m{i3۞E,Ҷg=Ymm{gXy۳H۞A,Ҷg=Ym"m{i3۞EѶg=Yt_+o{aUșgo۞1,Zr3۞E,Ҷg=Ym"m{q۳H۞E,¶o{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.q۳۞1,ҶgѿVo{q۳H۞E g=kYmn{i۳H۞E g ۞E g=Ym m{h۳H۞Z=jm=R{r9ȵ מ_h=sk -)X ryskA=/skA=/Ԟ\{b9Ƶ煖skA=/Ԟ\{r9ȵ煖skA=R{r9ȵ煖skA=ǸB[3 מA=X{3Hg kA=X{ b9ȵgk ֞A= bsk ֞A=X{r3 מA=X{3gk -gk 8 מA=X{r zwX{r3gkA=X{3Hg k ֞\{ b9ȵgh-gkA=X{3gk ֞Zj ֞A=X{rtsk ֞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蹿Q=cX{3m3 מA=X{3趿QK9ȵgk ֞A= bskϘrsk ֞A= b3煖3gk ֞\{ b9ȵgk ֞A= Rsk֞A=X{r3 מA=T{ư3gk ֞\{ b9ȵgk ֞A=/ԞA=cX{r3gkA=X{3g_xR{3Fyfa43Fe1oי2E20ʌQ$3FE11cca3D-fR1,1cbƨ 3}}aƨ3Ff1/c_ƨQ|y1J/cT^(2Fe !.c\(Qq9G2F֖1-cZ(2Fe:1,cTY(Qc9e 1+( Q]r 1*+cV^]eUcUƨQRr 1)ǰQL2F)1 )cQaF2Fe1L(cTP(Q?9dœcN(Q9pr e1&/h2Fdɘ0 Q/\r kɘq+Tr K1$cIa%H2F&1*$cHƨ<2Fud1j#CGed1"cEƨ(2FMdq2F9dj1!cB(2F!d:ecg2D %!* c@ƨ1Fc1lc>Ơ| Q8cU1ǰyQq 1cP;^ıc ZcX:(tQq +E1j(q Qs1Fuc1y{ܼŵlQ8]c U1iQq 1cT3a1D)eX2Ϗ;ecX1(bQ8 c 10_Ax1F/|rmWal1Fb !lc?s,0XQ\1FƊ1jc*aP1Fb 2ŋRQF1F1 c'a:1Dqb !JcT&(L.1FYbEc$(IQ8Ab z10FQ1F%1c!aQ2.c ƨ?0FacƨDQ=RGFQ#FQ?֏?ި_/=7&XߨAP+H^o u!.$oi!u1.F}NIQԏQ$/=7dtH^o)#qI#um$=7ԑ'`?Y'ԥ6huM}\M]jK:.ۏ'Cp[IN'u: .:h?s_r>%'.tbNu:9'/} :uE'/=4:Ԩ/S׮SvcNکKi;y趿N;ewM_}N@O]jKu:>'/鄞Szc}Ş/}=ݿ<4-ۘ I^h=AE/MJ J䅖YAޕa -˒<-9ے<.ywK K^hA -#293Zv&yhr&yjB M M^hٛA^299ț8:9ƫ_h d'yy2ӓAܞ Oi~2<@ NPqrG(B PeP2L)Aޢ e(8G9{A " ORq2AZY RqB2e)_sqA^ (}Aq e1c=a1F1c;Ơvc!JǰtQ1FV1c8Q1oü1Fuc1lcec1c^g%_!lc4ƨhà1F=crՌc3Ơe Qx!1FV1c0a1Fc1c^֋/|c>.ƨ\Q8bU1Y̱X`1FbrՊc+ƨUQ8bBu1/J1Fb%cX((PQ8yb ʼn1h0MQ0q e1c%a$1FE1C#ƨF1F-bRc"ƨCA8bzD b˸@Qp Շ1caz0v1c_tt8acƠ7 Qnpc1J cTah0FV1 c(10Da/1U~sͷʠ ^:!.PRחEB _ܷP q锆BM Nk(PPsC u!.P!>ѡ:ġu!.NzKmN}K'?ԥNK'Ajt"DVBC_/}+Q#OQ#RDJCMuM"QD~\D]jKy)a"/LjH=:(y~y)P EF}k7RԥVL>Y`6TԡTNHXwjE^JKu"QE&Do9Doob*բ~&y)"/\x.sNKy?Z'`ԥԄ?Z'bԥVt1 5d$2 e$zS3ǣ˥3 uF]jӨKy>Z'kԡvtS6RF]jHS7RFhQ#o~u#/7tБcNKQZ;sNK y)#/}oiq'zTQ=7ꔏBM>7ď~ԥ揼tFz鹿Q5FRZAmNK !u%$}N K!u5$/=7DuH:M~"y)U$.,NK:e>.iF:RGmN )BcN#o.}o$uBI:~m%u.Ǐ7K%u$}}N2Cm&u$/='dn='ꤓO;KOԯ>'D:P J}M(y) %/}Oԩ(u)%=!>%%괔ԘRZSRrJ]jOK *yi*}7@R]%mNYKM+um%/u%W<Ēu"K]jeK,y?P -iiRK}m-u%8Rt\RK]JtCӯ>Y^2RRR^}N}K/>@-0i4SZa%$z 1XScWesNK ;I.ԥFtߟf22?-3f?~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={ˎ+Kl#U0؍QB:WL(I&˩=Z{ joAkO:ĥS{ ǵԡ֞8tjO\:.ĥS{ҩ=uPkO|ܩ=qԞSZ{ҩ=qԞB=N)S(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΢;\jzG7@7p7O<1*ɿ&±X lGHqg"ŝE;cw),RY3qg"ŝA;w),RĸHqg ƝE;w) bYHqg ŝ5;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ƝԸ۰&HO ~8 U,&X,wcN)Ը貿Q'ԏq.5ԥƝtFSw'ĝ:ԸSuN]jܩK;??Q'7~N^x^^ڟw]'ĝB;7ĝ?Q'ԥĝw),RĸHqg"ŝA;w( bYHqg ƝE;w) bYHqg"ŝE;w1,RY3qg"ŝE;cw),7b"ŝEq ƝE;w1,),RĸHqg"ŝA;wUܙbYFqg ƝE;w1,쏖"ŝA;w) bYHqgA;w),RĸHqgƝE;w) bYHqg"ŝE;w1,RY3qg"ŝE;w),RY3Hqg"ŝA\.1,RYs"ŝE;w),RY3qg"ŝA;w),RĸHqgƝE;w) bYHqg ƝE;w1,RYHqg"ŝErYHqg ŝ5;w1,(ǝE;w),RY3qg"ŝA;w),RĸHqg ŝ5bY3qg"ŝA;w),R9qg"ŝE;w),RĸHqg"ŝA;w( RYHqg ƝE;w1,RYFqg"ŝE;w1,RY3\cYqǝE;kw1,RYHqg"ŝEbY/U( bYHqg΢qrY3qgŝE;cw),RĸHqg"ŝA;w(ĸ沿M;w1,RY3qg"ŝE;w!븳_3qg"ŝA;w),Bøhqg"ŝE;w1,RY3qg"ŝE;8,RYHqg"ŝE;w!QY3qg"ŝA;w),RĸHqg ƝE;kw) bYHqg ƝE;w|),(,R9qg"ŝA;w),RĸHqgƝE;wYw1,RY3qgŝE;cw),RY3qg"ŝA;w),RFqg'Z΢_ŝFڷ(hPWN܉K'ԥƝԸoqP-ԥƝtN\:qPNw 5j)Ը?Ɲ8tNj܉K'j܉kܩC;qĝtN]j܉K'ĥwRNƝw҉;uq.5ĥw҉;w}5j)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;yzwW5ĝwhSwGĝԸ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_uN>7ĝtN\:q'/7ĝĝ:ԸuN]jK:qPN:qƝԸ躿Q'jItߨwGиSwRN^x^]JܩC;nuNjܩK;y?Q'ԥƝDOK؟w?q'/q'ĝԸSwRN]jܩK;&yԉ;}7@Sq'uNܩKy{q'/q'wĝԸnuN]jܩK;y?P;i.4qƝ:ӸsN)ԸSxN^Ӊ;uq.%ۏ塯_vN8SwRN^Ӊ;uq'8q'eN܉;uq'QN6SxN^oӉ;uq.%]ܙ_w{hK:q.5b5iICظSq7bSq'bSwRN^OVN:q'S׸SwcNItYw}O֣q'uNܩK;uq'/'ĝƝԸuN]JCOC_['-$_w:S?:h?s_w>q'.tN:ĝԸtNjK'5ԥƝt_wRNSNƝD?%Ӊ;hܩK;y鱿N'5:Sw:oqK^ĝSm;9|%sA;-sA;h;9󉖸sA;9|"ǝcwrDK9q Ɲcw>wr9q-q ǝwrDK9q ǝw>wr9q-q ǝwqmqg Ɲw1 bĸs ŝ1;9 bĸ3q ǝA;w13qgA;w1 b9qg Ɲw1 bs ƝA;h;wA;9 T'ĸsΠO Ɲw1 bĸs ƝAwW9 Rø3q ǝA;wrt% b9qg Ɲw1 bĸ󉖸3qg Ɲw1 R9qg ƝA;9 bt% bĸ3q ǝA;wrĸ3qgA;w1 b9qg Ɲw1 bĸ󉖸3qgA;w1 b9qg Ɲw1 bĸs ƝA;8 bĸ3q ǝA;w13qgA;w1 b9qg ƝOĝA;w1ĸ3qgA;>7j;wrĸ3qgA;w13qg Ɲw1 b9qgew03qgA;w1 bDKĸ3qgA;w13qg Ɲw)/ƝA;wrĸ3q ǝA;w03qg Ɲw1 b9qg ƝA;f;w03qg Ɲw1 b9qg Π\sΠqZA;>i;wr3qg1;w13qg Ɲw)aD;c.۴ĝA;9 bĸs ƝA;wr3} 8;w13qg ŝcw:3qg Ɲw1 b9qg ƝA;f;w1 b9qg Ɲw)as ƝA;9 bĸ3q ǝA;wr3qgA;w1 b9qg ŝcwgw1|% bĸs ƝA;wrĸ3HqǝA;wYs ƝA;9 Rø3HqǝA;w13qgA;w1 b9qg Ɲw]"(hQA'ĥwRN]jҷSqwRN\:q'.Sq'Љ;w 5j܉AN:q5ĥw 55ԡƝ8tN\:q.5ĥw҉;uqPN|܉;qĝԸSw҉;qĝB;N)ԸS(qL?oqKNwRN^JK;uq.%ĝ:ԸSw%%ԥƝԸwRNƝD0QNƝD;#hK;w]7[ܩoq.5ĝ4q5ԡƝNIwN^JܩK;uq'QNƝDw>DwGиSwRN^ߨwwcNK-@W]GĝwRN]jItwRN^։;w}։;w}։;yzqĝtNhSwRN^z։;uq'/GĝԸSwGĝԸ(q'hsNܩAN]jK:q.5$wGĝ:ԸuN]jK;ykN܉;q'/%ԥƝԸ趿Q'jIQ'ԏq.5ۏ7FS׸uNjK:q.5ԥƝD:q.5ԥƝߨw]7ĝD_uNw}N܉K'FSSw}NܩK;y麿Q'jIQ'7޸Sw]7ĝB;.uNwRN]jKoԫK;uq'm}NܩC;uq'/'ĝԸzuN|''奯:q'uN)ԸSxN^Oԉ;uq.%B5ԇ5BSwRN^JܩK;uq'ĝ4:qƝtw 5$ԉ;uq.5@5ġwPN@SwmNܩK;uq'/q'MNM7ԙƝDtNƝwuNܩK;u)q'~ĝ@;i.tNNܩK;wĝwuNܩK;u)q'ĝqgq7ƝԸSwmw4$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;uq'[ҷťqpgv;p3F1fx3F1^uh3Fcc-uhsv:C41Fg &:C91<sh3Fۜ1e sh3FcQmr$g9c0=Χg 8k0-Lq`C1y?Yp`5Xg 7k0Yo`{ӛ1Zެf v7k0n`s3F5Xܬfm`mccYۉj0l`e3F#5j0Y l`_5X׌Ѹf 5kOk`HU|9_~X5ՌѪf F5kI͚ qP{1Ӭf 4cY),i`Hs w4k0YhhC54C4Yg`=3F5ά3k0Yfh5s},f`0{1ˬZf 2k,e`(3F;5ɬJf F2p#5XȌ@f 1k0Yuc`Ә1ZƬ0f v1k0Ubּ $f 1k0Y=a` c5Œf 0k0``#1f 0p5e /K}Y-_|w/k0{^`1Ze .c4wY]`2FS5Xe v.K.룣\hs}tp[`޲c8nYmL[`2FÖ5صeV-k0jYMLZhѲe}}s4gY5Y`2FS5Xev,k0cY~Ų#1ڰe ,k0`W`2F5خte!y[YV`5be +kWUּ (Ve*kTYT| W*k0Rʚ%Xy?P}S`2F5ئ4e )c4LY~cJYrY_nR`2F5e(kFY1lQhe (kv2_P`2F5eOli}2F5؞d 'c4ђ8q +71c; \:1u b8ȱck A9x bq FA=r1cAn?~1c @ bDK 2dCA,!cB2c2= A,"D(2UdA"F b9md ֑G\'ʁd AN$>'j$ b&N2-dS A% b.^r AL&Lr4j2 v1 'XN1v2dA'O)aA9 e FA(9 bGĐrK Al)S>RS)T bRĦr VA*aX7"Vr[ĸ2u AA,,9 Rc2HgA,Zri2ecA-[ư|"1mZ 6] bv9e AL/ R|2}~yRwff AN0`1 R9fCA.1b b95fs d b&i(3Uf vf b9mf֙A3Ǹ btߟ% bH3 gA4jrT3fcA5k b9f 5cmgm|% bts ƛA7orĀ3H'Al8wYs3 vA 9 RÖ3H1לA9s13IgA:Xu1 b9ag v]&w13qg ƝOĝA;w13qgA;w1 b9qg Ɲw1 Røs ƝA;9 bĸ3q ǝA;w13qgA;w)aDKY_}"ŝE;w1,BY3qg"ŝE;w),RY3qg"ŝA;w),RĸHqg ƝE;w!aYHq ǝE;"ŝA;w) bY)RY3qg"ŝE;w),Rwqg qg"ŝA;w) bYt-ǝE;w),RĸHqg"ŝw),RY3qg"ĝ1;w),RĸHqg ƝE;w) bYHqg"ŝE;w1,RYHqgŝE;w),RYs"ŝEw3A;w),RĸHqg ƝE;w) bYqg "ŝE;w1,RYHqg"ŝE;w),RY3qg"ŝw),RY3ĝ5;w1,(ǝE;w),RY3qg"ŝA;w),RĸHqg ŝ5bY3qg"ŝA;w),R9qg"ŝE;w),RĸHqg"ŝA;w( RYHqg ƝE;w1,RYFqg"ŝE;w1,RY3qg"ŝE;8,BYs(ǝE;w) bYHqgŝEoBqg"ŝE;w}쏓"ŝA;w(,BøHqg ƝE;w) bYFq Ɲ5mrY3ŝE;w1,RYHqg"ĝ5;w}ٯTY3qg"ŝE;cw2 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. ƝE;w1,BYqg "ŝE;w1,RY3qg"ŝE;w(,RDKYt{yKyzPΠM>щ;qĝԸSw-jŝԸN܉K'j tNƝB;wGиNܩC;qĝB;q;uq'NܩK;qĝtN]j)ԸwN\:q.5ԥƝtN\:qPNw 5J)ӸO[ҷ(5ԥƝwRN]JC;uq.5$JɏKܩK;uq'/%ĝB;aĝB;wGиw 5$oԷSxN]jK;yiNjܩC;y)q'.(q'>ĝSIܩK;w 5$!oԷS?ƝԸwFS׸uN]JC|mNܩq.5$։;uq'/GĝB;>GĝB;>GĝhtN\:q'}NܩK;uq'/=Gĝ:ԸnuN]jܩK;uN]jItw 5$wGиSwuNܩK;>Gĝ?Z;uq'=7ĝԸwFwN^JܩK;uq'mN)ԸsNܩAN]jKoK:q>q'/7ĝ:ԸuN]jܩK;nuN]jܩK;y鱿Q'$oԉ;7ĝ4FNK:q>7ĝĝ@;i.tNNܩK;wĝwuNܩK;u)q'ĝƝ.W^ĝFwRN^/VNƝD?;w~N^/։;w}/։;uq.5d5ġwЉ;y;q;uq'/='ĝD:q'd=w]'ĝԸSwmNܩkܩK;y?Y'ԥĝѲ9˝9˝O,wr /w>Ѳ9˝9˝O,wr /wr-˝9˝O,wr .wro-wq3˝ .wqs;>Fr /wq3˝A\ .wq3˝ .wrg;A^ rg;y3˝A\ r/w}?'Z;Q; .wqs;>~_ .wrg;A^ rg;az;*q3˝ .wrge .wrg;9˝A\ rg;hY rg;9˝A\ r/wq3˝A\ .wqs; .wrg;9˝A\ rg;y3˝A\ r .wp3˝ .wq .wqs; .wrgF-˝ .wqs;1^ rg;9˝A\ rg;y3˝A\ .wq3˝ .w>Ѳ .wqs?Zrg;y3c .wrg;A^ rgc .wq3˝ .wrgeA^ rg;y3˝A\ r-˝A\ rg;y3˝A\ .wq3˝.wrg ;A^ _es;.wrg;A^ rg;y3˝A\ r,˝AZr /wq3˝A\ .wqs;c~9!˝ .wrg8-˝A\ -wp3H˝cΠ8-˝A\ rg;y3H˝1\|"/w\iY r /wq3˝ .wqs; .wܙrg;y3˝A\ r/wzs; .wrg;9˝A\ rg;fY rg;9˝A\ r /wi3˝AZ .wqs; .wrgd-˝.wqs; .wrg;9˝A.wq .wqs; .wrg;9˝A\ e];y3˝A\ -wp3H˝c .wqs;_e3˝A\ r .wp3˝Ѷtw13qg ƝOĝA;w13qgпÿ9 bĸ3q Ɲ1;wrĸ3Hqg A;w13qg Ɲw1 bĸs ƝA;9 b3q-qg"ŝA;w),Rĸqg ƝE;w) bYHqg ƝE;w1,RYHqg"ŝE;w),RY3qg"ŝw),w1,RY3qgΧHqg ƝE;w) bY豿Q;&),RĸHqg ƝErY3qg"ŝA;w),R9qg"ŝE;w),BøHqg"ŝA;w) bYHqg ƝE;w1,RYHqg"ŝE;w)QY3qg"ŝE;9,RY3qg"ŝE;>w),RĸHqg"ŝA;w!aYHqg ƝE;w) bYHqg"ŝE;w1,RYs"ŝE;w)QY3qgF9,RĸHqg"ŝA;w=7qg"ŝE;w),R?Q;kw1,RY3qg"ŝE;9,RYHqg"ŝE;>w),RY3qgŝA;kw),RĸHqg ƝE;w( bYHqg ƝE;w1,RYqǝE;kw1,RYHqgЇ"ŝE;w(,zu;w),Rĸcw) bYFqgƝE;w1,RYHqg"ĝ5;1o"ŝA;w) bYHqg ƝE;kw) B 8Jŝ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΢_ŝoqQРƝENܩK;uqKNƝ?[ܩK;qĝtNƝ@'j)ԸSq'~;qĝ:ԸN)Ը׸SwЉ;qĝԸN܉K'ԥƝB;q'ĥwRN]j܉K'ĥw 5:qPNĝ2;ŝ/};kܩK;y)q'/%ԥĝwPN]jISwRN^JK;wD;w%ԏq'/%jIt]ߨoqƝԸwĝ:ԸSwRN\:q'QN|܉;y)q.5ԥƝD;w}]7[ܩAN]jK;ykNܩkK:q.%Wqg?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'DuNwRN^x^^zoԉ;q;y龾Q'ԡƝtߨwRN]jItߨwRN]jK:q'eNIQ'ԏq'/7ĝtN^oԉ;q;uq'7ĝԸuNƝDuN};uq'uN)Ը貿Q'ԏq.5ԥƝtFSw'ĝ:ԸSw}NܩK;??Q'7~N^x^^ڟw]'ĝBOԉ;y?Q'ԥƝ ոSָn uN]jܩK;y)q.5ԥƝDw<ĝw}N)Ը?P'ԥƝԸnոN܉C;iuN]jK:q.}$ԥstƝ4}StNiI?N'jܩoq'/]ĝԸSwׯ;q'uNܩK;uq'/ĝԸs}N Ը沿M'ĝԸ(q'}Nܩoq'/]ĝԸSwmNܩOkܩK;{]ܙ|/։;6b5iICظSq7bSq'bSwRN^OVN:q'S׸SwcNItYw}O֣q'uNܩK;uq'/'ĝƝԸuN]JCOC_['-$Ѳ9˝Dr /wr /w>Ѳ9˝9˝O,wr /w>Ѳ9˝9˝Ѷ .wrg;A\ rg ;y3˝A\ r /wq3˝A\ .wqs; .wrg;9˝A\ rg;x3˝A\|e3˝Aqs;A^ W;9˝A\ rg;y3˝A\ΠZq3˝ .wrge .wrg;9˝A\ rg;hY rg;9˝A\ zֲ .wqs;A^ rg;9˝A\ r /wq3˝A\ .wq3˝ΠF-˝A\ rg;hY rg;y3˝A\ r.wq3˝ .wqs;1^ rg;9˝A\ rg;y3˝A\ .wq3˝Qr-˝A\ rg;q3˝A\ΠZ;9˝A\ rg;y3˝A\ .wq3˝ .wrgeA^ rg;y3˝A\ r-˝A\ rg;y3˝AZ; .wrg;c9˝1\ rg;y3˝A\ .wi3˝ .wqs;A^ rg;4rg;c9˝A\ rg;}p3sA\rg.wrg;9˝A,wqs; -wrg;9˝A\ rg;y3H˝1\|"/w\iY r /wq3˝ .wqs; .wrg/w+,wq3˝AZΠB/wrg;A^ rg;y3˝A\ r,˝A\ rg;y3˝A\ -wp3H˝c .wrg;A^ rg;y3H˝1\ r /wq3˝A\ .wis;3\ r-˝A\ r /wq3˝A\Πur/wq3~uY .wqs; -wrg;A^ rg;y3˝A\ r .wp3˝ѶtŝA;9 bĸ3q-qg ƝA;9 bĸs ƝA;wbø3q ǝA;w03qgA;w1 b9qg ƝA;9 bP9qg ŝ1;h;w) bYHqg ƝE;kw1,RYHqg"ŝE;w1,RY3qg"ŝE;w),RĸHqg"ĝ1;w)丳Hqg@\3qg"ŝA;>w>E;w1,RYHqg"ŝE;w;-_3qg"ŝA;.帳Hqg"ŝE;w),RYs"ŝE;w1,RYX-ǝE;w) bYHqg"ŝE;w1,RY3qg"ŝE;w),RY3Hqg΢F9,RYHq ǝE;w1,RYHqg"ŝE;w),RY3qg"ĝ1;w),RĸHqg"ŝA;w) bYHqg ƝE;wrYHqg ŝ5;w1,(ǝE;.;w),RĸHqg ƝE;w) bYHqgΚD1QĸHqg ƝE;w)丳Hqg"ŝA;w='qg"ŝE;w!QFqg"ŝA;w) bYqg ƝE;w) bYHqg"ŝE;wqYFqg"ŝE;w1,RY3Hqg΢\W3qg"ŝA;>qg ƝE;kw!aYHqg"ŝE;w1,BYsΚ69,RĸHqg ƝE;w) (,BYHqg΢;;w),RY3qg! ƝE;w) bYHqg"ŝE;wqYHqg ƝE;w1,BYqg "ŝE;w),RY3qg"ŝA;w(,RĸHqg"ŝA;w!aYQYs"ŝE;w),RY3qg"ĝ1;w: bYHqg"ĝ5;w0,RYHqg"ŝE;w),RY3Hqg"ŝOĝE;m;9|%sA;-sA;h;9󉖸sA;9|"ǝcwrDK9q Ɲcw>wr9q-q ǝwrDK9q ǝw>wr9q-q ǝwqmqg Ɲw1 bĸs ŝ1;9 bĸ3q ǝA;w13qgA;w1 b9qg Ɲw1 bs ƝA;h;wA;9 bĸsΠO Ɲ.;w1 b9qg Ɲw)3_Ÿs ƝA;9 w13qgA;w1 bDKĸ3qgA;w)3qg Ɲw1 b9qg ƝA;9 bĸs ƝA;wrĸ3qgA;cw13qg ƝOĝA;wrĸ3qgA;w13qg Ɲw1 R9qg ƝA;9 bĸ3q ǝA;wrĸ3qgA;w1|% bĸ3q Ɲ1;wrQKĸsЅqg ƝA;9 bĸs ƝA;wrĸ3q Ɲ1røs ƝA;9 bĸ3q-qg ƝA;9 bĸs ƝA;wr3q Ɲ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ĸs ŝ1;wr>w JǝA;w)3hq ǝA;w13qgA;w1 R4Kĸ3qgA;w13Hqg ŝcw1 b9qg ƝA;9 bĸs ŝ1;wrĸ3qgA;w)3h?ø3q-qg Ɲw1 bĸs ƝA;8 b˺ĝw1 b9qgƝA;8 bĸ3q ǝA;wrĸ3qgA;cw13Wq_wԸ3|OtN\: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)qPNa(qPNĝ4ĝB;-7޸SwRN^SwPN^J܉K'$J܉;q'/%ԥƝԸ(qPN;F};#hܩK;y)q'/}oԉ;q;y鱿Q'ԥĝGĝ4ԥƝtwRN:q'/}VNjC: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'/'ĝԸS.w}wwmNܩK;uq'/%ԥƝԸhN@SwN^ԉ;w]ĝԸSwmwЉ;qq'}NܩK;y?P'ԥƝԸո沿Ow꛾<ĝDtNƝwuNܩK;u)q'~ĝ@;i.tNNܩK;wĝwuNܩK;u)q'ĝƝԸowq|eNoܩoq'bhqPNoK:qPN:q.5ԥƝtݟƝ8tN:q'/18q>q.5d>Y'$ZGNdSwRN^O։;q;uq'/'ĝ?N[I?Y'䥯u:q.=~>Ku:q'~涿N'7}N\:q'/=ĝDu:q'/}Ӊ;uq'/ĝ:ԸwYOܩkܩK;y龿N'ԥĝ:ps 9c89ۜc84^a1YΧ*r&xs 9hs8e3?D8p3FS1Zp`3D+c8 Mphs 8cof7c49˛1ތff7pu3F1-nhp3{C8m>6c4;Q6pg3F31ZÑ͘_[1،y`l 6cykf5c49˚1 ]|f5pU3F1I͘ yP3F{c85if4c!ͧff4c1Ќфf 4p@3F1όzg\gәcfh6s W3c41̌bf3c9s1ZˌXf2h*3DK1Ýdh%3F#OMdh!s 2cyc8f1c49˘1ƌ.ff1|j3F1I-bh3F{c85ah s 0c!1 fV0c491x3F1_h2Fӗc|:޽^h2F1 ^hr .cvm]e.c4t9F;!eF.p2F1ZÁ[h2FOqm[h2F˖c8l]ZeF-ciI1\e,h2Dk1іNYh2FCccXhr 7,c4a X~e+c^91ڮte +Õ1ح lVh2F1 Vhr*CVv, @[c>5U UNex2>7ިDe*c0P91:Sh2FӔ1ZaRhiJrY_oRhr )c4H=1e(cE9S1X ev(p2F+1=B9_ MPh2C?31d'c<9Ó1ڝNht2F1|/Nhp2F{1õMhkr &c4LdV&c4291d&p_2F1ZqlKhZ2F˒c8,]JhUr G%c)/JƬG'9ɧd$c%9S1Zѐdv$pF2F+1 MH쿣1ڏ|d#p<2ۑ!rGh72F1ZmFh2r #c4EZd"c,S1Y5 OrQ8Io5rU8Y-] \>ђr[8q ׅOpA h) 91p#'Z*A 3|%4pSAn h 6p{'ZA.99|9p1; bxp AXr~0 AL 1B?1C bqK Al9F b1= A,$r(1Ub1&L|%M b?N<1}bA.>9Al)rL1bCA.*UX1Hb\z'j,X b8bej1 wA X.rv1b'Z A X0rĆ1HWA11d1)c[AX31g b8Ac &41j bĬq A,6bø1u A8p|%q o9r1cCA.:u1cs ><x R8c VA{ b1 AX?r1d AN @1| b2! 1L!Br QKr AL"Dr*2Y wA #XF162qdA#c.@2 'Al$Ir%L2dC'ZJ Al%Kr-\2 A,&Lh2芌% v1 'XN1v2dA'O)aA9 e FA(9 bGĐrK Al)S>RS)aO9Ae &Al*9 bUĬrA.iOA+XWr^?NK`r 51,TYqf2 AL-Z12He {'rpsߦ% bs9e f]1 byr ŗ1/_r3 J'Al0a 3h! AL1b139f{A2Xd1 R4K*3YfA3Xf163Hqf cg]'k)49 bH3 gA4jrT3fcA5k b9f 5cmgm|% bts ƛA7orĀ3H'Al8wYs3 vA 9 RÖ3H1לA9s13IgA:Xu1 b9ag v]*g-󉖸sA;9sA;9|%s'ZA;9wq9q-q ǝwqDK9q ǝOĝwr9q-q ǝwrDK9q ǝOĝwb9qoŝA;wrĸ3qgA;w03qg Ɲw1 bĸs ƝA;9 bĸ3q ǝAA;w1 R9qg ƝOĝA; Ɲw1 b9qgЇ'qgA;w1 b9qg Ɲw)awq| ƝA;9 w13qgA;w1 bDKĸ3qgA;w)3qg Ɲw1 b9qg ƝA;9 bĸs ƝA;wrĸ3qgA;cw13qg ƝOĝAZA;w1 b9qg Ɲw1 bĸs ƝA;8 bĸ3q ǝA;w13qgA;w1 b9qg ƝOĝA;w1ĸ3qgA;>7j;ĝA;w13qgA;w1 b9qg Ɲw\'qg A;w13qg ƝOĝA;w13qgA;w1 b9qgL A;cw1 b9qg Ɲw1 Røs ƝA;wrĸ3q ǝA;w)|% Røs ƝA;wrĸ3q Ɲ1;r]A;w13c3q ǝA;cw)3qgA;w1 b9qgƝO3沿MKĸs ƝA;9 bĸ3.w)aĸs ƝA΃q+@;w)3hq ǝA;w13qgA;w1 R4Kĸ3qgA;w13Hqg ŝcw1 b9qg ƝA;9 bĸs ŝ1;wrĸ3qgA;w)3h?ø3q-qg Ɲw1 bĸs ƝA;8 b˺ĝw1 b9qgƝAuZ ƝA;wrĸ3q ǝA;w1ĸ3qgh;.w^w13qgΠ'Z ƝA;wrĸ3q ǝA;w1ĸ3qgA;w)a9qg Ɲw1 bĸs ƝA;wrĸ3q ǝA;w0|%,RY3qg"ŝE;w!QĸHqg"ŝA;w),RĸHqg ƝE;w) bYHqg"ŝE;w0,RYs"ŝEq ƝE;w1,),RĸHqg"ŝA;w) bYFqg_ŝ*ƝE;w1,쏖"ŝA;w) bYHqg5qg"ŝE;w),BøHqg"ŝA;w) bYHqgΠ"ŝ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=7qg"ŝE;w),RĸHqg"ŝA;w) RYsٟ(Ɲ5;w),RĸHqg"ŝw),RY3qg"ŝA;w),Rĸqg ŝ5;w) *,RY3qg"ĝ5;w),RY3qg"ŝA;w),B9qgŝA;w),RĸHqg ŝ5;r] ƝE;w1,'ǝE;w!QY3qg"ŝA;w),RĸqgA;k.丳Hqg"ŝE;w),RY3qgŝE;w),RqgRqg"ĝ1;w1,RYHqg"ŝE;w),RYs"ŝE;w1,RY3qgŝE;cw),RĸHqg"ŝA? "ŝA;w(,RĸHqg"ŝA;w!aYQYs"ŝE;w),RY3qg"ĝ1;w: bYHqg"ĝ5;w0,RYHqg"ŝE;w),RY3Hqg"ŝOĝE;-%<=qg&ĝtN]jܩK;_w 5|qN]j܉K'ĥw 5:qPNƝB;#h܉C'ԡƝtNƝƝ:Ը;qĝԸN܉K'ԥƝB;q'ĥwRN]j܉K'ĥw 5:qPNĝ2;ŝ/};a}\N]jK;y)q.5ԥĝQ'ԡƝԸuN]jItDD:q'wD?Q'jܩoq'/'ĝԸSw}wwmNܩKĝSwRN;iuN}ߍ;y?P'jItwRN]jKj܉C'ġƝ4:q.5@SwRN^TN>Mܩoq4$w 57޸tN]jܩK;yqzy?N'ԥƝԸntN]jI>N'jIsߦwpN]8ۤH$[3r Xgއ"DZj%7OƝD;w 57޸ntN]jܩK;y?N'ԧ5ԥƝwWqg}NIX'$Z6jܩnN^/։;w}/։;uq.5d5ġwЉ;y;q;uq'/='ĝDuNz6$O։;uq.5ĝDuN]jK:q.%ۏ'C?['-$؟wwz鹾N'$ĝO܉K':}NKtN]jKu:q5'5ԥƝ_wRNSNƝD?Wt_wиSwsNܩkKu:q.%ԡƝq'/=7ĝ:ԸnuN]jܩK;uN]jܩK;y鹿Q'$zߨw}oԉ;#hK:q'.uN}\NjC:q.5FSq'FSxN]jItߨw 5$zߨwGиSouN^zx~Sw'ĝ:ԸSwcNܩK;n?_sN܉oĝDzsNIt۟w 57޸uN]jܩK;y豿P;a;y辿P'ԥƝԸwRN]jI4q'sNܩq'/=ĝB;nuN]jܩK;y?P;qĝ8Ը?P'ԥƝtwRN]jKjIOwnܩ3;>ĝB;78SwRNx~=g{NItwRN]jKq:q.5$Xw5yߦwpN]jI豿M'7޸ntN]jܩK;y?N'ԧ5ԥƝwR;WqLNaNƝ4bSq'bSwRN^OVN:q'S׸SwsNI>Y'$\gNdSwRN^O։;q;uq'/='ĝn?_=lķcNKuN]z}_/=ĝD:;qĝ_wӉ;ysNܩK;y鱾N'ԡƝ/~ĝƝԸtN]JCuj)ӸotNwRN^zӉ;q;y龿N'ԥĝ:Ը-|}[˥_ίږ;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\t|;9˝A/wqs;A^ rg;ye3˝A\ r /wq3H˝c .wqs;A^ rg;9˝A\ r /wq3˝A\ .wq3˝ .wrg; -˝A\ r /wq3˝A\ .wqs; .wrg;9˝A\ rg;y3˝A\ r /wq3˝ .wqs; -˝A\ rgs .wrgF-˝A\ .wq3˝ .wrg;Aw.wq3˝?Q^r /wq3˝ .wqBrg;A^ OԲ9˝A\ rg;y3H˝1\.wq3˝ .wrg;A^ rg;9˝A\ r /wq3˝AZ̲.wrg;A^ rg;q3˝A",wq3˝?Nrg;y3H˝1\ r/wq3˝ .wqs; y3} .wrg;9˝A\ rg;y3H˝1\ r /wq3˝ |w+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 ;ΠY|vaycva9YY1:ǰä2.:0Þ29ǰØs [0’s C˸Ìs*!8/s 1,8/s 17ǰ޼1l70r27ǰl260fs/1 6ckaZ3FfZ1L5cPj(N3Ff*Ech(ьQ@s 130ΌQ43Fe12cea(3FMf !,2cdƨǼs՘1 l2<)fJcaƼ_gbTa(3F f c_(Q}9e 1*/]x/Rwr ˘%cX\(Qo9ejŖ1j-/2FeBucYƨAd9e1 ,ǰQ^r 1J+cTVaX2FYV1*cT(â2FAezcTS(QK9)eJ1(/2Fe"1l(cPƨQ@9dՓcOƨQ:rr u1&Q4f2F1 &cK(P-X2F1*%cJƨL2Fd"˸Q"B2湾:#CGƨ82m}uFƨ02F]dUcEƨQ9Ed1!ǰQ rRȐar 3U1 ǰQ2Fe?(Qq 1*0|Q1FF1hC7c3ƨeÔ1m}n2ƨcÌ1c"4CJcT0(`~1Fbŋc. ] Qx!kl1FF1jc,a`1Fbr1c+UQ8bBuc)u/TFqŘ1c'ƨNQ8mbc&ƨKQ*"c$(IQ8AbzcX# F QqK10CQ1F &1*c a0Da1lcƨps -= \rRpA 9+rX8eᅖpA .1 90Rrb8GZ*A 3ri8ȩ ZbA 97BKp8 'ZA: ma = b|p 1 @ b1 WA!1D1)b[AX#1G b8 1EbAn%J R8]b Z AoA'1PB1MF1 WA)1TR1b[AT+0W b87:PjW1Yf1}j1 wA X.rv1b -b A,9a bq+ fA2rĔ1- njA3g1EcAn5j b8]c ALmaĺq A X8^hI81r1c; \:1u b8ȱck A9x bq FAZA>| b81cA?1 b9 d FZ* fA Bb 2- ǐAoA!9 b$2M GA"Er02edAn#G<2}HưD2d#A$I b(y b*V2 גA%Kr0b2dA&TM0n2d N1 b=9d 1,(9 bCĈ2 gA(RrIĔ2-eb,5erT bRĦr VA*aX7"Vr[ĸ2u AoA,,9 Rc2HgA,Zri2ecA-[ư˘mZ 6] bv9e AL/ R|2 A 0X`r ff*10?1 b31 טA1cr"3If,Qf fA29 b4s ř13gq@3 'Al4iL3fCA.5jư b9ȵfs A 6 bfs͠ vZ AL7 bz3 A 8TpqĆ3_.RqrĎ3! AJ9cr)39g{ \t1 b9Qg fA:1aĴ mmg_ŝDh?]ӃwoB'ĥw-q.5|}[)Ը};uq'.N)ԸĝB;w 5ďq'Sw҉;wwPN:q'.Sw҉;qĝԸSq'>ĝtN]jܩK;qĝ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[ܩAN]jK;ysNܩkK:q.%FSwREŝhS߸uNƝDuNƝDouN^zx~tN\:q'QN~hSws}NܩC;y?Z'ԥƝԸ?Z'ԥƝD:qPN:q~;uq'/GĝԸcNKոSwsNܩK;y)q'/}oԉ;q'ĝԸSw7ĝB;>7ĝ4ԥƝuN}\N^zoԉ;uq'/7ĝԸSw7ĝԸS:qPN: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<ĝwcN)Ը?P'ԥƝԸոN܉C;iuN]jK:q.5ԥƝƝ44qƝ:ӸcN)ԸSxN^Ӊ;uq.%CĝDq:q.5ԥƝtwRNq:q'PNm:q'~'ԥƝD;tN};y鶿M'ԥƝtN}ZN]jKq:q.5U\_ww 5Ϥq'/w}/։;uq.5d5ġwЉ;y;q;uq'/='ĝDuNz6$O։;uq.5dS׸SwcNܩK;yI|;>'ĝ?Y'ԥgs}NIӉ;MNKu:q':>ĝԸtNjKwYOܩkܩK;y鱿N'ԥĝ7ĝƝߨwRNoԉ;uq.5$z|~+@wtNoҸuN:qPN:q'/=7ĝ4FNK:q>.q5FSwmN)ԸcNܩoq.5$oԉ;woԉ;#hܩK;uq'/=~Q]JܩC;uNjܩK;y?Q'ԥƝDOԯ?Q'7~N^zx~?Q'$Oԉ;woK:q.5ԥĝ<_ƝƝN|bhCظSq~&;y龿X'jIX'ԥƝԸnոN܉C'/'5ԥƝܟwO։;>'ٸ?Y'ԥƝԸuN}\N]jK:q.%ۏ'C?['-$؟wdS?Ku:q'~澿N'7}N\:q'/=ĝDtN^_wRN^zӉ;uq'/e=q>q.5:Swmw4$:S?ƝԸtN}\N^Ӊ;u)q5:};__wr/Y;9˝A\ rg;/,wq3˝A\ .wqs; .wrg ;9˝A\ rg ;y3˝A\ .wݴA^ rg;9˝A\ r /wq3H˝1\вY"-wqH˝EZ,?˝EXrg;Y"-wqH˝EZ,rg;Y .wiH˝EZ rg;"-wi˝1\,rg;yH˝Ei3˝EZ,rg;ziH˝A\,rg;"-wi3˝EXrg;Yzz=KܙrghyH˝A\,rg;Y΢hys;Y"-wqH˝EXrg;Y .wiH˝A\,rg;"-wi3˝EZ,rg;Y"-wi3H˝5Z,rg;Y"-wrg;"-wisY"-wqH˝EZ,rg;Y.wiH˝EZ rg;Y .wiH˝A\,rg;"-wis;Y"-wiF˝EZ rgFyH˝A\,rg;"-wi3˝EZ,rg;Y"-wi}Y .wiH˝A\,rg;9˝EZ,rg;Y"-wqH˝EZ,rg;Y -whH˝E "-wi3˝EZ,rg;Y"-wi3˝EZ,rg;Y",wrg;k"-wiH˝A\,rg;Y΢ Z rg;΢qrg;Y-wa3˝EZ,rg;Y"-w}j˝5ZΚmrg;Y"-wqH˝EZ,rg;Y"-wqH˝EZ rg;z_.w"-wiH˝A\,rg;Y"-was;Y"-wqH˝EZ rg;kY.wiH˝A\,rg;>'˝EZ,rg;Y"-wqH˝EZ,rg;Y.wgYA^,rg;Y"-wi3˝EZ,rg ;Y/~˝A\,rg;Y-wa3˝EZ,rg;Y"-wqH˝EZ,rg';kY -˝E7wry%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;wdĸ3q煖3qgBĸs ƝA;9 zӿ1 b9qg ƝA;9 bĸs ŝ1;wrĸ3*ǝAĝ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;w1ɸ3qg -qg ƝA;1aĸsΠZ Ɲw1 bĸs ƝA;9 bĸ3q ǝA;wb?Q;cwrĸ3q ǝA;w1w1 bĸs ƝA;9 bĸ3q ǝA;cwbø3qgA;w13qg øs ƝA;wrĸ3q ǝA;w)w)a9qg ƝA;9 bĸsƝA.q ǝA;wr?NKĸs ŝ1;wqĸ3q ǝA;w13Hqg 9yߦ% b9qg Ɲw1 bĸs ŝ1;wrĸ3q ǝA;>W*3hCs ƝA;wrĸ3q ǝA;w)w1 bĸs ƝA;9 Rø3HqǝA;wrĸ3qgA;w13HqgMLA;w1 b9qg ŝcwgw1w1 b9qg ƝA;9 bs ƝAwYs ƝA;9 Rø3HqǝA;w13qgA;w1 b9qg Ɲ_h;*-BK9q ǝw~-sA;/ĝwry%sA;/sA;/ĝwb9q煖sA;/ĝwr9q煖sA;9wr9q煖sA;8B[ĸ3q ǝA;w13Hqg A;w13qg Ɲw1 b9qg ƝA;9 bĸs ƝA;wqĸ3q煖3qgBĸs ƝA;9 zӿ1 b9qg ƝA;9 bĸs ŝ1;wrĸ3*ǝAĝ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;c'qg A;w13qg ƝZ ƝA;wrĸ3q ǝA;w13Hqg A;cw1 b9qg Ɲw1 ׽bwrĸ3qgA;w13qg ŝY ŝ1;9 bĸ3s3qgA;cwƝw1 b9qg8-qgA;w0 R9qg Ɲw1 bĸs ŝ1;/3}3q ǝA;wrĸ3qgA;w0 b9qg Ɲw1 zw~C/;W|ΠA;w1 b9qg Ɲw1 b2Kĸ3qgA;w13Hqg ŝcw1 b9qg ƝA;9 bĸs ŝ1;wrĸ3qgA;w)3h?ø3q煖3qgA;w1 _% bs ƝAwYs ƝA;9 Rø3HqǝA;w13qgA;w1 b9qg Ɲ_h;"|-?]=]Ը3w҉;uq.5|}[)Ը};uq'.N)ԸĝB;w 5ďq'Sw҉;wwPN:q'.Sw҉;qĝԸSq'>ĝtN]jܩK;qĝtNƝ@'j)Sqoq'Q2kܩK;y)q'/%ԥƝwPN]jISwRN^JK;w/D;w%ԏq'/%jIt[ߨoqƝԸwfNjK;qĝD;q'ĝԸSw%jI6C(q~;uq'/%:q>q'/=7ĝuN]jܩK;/ߨ;U;uq7iK:q'hSq'h?_.NIwRN]jK:q5hSwRNhSwGĝB;w=GĝԸnuN]jI?Z'jܩC;y?Z'ԥƝ>7ĝwRN]jܩK;uNƝDuNwRN^x~ߨwwc}NܩC;y鶿Q'ԥƝԸ辿Q'ԥƝԸuNĝD;>7ĝ4FNK:q>.q5FSwmN)ԸcNܩoq.5$oԉ;woԉ;#hܩK;uq'/=~Q]JܩC;uNjܩK;y?Q'ԥƝDOԯ?Q'7~N^zx~?Q'$Oԉ;woK:q.5ԥĝ<_ƝƝĝԸSwmwЉ;qĝĝƝԸuN:q'd=w'ĝԸSw}NܩkܩK;y?Y'ԥĝ˝a ,wa,wj9,wi ,w"-w?N\<˝EZ2n0=p ˸;pË8:ar8Y1 07k1 ǰ52. 04" ǰ2^Ɖc^}CXQ\xcaY8aeaV8UeaS8IaP8=&71?OV1'0Aa &Z FA rWİ0e Al .ļ0}aA. 1ad8ȕa3 v4 bjpc ֆA rp0 7AT|*;)<,RyHa"ՇA(@ bXH b" VE!)D bXH-bc"ՈE#1H,RX$1Mb"UEc%)L,R8ib"ŷHub"E X(_s()R bXLHbB EJ*1V,BX\Hb"EJYW"eA.\ bXvHbA/)`,RĄH c"VE1)d bXH-cc"ՌE31h,RX1Mc"UE5)l,RX1Hmc"ՍA7)p,R8ȉc"EA9s,RұHcZ ƎE;w bXc ǢrX1c"EJ>)~,RHc"AL @) Hd:"A*!kB b YQ!C1,RY$HMd"UE"E),RY42md"ՑA#k'd &Ej$I,R&YNH EJ%J) j"E%L,R2Y?Q&PM( R7YpHd E'TO1,R?YFe"5E(TQ1,RGY2%eR"E)Ǹ,BNY2Ae"%Ej*U,RVFae߬PZĶHqe EoHe"45,PY0,RgY2eR"E-X[!Qo9e69,RsHe vE /T^) b{YFe E 0T`1,RYo+|!3̢!C EJ1b) bYH=f"EJ2dqY*HYf̠.3f,BY:yf "E*4h,RYJ3f:"A,5j֨,RZHfz"A,6lٌaYQYns"EJ7n),RY|3f"1L8peuČHgB EH9kr!aYH=g EJ:t1,RYH]gEJ;/Ewyŝğ5 ?N܉K'ԥƝԸoqP-ԥƝƝtNƝ@'j)ԸSq'~;qĝ:ԸN)Ը׸SwЉ;qĝԸN܉K'ԥƝB;q'ĥwRN]j܉K'ĥw 5:qPNĝ2;_ŝ/};a}\N]jK;y)q.5ԥĝq'/=7ĝ:ԸnuN]jܩK;uN]jܩK;y鹿Q'$zߨw}oԉ;#hK:q'.uN}\NjC:q.5FSq'FSxN]jItߨw 5$zߨwGиSwRN^zx~Sw'ĝ:ԸSwcNܩK;n?_sN܉oĝDzsNIt۟w 57޸uN]jܩK;y豿P;a;y辿P'ԥƝԸwRN]jI4q'sNܩq'/=ĝB;nuN]jܩK;y?P;qĝ8Ը?P'ԥƝtwRN]jKjIOwnܩ3;>ĝB;78SwRNx~=g{NItwRN]jKq:q.5$Xw5yߦwpN]jI豿M'7޸ntN]jܩK;y?N'ԧ5ԥƝSwRN^S5Ɲ~_6jܩIN^/։;w}/։;uq.5d5ġwЉ;y;q;uq'/='ĝDuNz6$O։;uq.5dS׸SwcNܩK;yI|;>'ĝ?Y'ԥgsԉ;3u:q'w҉;y鹿N'$z_w:Swc}NܩC;y_.;q;uq'/=ĝnԸSq'dĝ4ԥƝ_ww}NܩK;uq'=[ҷKĝ=A^в9˝9˝_h[A^ ˝9˝Z;ys;yB^A^в9˝9˝Z;ys;/,wr /wr煖A^A^в9˝yes;qs;ж .wrg; r /wi3˝ .wqs; .wrg;9˝A\ rg;y3˝A\ .wq3H˝c .w^hY rgkGA\ .wqs;? .wrg;A^ rg;y3H˝1\ r /wq3˝ |~+@U\ r /wq3˝ .wqBrg;Arg;9˝A\ rg;y3˝A\ .wGkY .wqs; .wrg;A\rg;y3˝A\ e3˝A\ .wq3˝ .wrg;A^ rg;x3m .wrg;A^ rg;y3˝A\ r /wq3˝Z; .wrg ;9˝Ao,wqs; .wrg;9˝A\ rg;y3˝A\Θrg ;y3˝A\ .wq3˝Z; .w;A^ rg;9˝AZr .wp3辿Pr /wq3˝ -wps; .wrg;9˝A\ rg;/,wi3˝ .wqs;A\rg.wrg;9˝Ao,wqs; -wrg;9˝A\ rg;y3H˝1\;ciY r /wq3˝ .wqs; .wrg;9˝A\ rgc0W9˝A\ /ֲ9˝A\ r /wq3˝AZ̲ .wqs;A^ rg ;>' .wqs; .wrg;9˝AZrg;y3˝A\ r /wq3H˝crg;/,wq3˝ .wqs;1^ rgп]es;A^ rg ;9˝A\ rg;y3˝A\ .wq3˝ .w~m3o;[m;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;w1,RYHqg"ŝE;w!QY3qg"ŝA;&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) RY?Q;kw1,RY3qg"ŝE;9,RYHqg"ŝE;w),RY3qgŝA;kw),RĸHqg ƝE;w( bYHqg ƝE;w1,RYqǝE;kw1,RYHqg"ŝE;w(,zu;w),Rĸmw) bYFqgƝE;w1,RYHqg"ĝ5;1y&ǝE;w),Rĸmw) bYFqg ƝE;w1,RYqgǝ! ƝE;w) bYHqg"ŝE;wqYHqg ƝE;w1,BYqg "ŝE;w),RY3qg"ŝA;w(,RĸHqg"ŝA;w!aYQYs"ŝE;w),RY3Mqg"ĝ1;weuĸHqg ƝEo丳qg "ŝE;w1,RY3qg"ŝE;?-),IBZp'֕i eyY#Q|;kw)w*yx[A;/ĝwr9q'A;9BK9q ǝZA;9B;8BK9q Ɲ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);?;9 bĸ3q ǝA;wrĸ3qg,qg ƝA;9 bĸs ŝ1;wqĸ3q ǝA;ĝw1 b9qgƝA;9 bĸ3q ǝA;wqaĸBKĸ3q ǝA;w13qg1;we]A;w13Hqg ŝcw1 bĸs ƝA;9 bĸ3q Ɲ1;w~- U5|%~?=qg&/tN\:q.5ԥƝ_w 5ĝԸN܉K'j tNƝB;wGиNܩC;qĝB;q;uq'NܩK;qĝtN]j)ԸwN\:q.5ԥƝtN\:qPNw 5J)ӸK_NaX׸SwRN^JܩK;u)q'%ԡƝԸ(q'?.q.5ԥƝw 5$w 5$JܩAN^J)Ը达Q_N};uq'/%䥉;uq5ĝtNĝwRN]jܩK;w 5$z!oԗS?ƝԸwFS׸^uN]JC:q.5ԥƝD:q.5K?ŝhSq'hSq'h^.NIwRN]jK:q5hSwRNhSw=GĝB;Gĝ4ԥƝtwRN:q'/}VNjC:q.5ĝ?Z'ǝwRN]jIߨw 5$zߨwGиSwFS׸uNjK:q.5ԥƝD:q.5ԥƝߨw7ĝDuNwsN܉K'FSSwsNܩK;y龿Q'jIQ'7޸Sw7ĝB;nuNwRN]jKooOwPNDSwRN^zOԉ;uq'#zOԉ;񍟸ߞ/}Oԉ;uNƝwcNܩK;u)q'=q>q'=ĝԸSwRN]jܩK;&yԉ;}7@Sq'}NܩK;uq'/=q'w<ĝԸuN]jܩK;y?P;in4qƝ:Ӹ}N)ԸSxN^Ӊ;uq.%ǷCĝDq:q.5ԥƝwRNq:q'PN6?wRNĝDm:qƝtߦwRN]JCq:q>q.58Swcw4o[ܙ\!l)Ը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ĝ?\?9ǶA^ rg;ye3˝A\ r /wq3˝ .wqs;cA^ rg;c9˝A\ r /wq3˝A\ .wq3˝ .wrg; -˝EZ,rg;Y"-wq˝5Z rg;Y .wiH˝EZ rg;"-wiH˝A\,rg;Y"-wa3˝EZ,r /wiH"-wqH˝EZ rg۟^EZ,rg;Y΢rg;",whH˝A\,rg;Yt( uP"-wi3˝EZ,rg;yH˝EZ,rg;Y.wiH˝EZ rg;"-wiH˝A\,rg;Yt-/wi3˝EZ,rg;Y"-wqH˝EZ,r /wiH˝A\,rgc"-wi3˝EZ,rg;Y",wpH˝EZ,rg;Y΢rg;"-wiH˝A\,rg;yH˝EZ,rg;kY .wo;"-wiH˝A\,rg;Y"-wi3˝EZ,rg;kn-wqH˝EZ rgmYA^,rg;"-wi3˝EZ,rg;Y-wiF˝EZ,rg;Y .wi˝5Z rg;Y .wiH˝A\,rg;>˝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ŋ?9q8y։c'^mcX&^avc%QI(q 1LǰH10Gk1E".0D2ǰBq 8Aq ˸?p1/p 1,0<1Ǩ:1&cX~%8p s˸6p [1L /p C1 /p +1h.eaa8eQ^8uŅq[8ic^]fcX^Q6c{aP8=&sps -= \rRpA 9+rX8eᅖpAƅ\^y^h) 91p# - g^h 4p[ - ׆rox%8p - GXqv0aAN1> b}8a\ 1A bq+ fA"r1- LjA#G 1EbAn%J R8]b Z AoA'1PB1MF1 WA)1TR1b[AT+<7j9X bdqŠFmb8b .] bzBK~1c AN0)b1c; \21e b81ck A9h bĤq FA5rİ1echmaĺq A X8^hI81r1c; \:1u b8ȱck A9x bq FA=r1cAn?~1c @ by b2! 1L!Br QKr AL"Dr*2Y wA #F1 b9ydmHưD2d#A$I b(y b*V2cZ2d{A&XL1 b39dfM0 b9tr ƓA'9 b?2 'Al(Q2eCA.)R RLy RNÞr AL*TrTĪ2Y v1 +~ͺV1 b]9ye8-e AN,X0 Re9ƙe; \Z1 bkrk 1-/2涿MKrr VA. bx2 A/cX_12f AN0`1 R9a+br3-fcA1c 3Ef 5Y VA2>'k 3Xf163Hqf cg1 b9ȉf FA49 bPsK 1l5kr\3fA.6lh3h?l3慖p3fAn7o b9f cp ˺Tq b9%gRA9Ǹ bĞ3A AL:trĪ3YgA ;cXv1D[t? kKv:qgorЉ;qĝԸSw~K)ԸwRN\:q'.Sq'Љ;w 5j܉AN:q5ĥw 55ԡƝ8tN\:q.5ĥw҉;uqPN|܉;qĝԸS>w҉;qĝB;N)ԸS(qL_/};a}\N]jK;y)q.5ԥĝq.5d>Y'$XWNdSwmNI?Y'ԥƝܟwRN{~ĝSwRNFSq'FS?ƝԸި/7ĝƝ\ߨwPN^oԉ;uq.5$zoԉ;uq.5F趿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%$J)ԸSxN^oӉ;uq.%8SָSwkNܩK8c}NI?oĝĝݸS?Ɲ_w 5$z_wRN]jKj܉C'ġwswwRN^zO։;nuNz5$O։;uq.5ĝDuN]jK:q.%'C?['%$zߟwdS^K:q'~汿N'7}N\:q'/ĝDu:q'/}Ӊ;uq'/=ĝ:ԸﲞS׸SwsNܩK;y辿N;ew}McNܩ@N]jKu:q>q'/=ĝSws}ĝ_wp釸nq ǝ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;wA;9 bĸsΠ7O Ɲw1 bĸs ƝA;9 Rø3q ǝA;wrtߨ% sqg Ɲw1 bĸBKĸ3qgA;w)3qg Ɲw1 b9qg ƝA;9 bĸs ƝA;wrĸ3qgA;cw13qgCCE -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 b9qgmw03qgA;w1 by% bĸ3q ǝA;wrĸ3qgA;w0ĸ3qg Ɲw1 b9qg ŝ1;9 bĸ3q ǝA;wrĸ3?P;/ĝA;cwrĸ3qgA;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؟,ǝ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;cw1D[t,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'/%jI? %jIS?ƝSq'}}ĝwRN^JKwPNjK;qĝD;q'ĝԸSw%jI6Ct_ߨ/q~;uq'/%䥏:q>q'/7ĝuN]jܩK;uN]jK:qP[F?:qPN:q'/=Z?\:q'.?Z'ԥƝԸ^uNjK:q.5ԥƝD:q.5$z։;w։;#xhuN]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_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ܩKwcNܩK;ĝ@;intNNܩK;w=ĝw}NܩK;u)q'=ĝƝԸ^tN]jKqj)Ӹ~;e;uq~&;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'ԥĝq'/7ĝuN]jܩK;^uN]jK:qPNFOq|?Z'Ϥq'/=Z?\:q'.?Z'ԥƝԸuNjK:q.5ԥƝD:q.5$z։;wGĝ4ԥƝwRNh>Gq5hS>wRN^wNK;uq.5$z:qPNFS?ƝԸި/7ĝƝZߨwPN^zoԉ;uq.5$zoԉ;uq.5F趿Q'$ߨwGи^uN\:q'/=7ĝĝ:Ը^uN]jK:qPNFSxN]jIߨw 5$oԉ;#hܩK;uq'/Q?]JܩC;uNjܩK;y?Q'ԥD?Q'7~N^z}{~?Q'$zOԉ;woK:q.5ԥĝ<_ƝƝ<_wRN]jK;uq.5$?P'ݸ^uNƝD:q.5ԥsJN^\wPN@SwsNܩK;uq'/q'm&7ݸSgwĝB;78SwRNz~{~돗uNsN܉oĝtN^zӉ;ntN^_wRN^zӉ;uq'/e=q>q.5:Swcw4$?ĝDtN]jKu:q>q'/=ĝSwk}ĝ_wp釸.wr>9˝9˝ж9˝9˝Z;ys;/,wr /wr煼9˝yes;qs;/,wr /w^hYA^ -˝9˝yes;yBr /wr/wArg;9˝A\ rg;y3H˝1\ .wq3˝ .wqs;A^ i-˝A\ .wqs; -wrg;ye3˝Aqs;A^ B .wqs; .wrg;9˝AZrg;y3˝A\ΠF-˝A\ .wO.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˝ .wrgF-˝A\ .wq3˝ .wrg;A^ rg;q3?Q^r /wq3?Qrg; -˝A\ rg;y3˝A\ .wq3˝.wrg ;A^ rg;y3˝AZr /wq3˝A\ .wqs;n,wi2rg;c9˝A\ rg;y3˝A\.wA^ rg;y3c .wrg;c1^ rg;y3˝A\ r /wi3˝rgm .wrg;^۴,wq3˝A\ -wp3˝ .wrg;1?;?^ .wq3˝ .wrg;,˝A\ rg;y3˝A\Πd-˝AZ .wqs; .wrg;9˝AZrg;y3˝A\ r /wq3H˝crg;/,wq3˝ .wqs;1^ rgп]es;_e3H˝1\ r/wq3˝A\ .wqs; .wrg ;m˝AǝE;w),RYs"ŝE;w1,RY3qg"ŝE;w(,RĸHqgŝA;w) bYHqg ƝE;w) bYHqg"ŝE;kwry΃w)<qA;BYcw)<qA;BY ĝ!<qg΃wHqA;By"ŝ!<qg΃wŝ!<qg΃w?HqA;BY ĝ!,Ry΃wHqA;BYcwHqA;BYF1<qg΃w([By΃w1<qA;BY ĝw(<qA;BY ĝ!,Ry΃wHqA;BY ĝ!<qg΃w ĝE;Ay"ŝ!<qA;w ĝE;By΃w)<qA;w ĝ!,Ry΃~;kw ĝ!,Ry΃wHqA;BY ĝ!<qg΃w3qA;By"ĝ <qg΃>7qA;w ĝ!,Ry΃w)<qA;BY ĝ!,BymwHqA;zO΃w ĝA;By΃w)<qA;w ĝ!,Ryq1;w ĝ!,Ry΃w)<qAǝ ,Ry΃wHqA;BY ĝ!<3qAǝ ,Ry΃wHqA;BYĝuG ,Ry΃w)axc=a8e=Q8eX<a8掗q8q8C9^ƙVc9ax'cX8axc7a8Fqc6axc5a8Ue5a8IeX4a8'20fÖ2N|2axgcsDc0^ c0^cX/axc.a8\r[_%[j2ǰYd2.0X^q s˸VXq[1L/Rq C1/Lq +1ǨQDqpg΁e'a8uƉq8iq8]fcT%!K8M&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"A ?NOK'(ԥԤK_B{?KUK qttB@'-j[(ԸPu!~ q:Na(PЩ qdNhK4ԥBm q'6ĥSRsC]joK'8ĥS 59:͡PCT2 |%<$ʟhqMu!/%>ԇPPDjKM !R+D]jKy)!PKD(-PcDԈ4GB %I7&Q%RD^,Q%PD^JK'M$J;q"/Nԥ扺>(P EF}#hKy)"/}o)qMy齿Q'VԥԊ<ߨ+RE]jHߨ,RE^zo-7ꔋBM.>GċGK'_ĥ/GԄQ0{}NŨCy?Z'dԥԔ?Z'fԥ֌D:=PFhQ?6ԨuF]jHtS6hmԡƍ<7RF^JKuG|iy).rԥfD:PKGFQ?Ǝڑި/7ZߨK'&yI(}@R%cNHK-)u)%/=1%SҼԢuJ]jTK*y?P*in4e馕:Ӷ?Nj^o}%/=RXϿdDq:.ԥ[RkK8%mNri.u%QK6RxK^zoI/u.%8RR`{NKm0y?N0ea/-W6jISL^z/։1Zc SZdcdЉ2qTt2uLd:s}3u M]jKm4y?Y5ԥvڟSjRRMz|{~2A OHqC2A^ dw$8$9KA d$yM2sAܓA .JiR2ZF%*YY JiXH˒E d%k.y"Ki`H A,dF&2ę"Lih2KE,d&6Y"MqpHE,d G':YAޝ,dFE d'>ɢ~WuiH A,eF(B"Pi2KEe(FY9"Qq趿Q,&eG)JYYʠKٯ0e)4M9۔E:e)OY",TpHE,Jeg*SY .UiH[E Ze*^"-ViHA,jef+[-Wi2ەE,ze+yHEZ [Eڰ,҈eV,8cY" YqɲHSEڲ,Ҙe,4gY=ZiѲHEڴ eV-4kY] [iٲHӖAܶ,Ҹe-4o}" \ir'.qY"\iF;E eFyHcA\,o.4x"M^i2EZ,ev/8|Y"M_i?Q\e/4Y N`iH#EZ"`iHKA,f0Y9"ai3EĬ&fF1kYY"bqH˘E/kYq"ch3E,Bf&2Y"dq&H;E,ROea+FcAk-HsE,`f34Y fh5ل fq8H˙E vf8y=HA,40 "hiE33E,Ґf48Y-ifmYA .jiRHA,Ҫff5a",khZHۚA,Һf5Y"-lab3ol+ę"lihHKA,fkY"maps74Y"nquHE f7k4Yoi}HA,g84 "pi33Eg88Y-"qi3sE, g 93,( riHAO94Ym si1,@gѿ]VOtqH#EZ Lgv:k4YNuiHcEZ \g:4"MviHAZlgv;/ wrtSk9q煖sA;9sA;9wr9q煖sA;91;9wr9qǝZA;9wr9q ǝZA;9BK9q ǝZA;1 ƝA;͸3qg Ɲw)a9qg ƝA;9 bĸ3q ǝA;wrĸ3qgA;w13qg ŝcw1 by% b?13qgA;>w>A;wrĸ3qgA;w13Hqg Ɲw1 b9qgm3q ǝA;wBrTw1w1 bĸs ƝA;8 bĸ3q ǝA;wrĸ3qgA;w13qg ƝwGk;wbø3q ǝA;w1w1 b9oƝ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;ĝA;9 bĸs ƝA;wr3q Ɲ1;w13qgA;w)a9qg ƝA;9 bĸs ƝA;w^f;w07 ƝA;wrĸ3q Ɲ1;~Ɲw1 b9qg8-qgA;w0 R9qg Ɲw1 bĸs ŝ1;/3涿MKĸs ƝA;9 bĸ3q ǝAw.r Ɲw1 b9qg ƝAƝu(>Bǝw1 bĸs ƝA;9 bĸ3Hqe3|&qgA;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?ŝw^h;9s?h;9s -q ǝw^h;9s 9s -q ǝwqy%s -q ǝwry%i۾%BK9q ǝZA;1 ƝA;9 bĸ3q ǝA;cwrĸ3qgA;w1 b9qg Ɲw1 bĸs ƝA;9 bĸ3HqǝA;w^h;wA;9 bĸsΠO Ɲw1 bĸs ƝA;9 Rø3q ǝA;wrtߨ% b9qg Ɲw3_Ÿ3q煖3qg Ɲw1 R9qg ƝA;9 bĸs ƝA;wrĸ3q ǝA;w13?ZKĸsƝA;9 bĸ3q煖3qgA;w1 b9qg Ɲw1 bĸs ƝA;8 bĸ3q ǝA;w13qgA;w1 b9qgΠF-qg ƝA;1aĸsΠZ Ɲw1 bĸs ƝA;9 bĸ3q ǝA;wbs۟(ǝ1;9 bĸs ƝA;w^h;ĝA;9 bĸs ƝA;wr3q Ɲ1;w13qgA;w)a9qg ƝA;9 bĸs ƝA;w^f;w03qg Ɲw1 zƝAr]A;w13c3q ǝA;cw)3qgA;w1 b9qgƝrsߦ% b9qg Ɲw1 bĸs ŝ1;wrĸ3q ǝA;wsqgA;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_ q.ƝA_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)qPNa(qPNĝ4ĝB;%7޸SwRN^SwPN^zEK'$J܉;q'/%ԥƝԸ(qPN;F};#hܩK;y)q'/}oԉ;q;y齿Q'ԥĝ<ߨwRN]jIߨwRN^zoԉ;w7ĝB;>~}~;U:q'~'ĥwGĝԸSw{}NܩC;y?Z'ԥƝԸ?Z'ԥƝD:qPNhS?ƝԸuN]jItwh5ԡƝ<wRN^JKuN|܉;y)q.5ԥƝD:qGtߨwGиSwFS׸^uNjK:q.5ԥƝD:q.5ԥƝߨw7ĝDuNwkN܉K'FSSwkNܩK;y鱿Q'jItߨwoܩK;uNƝD:q~;uq.5׷7K;uq's}NܩC;uq'/'ĝԸ'ĝOKoOԏ>'ĝD:q?ĝܟwRN]JCjܩkC:q.5ԥƝSwRN;iuN}ߍ;y?P'jIwRN]jKj܉C'ġƝ4:q.5@S>wRN^zTN>Mܩoq4$Ӊ;woKq:q.5ԥĝ<8x;q'cNܩK;uq'/=ĝԸ>N'jIsߦwpN]jI赿M'7޸tN]jܩK;y?N'ԧ5ԥƝwRN^zS5ĝƝ\!l)ԸS?Ɲ_w 5$/։;uq.5d5ġwЉ;y;q;uq'/'ĝD:q'dw='ĝԸSwsNܩkܩK;y?Y'ԥĝY-wqH˝EZ,rg;Y"-wqH˝EZ rg;Y .wiH˝A\,rg;"-w"-wvT .wiH˝A\,W;"-wiH˝A\,rg;Y-wi3˝EZ,rg;n"-wqH˝EZ rgZWiH˝Y"-wi3˝EZ,rg??˝EZ,rg;Y .wiH˝EZ rg;"-wiH˝A\,rg;-wi3˝EZ,rg;yH˝EZ rg;YΠ-wiH˝A\,rg;΢Fq3˝EZ,rg;Y"-wi3˝EZ,rg;Y"-wqH˝Erg;Y -whH˝A\,(/wi3˝EZ,rg;Y"-wqH˝EZ,rg;Y -w'˝5Z rg;"-wiH˝Y"-wi3˝EZ,rg?g"-wi3˝EXrg;kY"-wqH˝EZ rg;Y .w˝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"-w|!;"-wiH˝A\,rg;Y"-was;Y"-wqH˝EZ rg;kY.wiH˝A\,rg;"-wi3˝EXrg;Ytߟ,/wi3˝EZ,rg ;3Z,r /wiH˝A\,rg;"-wa3˝EZ, .wiH˝A\,rg;"-wiH˝A\,rg;Y"-wi3H˝5Z,r煖΢?5BK9q ǝwA[9q ǝw^h;9BK9q ǝw^qǝw^h;9ĸs -q ǝw^h;9s -q ǝwry%s -q ǝwqmqg Ɲw1 bĸs ŝ1;9 bĸ3q ǝAwr Ɲw1 b9qg ƝA;9 bĸs ƝA;wqĸ3q煖3qg@ĸs ƝA;9 1 b9qg ƝA;9 bĸs ŝ1;wrĸ3q ǝAZ Ɲw1 b9qgq{Sby% bĸ3q ǝA;wqĸ3qgA;w13qg Ɲw1 b9qg ƝA;9 bĸ3q Ɲ1;wrĸ3qg -qg Ɲw1 bĸs ƝA;9 bĸ3q ǝAr9qg ƝA;9 bĸ3q ǝA;wrĸ3qgA;w1w1 bĸsƝA;9 ߨ% b9qg ƝA;9 bĸs ƝA;wrĸ3:}ΘD9a9qg Ɲw1 bĸBKĸ3qgA;w13qg Ɲw)a9qg ƝA;9 bĸs ƝA;cwrt% b9qg Ɲw1 b2K3q ǝA;w13qgA;cwu;9 bĸsΠqZ Ɲw)as ƝA;9 bĸ3q ǝA;c^3涿MKĸs ƝA;9 bĸ3q ǝA;cw13qgA;wwn+->qCs Ɲ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 ƝA;wrĸ3赾NKĸ3_.wrĸ3q ǝA;cw)3qg Ɲw1 b9qg ƝA;1aZ_- 'ĝ?5i^tЉ;qĝԸSw~K)ԸwRN\:q'.Sq'Љ;w 5j܉AN:q}Sq'>q5ġw҉;uq'.NܩK;wN܉K'ԥƝԸN܉K'j tNƝB;eww~KIkƝԸwRN]jܩK;y(q5ԥƝD;q;uq.5ĝSq'Q0LSq'QNwRNƝDwoܩK;y)q'/MܩC;uq'/%ĥw%ǝwRN]jISq'c}ĝ4ԥƝ>7ĝƝߨwRNzoԉ;uq.5$zoԉ;uq'/=7ĝB;uNƝDuCٯz{~8}N|'$z։;uq.5hSwsNܩK;uq'kNܩK;uNƝD:q~;uq'/=GĝԸ?Z'jܩC;y?Z'ԥƝ>GĝwRN]jܩK;uNƝDV'ԏq.57K:q>q'/7ĝ:ԸuN]jܩK;uN]jܩK;y齿Q'$oԉ;>7ĝ4FNK:q>.q5FSwcN)t#oԉ;7ԥƝD:qPNFS?ƝԸSwӥĝ:Ը>Q'ԡƝԸ^uN]jIDuN|'׷'KuNDSqƝܟwRN]JCjܩkC:q.5ԥƝSwRN;iuN}ߍ;y?P'jIwRN]jKj܉C'ġƝ4:q.5@SwRN^zTN>Mܩoq4$Ӊ;woKq:q.5ԥĝ<8x;q'cNܩK;uq'/=ĝԸ>N'jIsߦwpN]jI赿M'7޸tN]?N;y?N'ԧ5ԥƝwRN^z8w+?ĝD?;wgҸuNƝD:q.5ԥƝ؟Ɲ8tN:q'/18q>q.5d>Y'$\wNdSwRN^zO։;q;uq'/'ĝߞ:/q'}NKuN]z}/ĝD:;qĝ_wĝN'ԥƝZ_wPN^zN}\N]jKu:q.%:5iI7YDu:q~;uq'/ĝƝ_wRNjCuw~Kå?,wqs; .w^hY rg;9˝A\ r /wq3˝A\.w5%/wq3H˝1\ .wqs; .wrg;A^ rg;y3˝AZr煖"-wi3˝EZ,rg;Y-wqH˝EZ,rg;Y"-wqH˝EZ rg;Y .wiH˝A\,rg;"-wis;YQ;Y"-wq^EZ,rgM˝EZ,rg;Y"-wq˝5Z,rg;Y(/w7˝EZ rg;"-w~;yH˝EZ,rg;Y.wiH˝EZ rg;"-wiH˝A\,rg;Y"-wi3˝EZ,rg;Y"-wqH˝EZ,r /wiH˝A\,rg;"-wi3˝EZ,rg;Y",wpH˝EZ,rg;Y"-wqH˝EZ rg;Y .wiH˝Y"-wi3H˝5Z,rg;>7˝EZ iH˝EZ,rg;Y .wiH˝EZ rg;^w%i?Q\rg;Y .wiH˝EZ"-wiH˝A\,rg;Y"-wi3˝EXrg;kY"-wqH˝EZ rg;Y .wiH˝EZ rg;"-wi˝cY-wqH˝EZ,rg;Y -wh -wq?N^ rg8yH˝A\,rg;"-wi3˝EZ,rg;Y-wrgmY .wiH˝A\,rg;trg;kY .wiH˝A\,}n3_.wr3˝EZ,rg;Y"-wqH˝EZ,r/wiH˝EZ rg;",wh˝1\,rg;Y"-wi3˝EZ,rg;Y"-wqH˝EZ,rg;Y.wgYA^,rg;Y"-wi3˝EZ,rg ;Y/~˝A\,ﯓ;Y-wa3˝EZ,rg;Y"-wqH˝EZ,rg;kY -˝E'aA;/ĝwr9qŝwr9q煖sA;/ĝwr9qwq9q煖sA;8wr9q煖sA;9wr9q ǝZA;9wr9qǝw1 b9qg ƝA;9 Røs ƝA;wrĸ3qgA;w13qg Ɲw1 b9qg ƝA;8 bĸBKĸ3 b9qg]LA;>w>A;wrĸ3qgA;w13Hqg Ɲw1 b9qgm3q ǝA;wrĸ3ŝ*ƝZ ƝA;wrĸ3HqǝA;w13qgA;w1 b9qg Ɲw1 bĸs ƝA;wbø3q ǝA;w1w1 z)3qg Ɲw1 b9qg ƝA;9 bs ƝA;wrĸ3qgA;w13qg Ɲw1 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)a9qg ƝA;9 bĸs ƝA;w^f;wƼj;w1 b9qg Ɲw0 "wrt%3c3q ǝA;cw)3qgA;w1 b9qgƝrsߦ% b9qg Ɲw1 bĸs ŝ1;wrĸ3q ǝA=W2 R9qgA;w1 b9qg Ɲw1 b2Kĸ3qgA;w13Hqg ŝcw1 zOw1 bĸs ƝA;9 Rø3q ǝA;w13qg1;3;w^h;w13qg Ɲw1 R9qgΠK9qg Ɲw)as ƝA;wrĸ3q ǝA;w1ĸ3qg?h;n%Z1L;/s 1:0cs 1l:0鼌1 :ǰ缌s190Ö2L9Ð280s#˸Äs 8~s 17/xs 1L7ǰܼ160ۼ16ǨdY1|g1׌QX3F1(5CjaL3Ff"1l4chƨЌQ9}fՙcgƨ͌Q2s u12ǰʌQ&3I1 2cc^9fj6F-1*1cba󁿝Qs %1*0c`a2FƗ1h/C^ƨ2Fe1.cn2F1 .c[an2닜ZƨQhr 3U1,Qb2F1+cTWa\2Fie1 +cU(ê2FQe%cXT(QOrjŔ1j)0QI2FeQƨy!PÆ2F e cO(Q=9d1*'NƨA69d51J&ǰQ0^2F֒1%cJa*R2Fd:1$cTI(%1*$cHQ<2FuƑ142Fe1"cEƨ(2FMd1,"cDƨQ95dbcBG!d:1 cTA(2F d q1Fc1lc>ƨ|1FcUc=Ơy Q8Fc1ǰvQq S1C9a1Fc1LcT8(pþ1Fycčq1>9c5(kQ8Qc%cT4(h3fQq SƘqq 3T!c0a1F1cT/(^v1b0\ Uc-ƨYQ8b1ǰVAV1F1 c)a+|"4C(l1P>1Fybʼnc&(MQ8abe1/(1FMbc$ƨGQ85b b1HDQq 3U1c a1F1CT(>0Fac(;Au8azDa88Qop kņ1j cai0f1 ctc80Fa1 c.A\8ma1 ǰ+QVp 51J cTQP0F9Ԅ1&|S}<9a[ qԢP~KS(ԨRRB\:]!.Pe!I  5.j]AB:}50ĥS 51ǵ1ԡF8t*C\:.3ĥ) uP[C|܉ qԆP qBMNs(P(աL_/} 'Z}\C]j{Ky).5?ԥ<QZ RD4Dtϟnu"/C䥄B-G\BR#G# 5H$zoԗ$QxD]jKyiDjC y)e".4(m">ĉ:Q'RDB->os%Rԏ.5StQT5UFXQR+sNK u"kNKy鹿Q'[jHtߨS. 5]$ߨ/u.T/^_uE>"kNKMu #/GT:ԌuBF]jɨKM^ubF]jH3 5h$I#hӨKy?Z'kԥvD:e#/}VFjC:y.o?Z'qǝƑ9R+G]jH: t$i#hKy{N𨏻7ɣyԡFߨ=RG]jHߨ>RG]jK:#mNIQ'ԏ $/7Tt2H^zo !q)!u)$7ĐuzHD:I6(豿Q'jItߨSFG4RFRH^z}{~.58/W+ou"L:&aCL6bS5&}NK 2uE&/='M&(NKo NkK-3y?Y$O֩3>'>?Yԥ&Fu*M}\3M]jK:.%Ƿ'C￶NKItߟkSlx齾N'$r#q@r$/LHsCrG$/H H䅖%A-Aв&9s'yePr%qRr7%mT2A] KqY2Ӓ-qKd%80ąAw1đ Ldw&849KA d&ym2sAܛ .Nqr2Hc<: N^hٝ dFA Oq}r'>¿+A\ nPq2+Awgq93ә?Nzf3y?3H1\ ҄ohqD3+< iqIs41 yM3涿M˞f5yQ3AQ jqV3<eNkq[s5o|G7~_1 Z! lqg3CA\͠b-cĹ mip2f'7A^ fw7yx3H˛1 oq}3󛃼 .pqs788A g 89SA g8y3{AEΠ 798ye3AuZ9i ns8g949A ˺LtFgG:93APg:x3[A Z uq3 nvqsW;c8?h ǟh;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),z bYHqgƝE;wrYH .RĸHqg ƝE;"ŝE;w),RY3qg"ŝA;w(,RĸHqg ƝErY3qg"ŝA;w),=,RCگRYHqg"ŝE;cw),RY3qg"ŝA;w),RPYHqg"ŝE;w1,RYHqgŝE;w),RYs"ŝE;w),RY3qg"ŝA;w),RĸHqgƝE;w) bYHqg ƝE;帳Hqg"ŝA;w)丳Hqg"ŝA;kw) bYQ;w1,RYHqg"ŝE;w),RY3qg"ŝA;knŸFqg"ŝE;w),RYs"ŝE;w1,RY3qg"ŝE;w!QFqg"ŝAŝE;w1,RYFqg"ŝE;w1,RY3qg"ŝE;8,BY3qg"ŝE;w),RFqgѯ\W3qg"ŝA;>qg ƝE;kw!aYHqg"ŝE;w1,BYsΚ69,RĸHqg ƝE;w) bYFqg ƝE;sܙdYHqgƝE?;w),RY3qg"ŝA;w),B9qg"ŝE;w),Rĸqg"ĝ1;w) bYHqgΠ"ŝE;w!QY3qg"ŝE;w),Bøh?Hq ǝE;w1,RYHqg"ŝE;cw),3qg"ŝA;w(,BøHqg"ŝA;w) bYHqg ŝ5;w^h;n)5i4qON܉K'ԥƝԸK_NƝܗSw҉;qĝB;N)ԸSqPNwЉ;uq'.Sq'>q5ġGN\:q.5ĥw҉;uqPN|܉;qĝԸSw҉;qĝB;N)ԸS(qL_/};^׸SwRN^JܩK;u)q'%ԡƝԸ(q'?.q.5ԥƝw 5$w 5$JܩAN^J)Ը豾Q_N};uq'/%䥉;uq5ĝtNĝwRN]jܩK;w 5$!zoԗS?ƝԸwFS׸uN]JC:q.5ԥƝD:q.5FSq'}N)ԸcnKooN~;U:q'?sNܩK;y>Z'ԡƝwRN]jIwRNhSh?Z'ԥƝwRNh>Gq5hSwRN^wNK;uq.5$z։;wGĝ4ԥƝFx齿Q'5FSwcNܩK;uq'sNܩK;uq'/7ĝD:q'FS?Ɲߨw҉;y鹿Q'%ԡƝ<ߨwRN^zoԉ;w7ĝwRNFSq'mNܩAN]jܩK;yRNjI\wPN]jK:q.5$z|{~D:q'w:q'cN)ԸSxN^zOԉ;uq.%B5ԇ5BS/ԉ;y)q.5ԥƝDwҼĝwkN)Ը?P'ԥƝԸոN܉C;i^uN]jK:q.5ԥƝƝ4}StNiItw 57޸tN]jܩK;yq_vN8SwRN^zӉ;uq'}}N Ը涿M'ĝԸ(q'kNܩoq'/=ĝԸSwsNܩOkܩK;ofX'7ڸոSq'aNƝ~N^z/։;wĝԸSwcwЉ;qĝĝƝԸuNds}ލ;uN]jܩK;y?Y'5ԥs߂wRN]JCoO֏mėyĝN'ԥg{}NIyӉ;MNKu:q'mNKtN]jKu:q5'5ԥƝ_wRNzSNƝDG_wиSw{NܩkKu:q.%ԡƝ7ƝN~;U:q'?sNܩK;y>Z'ԡƝwRN]jIwRNhSq'}NܩAN]jK:q.5$։;yswPNz։;uq'/%:q'>ĝSwRNhSq'}NܩAN]jKooԏuN}\N^zoԉ;uq'/=7ĝ{NIߨwRN]jK:q'mNRvoq^Kn{D3 ߱Z!GHOe0Ħ''ߨw[иuN\:q'/7ĝĝ:ԸuN]jK:qPN:qƝԸ趿Q'jIQ'Էq.5ԥƝFv)q5$Oԉ;uq.5DSw~ĝ@;iĝSw%$zoӉ;76SwRNӉ;i;yE_y_w mܩK;y龿X;eww 5oq'/ĝB;>ĝԸSwmwЉ;qĝĝƝԸuN:q'd=w'ĝԸSw}NܩkܩK;y?Y'ԥĝwry%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ĝwow13qgA;w1 by% oqg~ Ɲw1 R9qg ƝA;9 bĸs ƝA;wrĸ3q ǝA;w13qg Ɲw0 b9qg ƝA;/ĝA;wrĸ3qgA;w13qg Ɲw1 R9qg ƝAZ Ɲ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;ĝA;w)w)a9qg ƝA;9 bĸsƝA.q ǝA;wr?NKĸs ŝ1;wqĸ3q ǝA;w13Hqg 9yߦ% b9qg Ɲw1 bĸs ŝ1Wf~%<9 bĸs ƝA;wq!t9qg ƝA;9 bĸs ƝA;w^f;w1 b9qgΠd-qgƝ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ĝYcv|/swN؉;:qY;ߪNF/?[Ӊ;M:_9E;'iڜ5'LcNM9_9%'4|}t08_V+Nii8_9 '|}~wo´|Y'|}紛twZnswN l9&LM4 M6_ֿ/| 6e[|VsMi;5u'&4ĝ:PgiN3MTDFwhN MI >S&y$i)62am{ue[eNLI;dLLi;1_99LjןubLI;M1q%LBLv2o32aw`N L\__Ⳛ_s}uN|;i/u澾:ĝR汾:ĝFs__\´X_[4y[_[ǫ;'|}甖4E:%>%ԝ gX}}N`;+qyc}N\;m+e3tJ23tJ[UNJݹI*q ՞Rw>g5%4ԙ wZRNBJ\QSQN"JiC;M(e3tJ23tIONIݹxu~\_NMc{uN53&u綾:'ĝ`R澾:'ĝ֒XRwsRI9LVX_HsIݹ $Y#qy4|QwsGi;iu汾9-I u澾9'wĝ֎Qw:NSGi(3s}rN/<'40MensGi߈;u>9_9m3MEsFiר;9U#4jĝ6X"3=#8ҚQc}nNӔ_sKFݹq#bԙ3$29#_ĝ拺s_/NE9kpQ}}mNw~Ei(fQ汾6X`QwnksrEi;yE_w_ߠ*[*NCEyoq7"HE\E}7Oԝ8m2w&NDݹPgNiu Qw#tjD:-=["Gt wZ!}}Nj;-u>B?ĝ:svgoޜPw>tsyn͉e#9Pw{sjC9|) q!0ԝޜwm}o-ޜvӬPw{sB|VBݹ) q'A!δ'ԙ| _r痘e)2Kĥ .Eq)BRd"ĥA^ Rd"y)2KA\ R .Ep)2Kĥ -Ep)r"ĥA^ Rd"9 .Eq)2Kĥ .ERd"å -KEZ,Rd"Y"-Eq)K5Z Rd"Y .Ei)HKEZ Rd"sq)HKEZ,Rd"Y .Ei)HKEXRd"9KEZ,]HKA\,Rd"Y@HKEZ Rd"Y .Ei)HKA\,Rd"ĥ"-Ei)2KE"-Eq)HKEZ Rd"YA^,OKUZ,Rd"Y.Ei)HKEZ Rdmĥ"-Ei)HKA\,Rd"Y"-Ei)2补"-Ei)HKAZRd"Y"-Ei)r"Y .Ei)HKEZ Rd"ĥ"-Ei)HKA\,Rd"cY"-E=7KEZ,Rd"Y"-Eq)HKEZ,Rd"YA^,Rd"-Ei)2KEo"-Eq)HKEZ,Rd"Y .Ei)HKEZ Rd"ȚRd"Y"-Eq)HKEZ,R /Ei)HKEZ Rd"ĥ"-Ei)HKA\,Rd"Y"-Ei)2KEZ,Rd"Y-E=Y"-Ei)2KEZ,z"Y",ERd"kĥ"-Ei)HKA\,Rd"YȢ -Eq)HKEZ Rd8y)HKA\,Rd"å"-Ei)2KEZ,Rd"Y-ERd6y)HKA\,Rd"Y"-Ei)2KJGּĥ"-Ei)2KEZ,Rd"cY!Rd"Y"-Eq)HKEZ Rd"Y1^,Rd"ĥ"-Ei)2KEXRd"cY"-Eq)HKEZ,Rd"Y .Ea)FKEZ zgRd"ĥ"-Ea)2KE-Ei)r"Y .Ei)HKEZ Rd"å"-EeRd"Y .Ea)FKEXRd"Y .Ei)HKA\,Rd"-Ei)BRdZv^iY8켌8lUeu^Met~輌˸2Kyלqy_)E\r^!Y:8 +΋82Ky'qe27/|27o^en^Y˸ۼ/Tqy6qي17O15/\s k15ǰռS1*50Լ;14ǰH2n40Bs ˸a8e>a8Vq8F&a8c;^ƵƎc:^Ʃc:axgcX9a8e8a8e7a8uō_di(m²2ǰkìq 8jæq ˰h q'20fÖ2NǼ2axgcT1a8F E0a8e/a8Ƌq8F_Y1/hq 1L/bq 1<_tHQ8q8vq8Fc(^ĉϜ˸O b~XFb "%Ej!B,RXH!bK"Ej#F,RX1Ab"%Al%J,B.HabAN&/E'O,RB SFHb+"eE*T,RXV1bjE,X,Rf}\-)[ bXpHb"EiA/Jc"5EcX1)c,RX1%cR"AT3)g,RĠHEc 6ET5)k bXHec 5T71o,RXH 'Ej9r,RXαHcK"Ej;v,RX1c"$1l=z,RHc"Al?~ bXHd &Ej ArY HdB 5J!B1,z(ErY"HId FE"E,RY2Hid"őE#GּOAO%Ej$I,R&YNH EJ%J) b-Y\Hd"EJ&L1,B5Yl2Hd"EJ'N),R=|HdAL(P),REČHeB EJ)R!㚲9ez E**T bTYHYeE/Bie"ŕE+W폓"AL,X(,Be̲HeB EJ-Z) bmYܲF 5He"UE.]/_1^,B|YHe"E*0`,RY 3f!fK"Ej1c]/1,R HEf"4ce,RY.3af"Al3g֨,B>Hf &Ej4i bYNHfK"5j5k,RY^Hf"%Eh6cmgmpHf E7To) bYg "5EgY]q1,RY3%gRE9cXs),RY3Eg"5A:Tu),RFeg -mg;]Ӄw/B'ĥwRN]jҷSqwRN\:q'.Sq'Љ;w 5j܉oAN:q5ĥw 55ԡƝ8tN\:q.5ĥw҉;uqPN|܉;qĝԸSw҉;qĝB;N)ԸS(qL߁oqKNeX׸SwRN^JܩK;u)q'%ԡƝԸ(q'?.q.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.5FSF豿Q'$zߨw˥w҉;/ߨ:q~';y>Z'ԡƝtwRN]jIwRNhSq'hS߂ƝԸnuN]jI?Z'jܩChSwRN^JKuN|܉;y)q.5ԥƝD:qPN:q;uq'/ĝB;78SwRNx~=g{NItwRN]jKq:q.5$Xw5yߦwpN]jI豿M'̯|wҸSwRN/։;i;uq'/=ĝԸոSq'qPNwRNĝB;>ĝԸSwmwЉ;qĝĝƝԸuN:q'd=w'ĝԸSw}NܩkܩK;y鱿N'ԥĝms;/,wr /wrږ;ys;yBr /wr煖A^A^;xs;/,wr .wr煖A^ -˝9˝yes;ys;/,wr /w^hYA\/-wq3˝ .wqs;A^ rg;9˝A\ rg;y3˝A\ .wq3˝ .wrg;1^ rg;/,wq3 .wrg;9˝Ao rg;y3˝A\ r /w7jY -wp3˝ .wrgF-˝A\rg;9˝A\ rg;/,wq3-wWqs;1^ rg;9˝A\ r /wq3˝A\ .wqs;Π+ .wqs;cA^ rg;ye3˝A\ .wq3˝ .wrg;A^ rg;x3˝A\ r /wq3˝A\ΠF-˝ .wqs; -˝A\ rg;q3˝A\ΠZ;9˝A\ rg;y3˝A\ .wq3˝ .wrgDy3˝\ rg;y3˝A\ zOԲ .wqs;A^ rg;9˝AZr .wp3˝A\ .wqs;.wrg;A^ rg;y3˝A\ reΠ@-˝ .wqs;A\rg.wrg;9˝Ao,wqs; -wrgmA^ rg;9˝AZr煼Mrg;y3˝A;_u+=zrg;y3H˝1\ r /wq3˝ .wis;?^ .wq3˝ .wrg;,˝A\ rg;y3˝A\ -wp3H˝c .wrg;A^ rg;y3H˝1\ r /wq3˝A\ .wis;3\ r煖Π۟#ؖ;y3˝A\ r /wq3H˝cΠr /wq3˝.wis; .wrg;9˝A\ rg;q3˝A\BrgY% b9qg ƝA;/ĝA;w13qgA;w1 b9qg Ɲw1 Røs ƝA;9 bĸ3詸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;wo"ŝA;w) bYHqgA;w;-/h~"ŝE;cw),RY3qg"ŝA;w),RĸHqg ƝE;w=bYHqg ŝ5;w}*,RYHq ǝE;w1,RYHqg"ŝE;w),RY3qg"ĝ1;w),RĸHqg"ŝA;w) bYHqg ƝE;wrYHqg ŝ5;w1,z(ǝE;w),RY3qg"ŝA;w),RĸHqg ŝ5ŸFqg"ŝE;w),RYܟ(ǝE;w) bYHqg"ŝE;w1,BY3Hqg"ŝE;w),RĸHqgŝA;w),RĸHqgΠOŝE;w!㸳qg ƝE;w) bYHqgŝE/Bqg"ŝE;w폓"ŝA;w(,BøHqg ƝE;w) bYFq Ɲ5丳HqgIfϢA;w),Rĸqg"ŝA;w) bYHqgƝE7Ɲ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;S; jۼw҉;uq.5|}[)Ը};uq'.N)ԸĝB;w 5ķq'Sw҉;wwPN:q'.Sw҉;qĝԸSq'>ĝtN]jܩK;qĝtNƝ@;w %i;-|}[I\N]jK;y)q.5ԥĝ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<ĝwcN)Ը?P'ԥϿĝtƝ8tNjIwRN^ԉ;uq.5@5yߧ;E7ԙƝDtNƝwmNܩK;u)q'D;uN?;y?X'ԥƝuN}ZN]jK:q.5b5iIyk)ԸSƝt_w 5$_wRN]jKj܉C'ġwcwwRN^zO։;'ĝDlIt{d}C?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׫ŝw^h;9s/ŝwr9q煖sЍq ǝ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 -qg ƝA-_3覟JR9qg ƝA;9 bĸs ƝA;wrĸ3q ǝA;w13qg Ɲw0 b9qg ƝA;/ĝA;wrĸ3qgA;w13qgΠ% bs ƝA;wrĸ3qgA;w13qg Ɲw1 by% bĸ3q Ɲ1;wrQKĸs ƝA;wrtߨ%3qg Ɲw1 b9qgD9a9qg Ɲw1 bĸBKĸ3qgA;w13qg Ɲw)a9qg ƝA;9 bĸs ƝA;cĝA;w13qgA;w1 Ry% Røs ƝA;wrĸ3q Ɲ1;^p]A;w13m3q ǝA;cw)3qgA;w1 b9qgƝrmzmW.>!Ɲw1 b9qg ƝA;9 Rø3q ǝA;wrĸ3qg1;?o;9 bĸ3q ǝA;wrĸ3qgs}3qg Ɲw1 b9qgƝA;8 bĸs ƝA;wrĸ3q ǝA;cw=N]rĸ3qgA;w)3h?ø3q煖3qgA;w1 b9qg ŝcw1 ?˺ĝw1 b9qgƝA;8 bĸ3q ǝA;wrĸ3qgA;cw1B[η+r?GAjQТ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;wRN]jK;y)qPNe(qPNĝ4ĝB;n-޸SwRN^SwPN^J܉K'$J܉;q'/%ԥƝԸ(qPN7F};-hܩK;y)q'/}oԉ;q;y鹿Q'ԥĝ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'/%$wĝԸSw}wЉ;qq'cNܩK;y?P'ԥƝԸո}&ݸSgw}Ӊ;w oKq:q.5ԥĝN''l$J܉ʉ;uq'QN`S_xN^։;uq.%bSָSwsNܩK;y龿X;eww 5oq'/ĝB;>ĝԸSwmwЉ;qĝĝƝԸuN:q':=w%7ϳvq.5:S׸SwcNܩK;yuI|;>ĝN'ԥϟgs}NIӉ;ENKu:q':>ĝԸtNjKgYOܩkܩK;y鱿N'ԥĝS&yi)62am{ue[eNLI;?-2qA|}21_։1u'-&4ĝ2 1aaʼͿܶW[{Li;)0us}uNj~;9%ԙw^NKw]}}uNr Rc}uNo Rm}uNl;?SZg5%4ԙ wZRNBJ\QSQN"JiC;M(e3tJ23tIONIݹx~\NMc{uN53&u綾:'ĝ`R澾:'ĝ֒XRwsRI9LVX_HsIݹ $Y#qy4|QwsGi;iu汾9-I u澾9'wĝ֎Qw:NSGi(3s}rN/<'40MensGi߈;u>9_9m3MEsFiר;9U#4jĝ6X"3=#8ҚQc}nNӔ_sKFݹq#bԙ3$29#_ĝ'_x_ߠS4l(A\|m.O_O;e,<',m}N;q'7褊PQwt2Ei; jDQf@}"~u羾A'Ni(ALĝ.Qwn#*%>sDy?E">A"GԝޜQ}{oN(7ϖ29"4CĝVs_ߛ Ⳛ N Dyq'~7yY~[{(7<ԝ9!<ow{sC}}oNq=;7ԝޜP}}oNk;{sJCih;9!δ2ԝg4Ocjb;- u籾7/ĝ:s[ߛƅ m e~o澾7',]!4+ԝޜզPw{sBIP3 u汽7o&|yĄKL?/KA\ .Eq)2KZ"ĥ .ERd"9KA\ Rd"q)2KA\ .Ei)2Kĥ .ERd"ĥA^ Rd"9KA\ R /Eq)2HK1\вY"-Eq)HKEZ,Rd"Y .Ei)HKEZ Rd"Y .E/ĥ"-Ei)HKA\,Rd"Y"-Ea)2KEZ,R /Ei)Hu"-Eq)HKEZ Rd۟"-Ei)2KEZ,Rd"Y"-Eq)K5Z,Rd"Y .Eo""-Ei)2KEZ,Rd"y)HKEZ,Rd[Rd"cY"-Ei)2KEZ,Rd"Y"-Eq)HKEZ Rd"Y .Ei)HKEZ Rdmĥ"-Ei)HKY"-Eq)HKEZ,Rd"Y .Ei)HKEZ Rd"å"-Ei)HKA\,Rd"ĥ"-Ei)2KEZ,Rd"Y"-ERd"Y -Eh)HKA\,z(/Ei)2KEZ,Rd"Y"-Eq)HKEZ,Rd"Y -EּO"k5 Rd"ĥ"-Ei)HKY"-Ei)2/-Ei)HKA\,Rd"ĥ",Eh)2HK5Z,Rd"Y"-Eq)HKEXRd"Y"-Eq)?P^ Rd"Y1^,Rd"Y"-Ei)2KEZ,Rd"kY_ .Ei)HKA\,z'/Ei)2KEXRd"cYȢK/JGi>HE |7-ERd`y)?X^,Rd"Y"-Ei)2KEXRd"Y"-Eq)HKEZ,Rd "?o\ Rd"Y .Ei)HKA\,Rd"9KEZ,Rd"Rd"ĥ",Eh)K1\,Rd"Y"-Ei)2KEZ,Rd"Y"-Eq)HKEZ,Rd"Y.EgYA^,Rd"Y"-Ei)2KEZ,Rd "Y/~KA\,Rd"Y-Ea)2KEZ,Rd"Y"-Eq)HKEZ,Rd"kY y),Eo5[9q煖sA;9B[9q ǝw^/ǝ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 bĸs ƝA;wrĸ3q ǝA;cw13qgA;7j;wrĸ3q ǝA;w1Л ƝA;wu n9+@wqĸ3qgA;w13qg Ɲ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 b9/Ɲ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ø3e_3g ǝA;w13Hqg 9y% b9qg Ɲw1 bĸs ŝ1;wrĸ3q ǝA;w)3hs Ɲ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 ƝA;wrĸ3HqǝA;ϲ.q ǝA;wr3qg1;w1 b9qg Ɲw1 bĸsƝA;wƝw^h;9tc9qA;9BK9q ǝ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 ǝAo7Fmq ǝA;w13qgA;w0 b9qg Ɲwow13qgA;w1 by7ǝA;w13ŝU;8 bĸ3q ǝA;wrĸ3qgh-qg Ɲ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 Ɲw1 b9qg ƝA;9 RøsƝA;wrĸ3q ǝA;w03qg Ɲw1 b9qg ƝA;/ĝA;cwrĸ3qgA;w1ĸ3qg`9qg Ɲww1Uo_3g<8 bĸs ƝA;wr3qwƼw13qgA;w1 b9qgƝA;9 bĸs ƝA;wqys9qg ƝAg9 bĸs ƝA;w^f;w1 b9qg Ɲw)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_{yKq:qg/rЉ;qĝԸSw-jŝԸN܉K'j tNƝB;w[иNܩC;qĝB;q;u3q'NܩK;qĝtN]j)ԸwN\:q.5ԥƝtN\:qPNw 5J)Ӹw[ҷ(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'7Ko;qĝD:q.5ԥƝK_\wklK:q.5ԥƝD:q.5$։;w}։;-hܩK;y?Z'ԥƝDuN^Ɲ:ԸuN]jK;ysN܉;q'/%ԥƝԸ?Z'jI?Z'Էq.5GK:q>q'/=7ĝ:ԸnuN]jܩK;uN]jܩK;y鹿Q'$zߨw}oԉ;-hK:q'.uN}\NjC:q.WmN)ԸcNܩ/q.5$oԉ;woԉ;-hܩK;uq'/=~Q]JܩC;uNjܩK;y?Q'ԥƝDOԯ?Q'~N^zx~?Q'$Oԉ;w oK:q.5ԥĝ<_ƝƝq.5:Sw短w}Ӊ;ysNܩKϟ?:h?s_w>q'.tNu:q'/}Ӊ;uq'/=ĝ:ԸϲS׸SwcNܩK;y趿N;ewI_}Nܩo@N]jKu:q>q'/ĝSwc}ŝ/};y鷸m[ r /wq3˝A\в .wqs;A^ rg;9˝1\ r /wq3H˝1Z .wqs; .wrg;A^ rg;y3˝AZr煖"-wi3˝EZ,rg;Y-wqH˝EZ,rg;Y"-wqH˝EZ rg;Y .wiH˝A\,rg;"-wis;YQ;Y"-wqW;"-wiH˝A\,rg;Y-wi3˝EZ,rg;7˝EZ rg;"-wiH˝޸Y"-wi3˝Ei ˝1\,rg;"-wi3˝EZ,rghyH˝EZ rg;n .wiH˝EZ rg;"-wiH˝Y"-wqH˝EZ,rg;Y .wiH˝EZ rg;"-wiH˝A\,rg;"-wi3˝EZ,rg;Y"-wrg;Y -whH˝A\,z(/wi3˝EZ,rg;Y"-wqH˝EZ,rg;Y -wּO;k"-wi3˝EZ,?_A^,rg;"-wi3˝EZ,rg;Y-wiF˝EZ,rg;Y .wi˝5Z rg;Y .wiH˝A\,rg;9˝EXrg;Y"-wqH˝EZ rg;^.'Th3˝E;_Ֆ gbyγHsAY",wpH˝EZ rg;Y .waF˝Y?X^,rg;Y .wiH˝EZ rg;kY .wiH˝A\,rg;΢;Y"-wi3˝EZ,rg;Yt_'.wrg;Y .wiH˝A\,rg;"-wi3˝EZ,rg;Y"-wq˝5Z,rg;Y"-wqH˝EXrg~F˝EZ"-wi3˝EZ,rg;޴Y",wpH˝EgY"-wi3˝EXrg;cY"-wi3˝EZ,rg;Y"-wiF˝EZвY; >׸s -q ǝwrsA;9wr9q煖sA;91;9wr9qǝZA;9wr9q ǝZA;9BK9q ǝZA;1 mqg Ɲw1 bĸs ŝ1;9 bĸ3q ǝA;w13qgA;w1 b9qg Ɲw1 bs ƝA;/ĝA; Ɲw1 b9qgЛ'qgA;w1 b9qg Ɲw)aĸs ƝA;9 zߨ% b9qg Ɲw1 bĸBKĸ3qgA;^ǝ˖t~ ƝA;wrĸ3q ǝA;w13qgA;wGk;9 bĸ3q Ɲ1;wrĸ3qg -qg Ɲw1 b?ZKĸ3q ǝA;w13qg1;w1 b9qg ƝA;9 bĸs ƝA;wrĸ3q煖3qg Ɲw0 b9qgF-qgA;w1 b9qg Ɲw1 bĸs ƝA;1yߟ(ǝ1;9 bĸs ƝA7W -qg ƝA;9 bĸs ƝA;wr3q Ɲ1;w}/w1 b9qg ŝ1;9 bĸ3q ǝA;wrĸ3qg,qgƝw1 bĸ(F$I;Ac-%Y i,jng6? ǝA;wbø3/}-e,> \|@;9 _% b9qgƝA;8 bĸs ƝA;wr3q 9w13qgA;w1 b9qgƝA;9 bĸs ƝA;wqs ƝA;wrĸ3q ǝA;w)|% bĸ3q ǝA;wr3qg1;w13qgΠ:-qg Ɲw)aĸs ƝA;wrĸ3HqǝAƝA;_h;w13qg Ɲw1 R9qgΠK9qg Ɲw)as ƝA;wrĸ3q ǝA;w1ĸ3qg?h;.%~ƝFAwtN\:q.5ԥƝ/;w~q.5ĥw҉;wSqPNƝ4ġwPN\:qPN|\Nj܉C'ĥwRN\:q'.Sw 5ǝNܩK;uq'.N)ԸĝB;w4w~#$\N]jK;y9ߥK;u)q'%ԡƝԸ(q'?.q.5ԥƝw 5$w 5$JܩAN^J)Ը躾Q?N};uq'/%䥉;uq5ĝtNĝwRN]jܩK;w 5$!oԏS?ƝԸwsNܩkK:q.%FSwRNFSwmN)Ը{N)ԸkNK_oԛK'ĥw7ĝԸSw&5ƝwRN]$ԥƝD:q.5$։;w}։;#hܩK;y?Z'ԥƝDuN^zVNjC:q.5ĝwNK;uq.5$։;w}։;#hܩK;yz{?Z'5wPN^oԉ;uq.5$oԉ;uq.5F貿Q'$zoԉ;#hK:q'.nuN}\NjC:q.5FSq'FSxN]jItߨw 5$oԉ;#hܩK;uq'/Q.%ԡƝD:q5ԥƝtߟwRN'-zOԉ;񍟸uNDSqƝt۟wkw}wwmNܩK;uq'/%ԥƝԸhN@SwN^ԉ;w]ĝԸSwmwЉ;qq'}NܩK;y?P'ԥƝԸ/})jIs)>q4$_w 57޸uN]jܩK;yz{躿X'ԥƝԸnuN]jIX'jIswpN]jI?X'7޸uN]jܩK;y趿X'ԧ5ԥƝ_wRN^SNƝD?o;w?~N^Ӊ;w}Ӊ;uq.5:5ġwЉ;y;q;uq'/=ĝDu:q's}_wp.5ԥƝt_wwRN^Ӊ;u)q']No=:q':tN]z}ַtNmN܉oĝtN^zӉ;.tN^zӉ;uq'/ĝ:ԸﲞS׸Sw}NܩK;y躿N;ewMַ趿N'q.5:S׸ntN]JܩC;y达N?ϗ~ĝ{]y'aY;9˝A\ rg;_hY rg;9˝A\ r /wq3˝A\trg ;9˝A\ rg ;y3˝A\ .wq3˝ .wqs;A^ rg;cBrg;"-wiy;Y .wiH˝EZ rg;Y .wiH˝A\,rg;"-wi3˝EZ,rg;cY"-wrg;o;*rg;Y .w}_U"-wqH˝EZ,rg;Y .waF˝EZ rg;΢FyH˝A\,rg;Y"-wis;Y"-wqH˝Ee3_"-wiH˝A-wiH˝A\,rg;"-wi3˝EZ,rg;Y"-wi3H˝5Z,rg;Y"-wrg;"-wi?Z^,rg;Y"-wi3˝EZ,rg ;Y"-wqH˝EZ,rg;Y .wiH˝EZ rg;9˝EZ,rg;Y"-wqkY .wiH˝EZ rg;"-wiH˝A\,rg;Ysٟ(.wh3˝EZ,rg;Y"-wrg;Y .wiH˝A\,rg;trg;k-wi蹿P^,rg;Y΢;Y"-wi3˝EZ,rg;Y",wrg;k΢˝B|<49"yi3Hs5,8P .wiH˝A\,_,/wi3˝EXrg;cY"-wqH˝EZ,rg;YA\;"-wi3˝EZ,rg;Y-wi3˝EZ,rg;Y",wph˝A\,rg;"-wi3˝EZ,rg;xH˝EZ,rg;Y .waF˝EXhH˝EZ rg;Y .wiH˝A\,rghEZ rg;Y .wi˝1\,hH˝Y"-wqH˝EZ,rg;Y.wi_.;Y"-wq˝5Z,rg ;Y"-wqH˝EZ rg;Y -whH˝/,w]r)ok9q -q ǝwrmq ǝwrBK9q ǝ/ĝwr9q 9sZA;1󅖸sA;_h;9sZA;9󅖸sA;_h;9ĸs?h;w13qg Ɲw)a9qgΠ™ Ɲw1 bĸs ƝA;9 bĸ3q ǝA;wrĸ3qg1;w1|% b?13qgA;w>A;wrĸ3qgA;w13Hqg Ɲw1 b9qge3q ǝA;wrĸ3qgZ ƝA;wrĸ3?ŝE;w1 zI1qg Ɲw1 bĸs ƝA;9 bĸ3q ǝA;w1ĸ3qgA;w1 bBKĸ3q ǝA;w13qgA;w1 b9qg ŝcw1 bĸs ƝA;wrĸ3q ǝA;w13qgZ ƝA;wbø3q ǝA_ĝA;9 bĸ3q ǝA;wrĸ3qgs3qgA;c.3q ǝA;wrĸ3qgZ ƝA;wrĸ3q ǝA;w13Hqg A;cw1 b9qg Ɲw1 ׽bwrĸ3qgA;w13qg ŝ/SITsϠĸ3q ǝA;wbø3oE03qgA;k;wr3qg1;w13qgΠb-qgƝ/3?XKĸs ƝA;9 bĸ3q ǝA;cw13qgA;w1 R9qgϛA;w1 b9qg Ɲw1 be3qg Ɲw1 b9qgƝA;8 bĸs ƝA;wrĸ3q ǝA;cw13qg Ɲw1 R9qg~qgZ ƝA;9 bĸ3q ǝA;wqĸ3_.wrĸ3q ǝA;cw)3qg Ɲw1 b9qg ƝAurø3qŝAw~%3q ǝA;w1|% bĸ3q ǝA;wrĸ3qgSq Ɲ1;wrĸ3Hqg A;w13qg Ɲw1 bĸs ƝA;9 b3q -qg"ŝA;w),Rĸqg ƝE;w) bYHqg ƝE;w1,RYHqg"ŝE;w),RY3qg"ŝw),w1,RY3qgΧHqg ƝE;w) bYHqg"ĝ5;w1,RY3qgew) bYHqg"ŝE;wrYHqg ƝE;>ƝǠ|Sw),zIĸHqg ƝE;w) bYHqg"ŝE;w1,RYHqgŝE;w),RYs"ŝE;w),RY3qg"ŝA;w),RĸHqgƝE_帳Hqg"ŝE;w1,RY3qg"ŝE;w),R9qg"ŝE;w(,Rĸkw) bYHqgΠoŝE;w1,RY蹿Q;w) RYsٟ(Ɲ5;w),RĸHqg"ŝw),RY3qg"ŝA;w),Rĸqg ŝ5;w) bYHqg"ŝE;kw1,RYHqg"ŝEdg"E(>xγqg ƝE;w) bYHqgŝEBqg"ŝE;w}/"ŝA;w(,BøHqg ƝE;w) bYFq Ɲ5rY3qg"ŝA;w),Rĸqg"ŝAߊ;w) bYHqgƝE?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)|%,{;9|%sA;-sA;_h;9󅖸sA;9|!ǝcwrBK9q Ɲcwwr9q -q ǝwrBK9q ǝwwr9q -q ǝwqmqg Ɲw1 bĸs ŝ1;9 bĸ3q ǝA;w13qgA;w1 b9qg Ɲw1 bs ƝA;_h;wA;9 bĸsΠ/O Ɲw1 bĸs7 ƝA;9 Rø3q ǝA;wrtߨ% b9qg Ɲw1 bĸ󅖸3qg Ɲw1 R9?Ɲ*ƝA;wrĸ3q ǝA;w13qgA;w1 b9qg ƝA;1aĸs ƝA;ww1 b9qg ƝA;9 bĸs ƝA;wrĸ3HqǝA_ĝA;9 bĸ3q ǝA;wrĸ3qgA;w1|% btߨ%ĸ3qgA;7j;wrĸ3qgAߌ;w13qg Ɲw1 b9qgew03qgA;w1 bBKĸ3qgA;w13qg Ɲw)a9qg ƝA;9 bĸs ƝA;cwrĸ3s)W3g<w1 be3Hqg A;w1 b9qg Ɲw0 w;9 bĸsΠZ Ɲw)as ƝA;9 bĸ3q ǝA;cwΘ`-qgA;w13qg Ɲw)aĸs ƝA;9 bĸ3HqǝA?o;9 bĸ3q ǝA;wrĸ3qgΗY ƝA;wrĸ3q ǝA;cw)3qgA;w1 b9qg Ɲw)aĸs ƝA;wrĸ3HqǝAƝA;_h;w13qg Ɲw1 R9qgΠK9qg Ɲw)as ƝA;wrĸ3q ǝA;w1ĸ3qg?h;.)|ߙq.A;7B'ĥwRN]jҏSqwRN\:q'.Sq'Љ;w 5j܉AN:q5ĥw 5ߴvq'NܩK;qĝtN]j)ԸwN\:q.5ԥƝtN\:qPNw 5J)ӸOGҏ(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ĝߨwwcNܩK;y趿Q'ԥƝԸ辿Q'ԥƝtߨw 5$ߨw 5$ߨw҉;qq'}NܩK;uq'/=7ĝ{]ܙ։;=6ԥƝԸ?Z'ԥƝD:qPN:q~;uq'/]GĝԸ{NKjܩC;y?Z'ԥƝuN|܉;y)q.5ԥƝD:qPN:q~;uq'/~=Zo/=GĝƝt_wPN^oԉ;uq.5$oԉ;uq.5F貿Q'$zoԉ;#hK:q'.nuN}\NjC:q.5FSq'FSxN]jItߨw 5$oԉ;#hܩK;uq'/Q.%ԡƝD:q5ԥƝtߟwRN'-zOԉ;񍟸uNDSqƝt۟wRN]JCjܩkC:q.5ԥƝSwRηW6WN:ŧôjSq'uNܩK;uq'/Wq'wWĝԸnuN]jܩK;y龿Z;i.5qƝ:Ӹ{N)ԸSxN^/։;uq.%ۯ_۫vNbSwRN^JK:q'8q'eN܉;uq'QN6SxN^oӉ;uq.%8SָSwcNܩK;y?N;ew5jܩ;y?N'jI?N'ԥƝԸԸN܉C'7'5ԥƝ_w]ĝDuz4$Ӊ;uq.5:S׸Sw}NܩK;yuz{I;ĝ_wﳾX_wgntN|'ĥwcNIt_wsNܩK;y龾N'ԡƝ/~ĝƝԸtN]JCuj)ӸoEu:q~;uq'/=ĝƝt_wRNjCuw~#Ko{[ r /wq3˝A\|e3˝A\ r /wq3˝ .wqs;cA^ rg 31\ .wqs; .wrg;A^ rg;y3˝AZyj"-wi3˝EZ,rg;Y-wqH˝EZ,rg;Y"-wqH˝EZ rg;Y .wiH˝A\,rg;"-wis;YQ;Y"-wqB"-wi3˝EZ,rg;Y"-wq˝5Z,rg;Y .w]7˝EZ rg;"-wiH˝Y"-wi3˝EZ,rg ;Co ~;"-wi3˝EZ,rg;Y"-wqH˝EZ,rg;Y"-wiF˝EZ rg;YA^,rg;Y"-wi3˝EZ,rg;Y"-wqH˝EXrg;Y .wiH˝EZ rg;"-wiH˝A\,rg;yH˝Erg;kY .w}o;"-wiH˝A\,rg;Y"-wi3˝EZ,rg;k.-wqH˝EZ rg;YA^,rg;"-wi3˝EZ,rgsY-wiF˝E;?JyqγHsE g<0Y9 yiγ .wiH˝A\,rg;9˝EXrg;Y"-wqH˝EZ rg;>)Th3˝EZ,rg;˝EZ rg;kY.wiH˝A\,rg;",whs;k."-wqH˝EZ rg;Y .waF˝EZ rg;"-wi>N^,Zyrg;Y"-wqH˝EZ rg;Y1^,rg;"-wi3˝EXrg;cY"-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˝/,w]rA;_h;9s?h;9sZA;9|%sA;_qǝwwr9qǝ/ĝwrBK9q ǝwwr9q ǝ/ĝwrBK9q ƝcwA[ĸ3q ǝA;w13Hqg A;w1 b9qg ƝA;]w1 b9qg ƝA;9 bĸs ƝA;wqĸ3q -qg 8q ǝA;wr bĸs ƝA;wrĸ3q ǝA;cw13qgA;.ĝA;9 bĸs ƝA;ww1 bĸs ƝA;8 oqgqgA;w13qgms ƝA;9 bĸ3q ǝA;w1ĸ3qgA;w1 bBKĸ3q ǝA;w13qgA;w1 b9qg ŝcw1 bĸs ƝA;wrĸ3q ǝA;w13qgZ ƝA;wbø3q ǝA_ĝA;9 bĸ3q ǝA;wrĸ3qgA;w1ĸ3?Q;cwrĸ3q ǝA;w1|% bĸ3q ǝA;wrĸ3qgA;?UJ1,>at۟%3qgA;w)a9qg ƝA;9 bĸs Ɲ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)3hq ǝA;nĝ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;- /Ɲwwr9q ǝwr9q ǝ/ĝwrBK9q ǝw1;9|%s1;_h;9󅖸sA;9|%sA;_h;9󅖸sA;83qgA;w;A;9 Røs ƝA;wrĸ3qgA;w13qg Ɲw1 b9qg ƝA;8 bĸ󅖸3qg@ĸs ƝA;9 1 b9qg ƝA;9 bĸs ŝ1;wrĸ3q ǝAZ Ɲw1 b9qg ƝA;_h;w1 b9qg ŝcw3_Ÿ3q ǝA;wrĸ3?ZK9qg Ɲw1 bĸs ƝA;wbø3q ǝA;w1|% bĸs ƝA;wrĸ3q ǝA;w13qg1;w1 b9qg ƝAZ ƝA;9 bĸ3q ǝA;ww1 bĸsƝA;9 ߨ% b9qg ƝA;9 bĸs ƝA;wrĸ3q Ɲ1røs ƝA;9 bĸ3q -qg ƝA;9 w~,> b3 y)a9qg Πl-q ǝA;wrĸ3Hqg A;w1 b9qg Ɲw1 b\_% Røs ƝA;wrĸ3q Ɲ1;>]A;w13k3q ǝA;cw)3qgA;w1 b9qgƝ/3沿MKĸs ƝA;9 bĸ3q ǝA;cw13qgA;w1 R9qgϛA;w1 b9qg Ɲw1 be3qg Ɲw1 b9qgƝA;8 bĸs ƝA;wrĸ3q ǝA;cw13qg Ɲw1 R9qg~qgs3qgA;w1 b9qg ŝcw1 ˺ĝw1 b9qgƝA;8 bĸ3q ǝA;wrĸ3qgA;cw13_?-ϸOtPΠw҉;uq.5|G)Ը;uq'.N)ԸĝB;w 5ďq'Sw҉;wwPN:q'.Sw҉;qĝԸSq'>ĝtN]jܩK;qĝtNƝ@'j)Sqq'Q0kܩK;y)q'/%ԥƝwPN]jISwRN^JK;wD;w%ԏq'/%jIt]ߨqƝԸwĝ:ԸSwRN\:q'QN|܉;y)q.5ԥƝD;w}]7GܩAN]jK;y鹿Q'5FSwmNܩK;uq'}NܩK;y鶿Q'jIQ'jIQ'ǯ7ͥw҉;uN]jܩK;y鱾Q'ԡƝ{Mٯ։;M6ԥƝD:q.5$։;w}։;#hܩKhSw}։;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$ߨwoܩK;uNƝD:q~FSwRNjIt[wPN]jK:q.5$zޢ'C8_yO9'S|sNIt߭w 57޸nuN]jܩK;y?[;a;y?['ԥƝԸwRN]]gq'cNܩq'/WĝB;uN]jܩK;y鶿Z;qĝ8Ը澿Z'ԥƝt_wRN]jKV;i.4qƝ:Ӹ{N)ԸSxN^Ӊ;uq.%ۯ_vN8SwRN^Ӊ;uq'8q'eN܉;uq'QN6SxN^oӉ;uq.%8SָSwcNܩK;y?N;ew5jܩ;y?N'jI?N'ԥƝԸԸN܉C'7'5ԥƝ_w]ĝDuz4$Ӊ;uq.5:S׸Sw}NܩK:mď{NKu:q.=~>Ku:q'~涿N'7}N\:q'/%ԥƝDu:q'/=ĝԸtNjKwYOܩkܩK;y龿N'ԥĝ Y .wiH˝Erg;",whH˝A\,rg;Yt(/wi3˝EZ,rg;Y"-wrg;Y .wi˝1\,}|W櫴"-wi3˝EZ,rg;Y"-wq?Z^,rg;Y"-wiF˝EZ rg;YA^,rg;Y΢hy3˝EZ,rg;Y"-wqH˝EXrg;Y .wiH˝Erg;"-wiH˝A\,rg;yH˝EZ,rg;kY .w}o;"-wiH˝A\,rg;Y"-wi3˝EZ,rg;k.Κ˝JyiγHsA,<49sE,Ҝg<8Yyrg;Y"-wq˝5Z rg;Y .wiH˝A\,rg;k"-wiH˝A\,rg;Y"-w=W˝EXrg;Yt(/wqH˝EZ rg;>)Th3˝EZ,rg;˝EZ rg;kY.wiH˝A\,rg;",whs;k."-wqH˝EZ rg;Y .waF˝EZ rg;"-wi˝1\,Zyrg;Y"-wqH˝EZ rghEZ,r/wiH˝EZ rg;",wh˝1\,rg;Y΢:y3˝EZ,rg;Y"-wqH˝EZ,rg;Y.wgYA^,rg;Y"-wi3˝EZ,rg ;Y/~˝A\,rg;Y-wa3˝EZ,rg;Y"-wqH˝EZ,rg;kYZ;.iq ǝ/ĝwr9qŝwr9q -q ǝwwr9q ǝ/sA;_h;9ĸsZA;9|%sA;_h;9sZA;9|%s1;- bĸs ƝA;wr3q ǝA;w13qg Ɲw1 b9qg ƝA;9 bĸs ƝA;wqĸ3q -qg 8q ǝA;wr bĸs ƝA;wrĸ3q ǝA;cw13qgA;.ĝA;9 bĸs ƝA;ww1 bĸs ƝA;8 b|A;w13qg Ɲw1 b9qg ƝA;9 bĸ3q Ɲ1;wrĸ3qgZ ƝA;9 bt%3qgA;w1 b9qg ŝcw1 bĸs ƝA;wrĸ3q ǝA;w13qgZ ƝA;wbø3q ǝA_ĝA;9 bĸ3蹿QKĸ3q ǝA;w1SdsϘn\|3qgA;w1 bBKĸ3qgA;w13qg Ɲw)a9qg ƝA;9 bĸs ƝA;cwrĸ3qgA;w13qg ŝ/ĝA;cwrĸ3?PK9qg Ɲw0 w;9 bĸsΠqZ Ɲw)a/(qĸ3q ǝA;w13Hqg rsߦ% b9qg Ɲw1 bĸs ŝ1;ĝA;wrĸ3qg1;wrĸ3qgA;w13qg ŝ/ĝA;w13qgA;w0 R9qg Ɲw1 bĸs ƝA;9 Rø3q ǝA;w13qg1;3;ww1 b9qg ƝA;9 bs ƝAwYs ƝA;9 Rø3HqǝA;w=i;w13qg Ɲw0 bmqgĝ?ȏ(hPwN܉K'ԥƝԸqP#ԥgN\:q'.Sq'Љ;w 5j܉AN:q5ĥw 55ԡƝ8tN\:q.5ĥw҉;uqPN|܉;qĝԸSw҉;qĝB;N)ԸS(qL?qK?N_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ĝߨwwcNܩK;y趿Q'ԥƝԸ辿Q'ԥƝtߨw 5$ߨw 5$ߨw҉;qĝD:q.5ԥƝXߨwPN^}|ĝĝ:ݸSdNhSwGĝB;Gĝ4ԥƝtwRN:q'/=Gq5hSwRN^z։;q'ĝԸSwGĝB;Gĝ4ԥƝthww}}NܩC;yĝԸSw7ĝԸSwcNItߨw=7ĝ4FNK:q>.q5FSwuN)Ը{Nܩoq.5|?.+:ŧPOpS?SwRNwwPN]jK:q.5$zޢn;yz{鹿['$։;woK:q.5ԥĝ91ڞd'px2F1Nhs2/ Nho2Fsc6mMd &C44!dF&pc2F1ZKh^2Fc8.mMKhYr %c+YJd6%c0)91IhNe&1mId$c4$1ъd F$pC2F1hz@r #c41vd#c9Ñ1ڍldV#p42F1 FscmE1Td?-E>an5 /rQ8I5rU8Y -] \Вr[8Ƹpr^8} /bc8Ƒ - gri8ȩ /Ć\rn8Ƚ - rt8g1< by8a ƇA9? Rq &Al!r 1bCA."E15bs $H b8Mb VAǸK b241mb:q A P Q b8ȕb3 vA T bVqc Պ1ZzAX,1Yf1貿QKlq A,9] bx1 -b A,9a bq+ fA;s.vrĔ1- njA3g1EcAn5j b8]c ALmaĺq A X8В8q b8ȕc3 vA t bqc ֎A;r1H7AX=1{1c >1~ b8c A, 9 bTA~l#G<2}dA.$k!Cr"2IdA"XE1.2adm4r ƑA#1H b$9ȕd3 vA %_h)%J b,9ȵds L b2fr U1&a8r2 A'XOr>~2He AN(P1 zԒQ bH9%eS A)_f)Sư2Ee 6U bV9]e ʠϿnr ƕA+9 % ba9ȉeFA,8 bgrK Al-[rm2 9oӒ\2eA.^ bz9e֗A/ bs 6A0TaqsK Al1cr3= A,2d|% b,3] A,3fr83uf13hD3f# Vi b9ȥfRA5 b^3蹿NKd3HGAfA6_h 7Xn1v3f 曃o1 R9 gΠK9g; \r)ask A9trĤ3M GA:uİ3eg?hk;.%3q ǝA;w1|% bĸ3q ǝA;wrĸ3qgA;cw13qgƝw1 b9qg ƝA;9 bĸ3q ǝA;wrĸ3Hqg Z"ŝE;w),RY3qgŝA;w),RĸHqg΢'™ ƝE;w1,RYHqg"ŝE;w),RY3qg"ŝw),w1,RY3qgΧHqg ƝE;w) bYHqg"ĝ5;w1,RY3qgew) bYHqg"ŝE;wrYHqg ƝE;w0,RY?ŝ*ƝE;w1,RYHqg"ŝE;w),RY3qg"ŝE;w(,RĸHqg"ŝw),RĸHqg"ŝA;w) bYHqg ƝE;w0,RYHqg"ŝE;w1,RY3q燲_Hg E*>T|e"ŝE;w(,Rĸkw) bYHqg ƝE;w1,RYHqg"ŝE;w\wqg ƝE;w1,RYHq ǝE;w) bYHqg"ŝE;w1,BY3Hqg"ŝE;w),RĸHqgŝA;w),z"ŝE;w),RYs"ĝ5;w),RY3qg"ŝA;kw} ŝA;w) bY?N;w1,BYqg "ŝE;w),RY3qgŝw\qg ƝE;w1,RYHqg"ĝ5;w1,RY3qg"ŝE;cw1 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ѿ]VǝA;w) bYFqgƝE;w) bYHqg"ŝE;w)QY󅖸?q.A;7B'ĥwRN]jҏSqwRN\:q'.Sq'Љ;w 5j܉AN:q5ĥw 55ԡƝ8tN\:q.5ĥw҉;uqPN|܉;qĝԸSw҉;qĝB;N)ԸS(qL?qK?NaX׸SwRN^JܩK;u)q'%ԡƝԸ(q'?.q.5ԥƝw 5$w 5$JܩAN^J)Ը躾Q?N};u鑸wĝ:ԸSwRN\:q'QN|܉;y)q.5ԥƝD;w}]7GܩAN]jK;y)qPN}\N^zoԉ;u)q'7ĝԸSw7ĝԸnuNƝDuNƝD_uN^zz\:q'.辿Q'ԥƝԸuNjK:q^zwW5ƝD:q.5$։;w}։;#hܩK;y?Z'ԥƝDuN^zVNjC:q.5ĝwNK;uq.5$։;w}։;#hܩK;yz{?Z'5hSwuNz-WD:ŧ.ԥS|]ĝD:q~;y)q'.NK:q>.q5pSwuN)Ը{Nܩoq.5$׉;w]ĝ4ԥƝԸwwPNnSwRN^|jܩK;?Q'7~N^z^zOԉ;uNƝwmNܩK;u)q'q>q'ĝԸSwRN]jܩK;&yԉ;}7@Sq'uNܩK;uq'/q'wĝԸnuN]jܩK;y?P;i.4qƝ:Ӹ{N)ԸSxN^JKq:q.%ۯ_vN8SwRN^Ӊ;uq'8q'eN܉;uq'QN6SxN^oӉ;uq.%8SָSwcNܩK;y?N;ew5jܩ;y?N'jISxN]jܩK;y麿N;qĝ8tN^9pN}\N]jKu:q'e}NI\_GN:SwRN^Ӊ;q;uq'/ĝ^mď{NKu:q.=~>Ku:q'~涿N'7}N\:q'/=ĝD;q;y鹿N'ԥƝt__wPN^zN}\N]jKu:q.%:5iI7Yߢ:S?ƝԸtN}\N^Ӊ;u)q5:;?_w7q];9˝A\ rg;_hY rg;9˝A\ r /wq3˝A\.wqs;.wrg;9˝A\ rg;y3˝A\ r /wq3˝Π=1\|eH˝EZ rg;Y .waF˝A\,rg;"-wiH˝A\,rg;Y"-wi3˝EZ,rg;Y",wpH˝EZ"-wvT .wiH˝A\,ЫH˝EZ rg;Y .wiH˝A\,rg;"-wi3˝Erg;Y"-wqH˝EZ,r /wiH˝EZ rg;"-w7?.w櫸Y"-wqH˝EZ,rg;Y .wiH˝EZ rg;Y -whH˝A\,rg;9˝EZ,rg;Y"-wqH˝EZ rg;>/w~ g<09"yiγHsA,Ҝg<49"yi3s?;Y .wiH˝Y"-wi3H˝5Z,rg;˝EZ rg;Y .wiH˝A\,rg;"-wi3H˝5rg;Y"-w=Y"-wis;Y"-wqH˝EZ rg;n .waF˝AZrg;"-wi3˝EZ,rg;Y"-wi3˝EZ,rg;Y",wrg;k"-wiH˝A\,rg;Y΢s Z rg;΢qrg;Y-wa3˝EZ,rg;Y"-wq˝5ZΚ6yH˝A\,rg;Y"-wi3˝EXrg;Y"-wqH˝Eqrg ;޸"-wiH˝A\,rg;Z,rg;9˝EZ,rg;Y"-wq˝5Z,rg ;Y .wiH˝EZ rg;",whH˝A\,rg;"-wa3˝E-wis;Y .wiH˝EZ rg;"-werg;Y .waF˝EXrg;Y .wiH˝A\,rg;-wi΢Y|sz:sA;-sA;_h;9󅖸sA;9|!ǝcwrBK9q Ɲcwwr9q -q ǝwrBK9q ǝwwr9q -q ǝwqmqg Ɲw1 bĸ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 bBKĸ3qgA;w)3qgΠqAh9*ƝA;9 w13qgA;w1 b9qg ƝA;1aĸs ƝA;ww1 b9qgSds A,> 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 R9qgϛA;.ĝA;9 bĸs ƝA;ww1 bĸs ƝA;9 Rø3HqǝA;wrĸ3qgA;w13Hqg Ɲw1 bĸs ƝA;8 0 bBKĸ3q ǝA;w13qg1;we]A;w13Hqg ŝcw1 bĸs ƝA;9 bĸ3q Ɲ1;wA[tOqw jn^tЉ;qĝԸSw~#j~ĝԸN܉K'j tNƝB;wGиNܩC;qĝBĝƝ:ԸN܉K'ԥƝtN\:q.5j܉;q'.SwRN\:q'.Sq'Љ;w %i'#|GItkƝԸwRN]jܩK;y(q5ԥƝD;q;uq.5ĝSq'Q0LSq'QNwRNƝDwoܩK;y)q'/MܩC;uq'/%ĥw%ǝwRN]jISq'u}~ĝ4ԥƝuN}\N^zoԉ;u)q'7ĝԸSw7ĝԸnuNƝDuNƝD_uN^zz\:q'.辿Q_;uq.5FSwmNܩK;һ3_uwwRNhSq'hS?ƝԸuN]jI?Z'h5ԡƝP'ġƝ4:q.5@SwRN^TN>Mܩoq4$w 57޸tN]jܩK;yqz{?N'ԥƝԸntN]jI>N'jIsߦwpN]jI辿M'7޸tN]jܩK;y?N'ԧ5ԥƝwRN^SNƝD?o;w?~N^Ӊ;w}Ӊ;uq.5:5ġwЉ;y;q;uq'/=ĝDu:q's};tN]jܩK;y鶿N'5ԥƝt_wRNzJܩK'5:S:h?Qv֑li ĞʈģWFAhv_V>iq'ŝXZɥuZ~wr:-Rq'봸SCŝ\?˺SWܩN.=iq;9qNŝj;FuZܩo@q;yN;qŝ\zܯN-wjC?/}?/}߸??woH3qg#F;'2l$Hpg"F;w6l$H3pgF; w6l#ܙpg#Dĝ; w6LDHpg#Dĝ; w&"l$pDƝwnHs#΍;7l$ܹϸsFwnܹpg#΍;7pFw6smF;7pFwn3l#ܹpF;7 pFw6pF;7s#FwnHsq6w6s#FoqF;7pFwnܙs#΍;7l$ܹpF?6wnܹpg wpFwnHs#΍; wnܹϸ{ⳑFA|nsύ~ wnܹb#DĝwnHs#΍;7l$ܹpF;7s#Fwn3l#ܹpFw6s#΍; wnܹpg#΍;7pFw&"s#΍;wnܹpg#΍~oqF;7s#FwnHs#΍;7l$ܹpF;y(m; wnܹpg#΍;73qFwnHs#΍; wnܹpF;7wns΍;7l$ܹpF;7gܹ pg#΍;7pFw6s@ w!gܹ pg#΍;7pFw6s~n FwnHs_Dܹpg#΍~Ɲwn3l#ܹpF;7s#F;L$ܹ6wnHs#΍; wnܹpF;7wnܹpg#΍;7l$ܹpF;wnt~l$ܹpFw6s#Fwnܹϸ3 qFwnHs#΍; wn3sqg΍;7l$ܹpFw6s#F;pFwnHs#΍~Ɲm;7g;7LDܹpF;7s#Fwn3l#ܹpFgY; wnܹpg#΍~Ɲwn3l#ܹpFw6s#Fwnܹpg#m;7ȸs wfo6*hŝXZܩN-ww**N-wbiq'w**DSQqNEŝwbhq;SQq'>SCŝZ܉ŝZ*N,-RqN|N,-Rq;K;w"ZܩSQpΟZҿw2zu\q;ɥN-wj)C*Rq'N~\p;TɥN.w**d? 3 TT(S߂N.w**dqQ_pN-wr)K;5TܩN.wb?/-Rp;T(SQq'_w>>7 ԷSKŝ\ Zܩ+F-Rp'SKŝZ*dߨŝZ*~w**d~Q;w2uQ;܉ŝXZyQ;TܩN.}oN wrqQ;TܩZUZ1~V|2}d+>/يO}_*>Tɥ%[ܩNFKKSCŝ_ŝZ*Rp'~/N|N.wjSKŝKSQq'%[ܩoAq;%v~w;<_ŝ*-Rq;=kq;TɥZ~w2}Q;-(~wbiq'SܩN=7jq;qQ;w2zߨŝ‹;T~w**dvQ;-(Rq;n)SCŝSCŝZ*~wjOԷD-K?o~ONFSQqN.='jq;ɡBwÊ;9_ŝZ*Rq';TܩNF;|N}ŝ\zNEŝ;wjSKŝ\zTq'wb~wjKZܩN-wry?PŝlipNw2zŝ;wr~wjSKz8};[~wjSKŝ\z܏N-w2z?ŝ;ټoN|wjQp'6-^ɥmZܩN-wrq?N;iŝZ*8-Rq'TܩSQq;ŝ;ߏN-wjKT܉ŝZɥ;qŝZ*:-dvN;>_NF봸SKŝZ*~w;Tɥ:-Rp'>xr_p'uZɥ봸SKiq'uZɥ봸SKŝ\zN wr,N}\q;_ŝZ :w)dO~=iqŝZ*:-wrqN;ܩN= y ppDƝwNd9qх;'2ȸs"WtΉ;'2|Eȸs"Ή;_q4ƝwwNd9q4ƝwNd9qDƝwwNd9qDƝwNd9qDĝw]3qg"Ή;Ǎw&"ȸ3pgΉ;w&"LD9qg"Dĝ;'2LDܙs"Dĝ;wNdܙ3qDƝ;w&Ƹ3qg"WtDĝDĝw&"LD9qg_;Dĝ;'2LDܙ3qDƝ;wNdܙH3 qg"Ή;w&"ȸ3F3qDƝ;wNdܙ3qg"WtDĝ;wNdܙ3p4Ɲ;w&"'\_xN%LD˙s"[Dh9'LD˙3-Dh9r&圈3 -g"ZΉl9r&LD˙3-D발h9'LD˙s"[Dh9rNd˙3,4h9r&Ȗ3-g"ZDr&LD9-g"ZDh9'LD˙3-g"ZDrLD9-g_uXDr&LߨrNd˙3-Dh9r&Ȗ3-g"ZΉh9ӼO-gZΉl9r&Ȗ3-g"ZD谜h9r&Ȗ3-g"ZΉl9r&LD9-g"Y4rLD˙s"[Dh9'LD˙H3 -Dh9r&Ȗ3-g"ZΉl9r&L$j˙H3 -Dh9r&Ȗ3-g"ZΉh9r&RrNd˙3-D~ݏa9rNd˙H3 -g"Yil9r&Ȗ3-g"ZDr&LCl9Ӽoa9rNd˙3-Dh9r&Ȗ3,g8s"[Dh9'LD˙3,4or&LD˙s"[Dh9'LD˙3,9,g"ZDh9'LD˙s"[Dih9rNc˙3-Dh9r&Ȗ3-g"ZΉl9rLD9-g"ZDh9'LD˙Hs[D -g"ZWtXDh9'LD˙3-Dh9rNc˙3?rNd˙3-Dd9r&Ɩ3-g:s"[Dh9'LD˙3-Dih9r]3b9޿Zn&Dk9SKZyTT}ZZN,TTˉh-ZNEj9-ZN rbi-ZN|\-j91Kk9TˉXZ˩ZNEXZ˩ZN-rbi-'r*DSQ-_P-߁//j9Tɥ_/SKZP,j9T(˩ZN-rr)Kj9Ìb9r2ԷKj9}o˩/SK\XN rjKXZ(R,j9T(SQ-'_w>>7ԷSK\Z˩FR,'SKZdߨZ~r*d~Qk9r2uQk9ZN,dߨZR-'>7j-j9ߨ̯,|-'pR-'pTT~r[P˩ZN.}ZN-r2z\}?\pR-'b9~rrr)SKZq?\k9r2zrjK?o>k->KZ˩ZN.}ZN-rj~rjSK\ߨ7j-'S߂ZN.=7j-'rrqQk9q~rjKSQ-'Z˩/SK>7j-ZNFoS߂ZN-rjK?ިb95Tq>Qk95T˩ZN.='j-j9}D}}OZN|k9vDdq?Qk9r ~rjSKz/T->CZ˩ZN-rr)SKZd4@]ɥ@TT~rjSK\zT-'rb~rjKZ˩ZN-rry?Pli,ZNr2zj9rr~rjSKz8};[~rjSK\z܏ZN-r2z?j9ټoZN|rjQ,'6^ɥmZ˩ZN-rrq?Nk9iZ8R-'T˩SQ-k9j9ߏZN-rjKTˉZɥk9qZ:dvNk9>_ZNF봖SKZ~rj9Tɥ:R,'>xb_,'uZɥ봖SKK봖=_rbi-'>i-'uZɥ봖SK\zZN rrZN}\-j9_Z:rd~=i-Z:rrqNk9˩ZN=y,~89 r圆79Iix89 qN9ix49 Oq_✆8ix $<9 op8Ix49 oޜ7ixx4<9 nNã77ixq49mNk7DZ4F6.mѡ4Fg648D764F64e)8eݦ)2eLg)*e_IF')"e(e]F(e$%ix2Pix2ͯ 4:A9 /P$?''4:>F'4osÓitwrLIttd4:89 Mѹ469 Mѭ4:5F&43Dg&4<2F7&40F&d%\x[rL˒itX2JNóitU2JNÛitR2.JAW{itN2I1ixK2NI%ixH2 H&4"9 H 4:!9 /H4F#4:F#4D#n4<FW#hd݌'#bd"Ӝ#F"_oEѩ49Ϳt(2Dљ49 Dэ489 /Dс4d<4F!64< !0d܅g!*dL$d]Ld54:9nA&)4wsL?݁DփNd@8E'!Ȉp"+Wt0‰'2$|E$荔p"[‰ _54NdQ8I46@YNdVW8aDNd\8uD慯Ndab8DDX]0a"BÉ, &5LDl8a"q4&8LDrp"DTNdx0DQ&"?0b" ĉL &"BL$8b":D萈H'FLDq"D9H$Nd*1Yb"ĉ Q&&"M61F:1yDQ(Nd~Jq"3Dt'TLDV1+:b"rD'XLDHfqDo?Q?ʟ-㗈nq"DH']LDz1DQ0Nd˜1c"*Ɖ1&"dLD8)cZDČY3&"gLDϘ1Ic"ƉQ5&"kLD8ac"D6&"nLDݘq"D$1qLD㘈1Df:&t1c"blj;&wLD8c"D4@=&{1 c"ljlߨC?&"1d" D$@&"LD9d: d"JȉL!B&"2DC!"2Id"ȉ"QE&"LD22'%ȉ#QG&">2d" D$H&LC%9d:D(%'2LD+Xr"kD䒉%LNd1d2d"ɉ&M&p2d"D'ӐONd?2e"ʉl(Q&2 e.%Dh)SNdM82ADD*T&ƪ2Ye"ʉ +QV&"LD[9qe"4䕯Ⱦ262D6,QYNdf2e"JˉL-Z!LDm9e"zDY\&"LDsHrD7ˉ /Q^&"LD{9e"D_&"LDH3fÜ3!f"J̉L1b!L$99f"zDYd&"LD(s"Dd2'2L$43mDƙ3g&Ϝ@3f"il43T4_4j&ԜT3f"bDԚk&L$9f"DGW9f"Dtn&LCHvsDԛ7oNd3 D68Qq&"㜈3 !g"Jοr&z_,r&Ȗ3-g"ZD谜h9r&Ȗ3-g"ZΉl9r&LD9-gZDr&L$˙s"[Dh9'LD˙3-Dh9=e9rNd˙3-Dh9r|El$H3-g#YFd9r6l#˙,g#YFh9r6l$˙,g#YDd9r6LDH,g"ZFd9rl$Hs"[FFh9r6LDΧ,g#YDd9r6LDH,g"ZFmd9r&l$H3-gl$˙,g#YDd9r6Ȗ,gFr&l$3 ,Lg%l$˙,g#YDd9r6LDH,g"ZFd9r&l$H,g"Y6d9r6l$Hs"[Fd9r6l$H3-g#YFh9r6l$˙,g#X4d9r6LDH,g#YDd9r&l$H,g"ZFd9'l$H,g"Y6d9l~l9r&l$H,g"ZFd9r6l$H3-g#YFd9ۼO-gYDd9r&l$H,Dd9=1d9r6l$˙,g#YFh9rL$F,g#YDd9r&l$,g"ZFd9r&l$H3-g#YF`9lF3-g#YFd9r6l$˙H,g,g"ZFd9r6u?Nd9r6l#3 -g#YFh9r6l$˙,gYΉh9ۼo-g#YDd9r&%H,g#YD`9r6LDH,g"ZFd9rlt~LDH,g#YDd9r&l$H,4d9r6LDH,g"ZFmd9rl$H3-g#YFd9r6l$˙,gYFh9r6l$˙,g#X4YFr6l$˙,g#YFh9r6LCH?U[Dd9r&lF,gZFd9r&l$H3-g#YFd9rl$WCszZDrbi-j9T˩b9TˉXZ˩ѯZNEj9r[PˉZNEZN rbh-'rjKk9SKj9qk9SKZZN,TTˉh-ZNEjj9|?/}a}\-j9ɥXN-rj)CR-'XN~\,j9TɥXN.r*d? 3TT(S߂ZN.r*dqQ_,ZN-rr)Kc95T˩ZN.rbi-'XN|ZN.rjSKb9aqQ_,ZR,'~oZN}\-'>7j-b99ߨZR-'FR-'SQ-'Z˩ѯZɥ?ިorbi-'FR-j9Ӝ_XZN}\R-j9=k-j9=k-ZNFõS߂ZN-rr~rjpP-'>k-j9ɥõKZR-'pTT~r[P˩ZN.=x]ZN.=?\P-'>7j-j9TqQk9T˩ZN.}oZNFoZ˩oA-'Kk9ߨXN rryQk9TɥZ˩F^˩ZNFSQ-'Z˩oA-j9TɥowKd8R-'SK>x>'j-'\zD}~r2j9KZ˩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<_//󿗾us"|E]Ή|s"w9.D9r.D9r_9rN仜.+]i|s"|E]Ή|s"w9_qs"w9_qs"w9']Wtw9']Ή|w9']Ή|w9'zϗzE9r]w9.g"w9.g"LĻ.g"Lû.g"LĻxs"LĻx3rN仜x3rN仜x3r&]Ή|3r&]Ή|3r&]D9r&]Dx3Fxs"LĻxs_˙_w%]D9r&]D˙w9']D˙w9']D˙w9.D˙w9.D˙~xs"LĻxs"LĻx3r.g"LĻxs"L]Οf~uNc_"LĻxs"LĻxs"LĻx3rN仜x3rN仜x3r&]Ή|3r&]D9r]D9r&zӿx2r&]WtLĻxs"LĻx3rN仜x3rN仜x3r&]Ή|3r&zoq3r&]D9r&]D˙w9']D˙w9']D˙w9.D˙w9.+:r&]D˙w9']4˙yQ]D7˙w9']D˙w9.D˙w9.D˙w9.g"w9.g"圈w9ӼOr]Ή|3r&]Ή|3r&]Dx3r&]Ή|3r&]Ή|3Dw9.D˙Hw9.D˙w9.g"w9.g"w9.g"Lû.g"LĻxs"LĻxs"LĻx3r.g"Lû.g"LĻxs"LĻxs"Lû~>w9']D˙y?N]D˙w9']D˙w9.4˙w9.D˙w9.g"w9.g|E˙~xs"LĻxs"LĻx3rN仜t3 r&]Ή|3r&]Ή|38w9.4˙滜.g"LĻxs"LĻxs"LĻx3r.g"LĻxs"LĻxs"Lix3rN㻜x3rN仜x3r&]Ή|3r&]Ή|3r]D9r&]Du:rN仜x3rN㻜LĻ˙w9.D˙w9.g"w9.g"w9.g]Ή|3r&]Ή|3r]D9r&]D˙w9']D˙w9']D˙w9.D˙w9.u3r?3Ss"[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#YFr6l?7LDHᓈ/O#YFh9r6l$˙,g#YD`9r6LDH,g"ZFoeH3-g#YFh9r6l$9-g#YFd9r4+_"X4d9r6LDH,g"ZFd9r&l$H3-g#YFd9r6l$H3,gYFh9r6l$9-g#YFh9r6l$˙,g#YDod9r6LDH|l9r6l$˙,g#YFh9r6LDH,g#YDd9rNdH,g#YDmd9=7ʖѯl$˙,g#YFh9r6LDH,g#YDd9r&lv?Qmd9r6l$˙,g#YFr6l$H3-g#YFh9r6l$˙,gYDmd9r6LDH,g"ZF`9r&l$H,g"ZFd9r6l$s[Fmd9r6l$H3-g#YF`9r6Zr&l$y?N~ݏ-g#YD`9r6LCH,g"ZFd9r&lFs"Z6odH3-g#YFh9r6l$˙,gYFh9r6LDH,g#X4oh9r6l$˙,g#YDd9r6Ɩ,g#YFh9r6LD,g#X4d9r&l$H,g"ZFd9r6l#H3-g#YFd9r6l˙=#Hs"[Fd9r6l$H3-g#YFid9r6?j˙,g#YD`9r6LCH,g#YDd9r&l$H,g"Y6d9_a9OopYΉl9_a9'Ȗs"[οrNd9-D谜rNd9-Dr"[il9'|EȖs"Zil9_a9'Ȗs"[Ήl9'|EȖs"[Ήl9_a9'Ȗs"[Ήh9;,g"ZDr&LD˙s"[Dih9'zLD˙3-Dh9r&Ȗ3-g"ZΉl9r&LD9-g"ZDr&LD˙Hs[Dh9_a9r&rNd˙3-D~|r&Ȗ3-g"ZDr&LD9-g"Y4h9'LD˙s"[DouXDr&LD9-g"ZDh9_a9r&LJlD˙Hs[Dh9rNd˙3-Dh9r&Ȗ3-g"ZΉl9r&LD9-g"ZDh9'LC˙s"[Dh9rr&LD9-g"ZDh9'LD˙s7ZDh9rNd˙3,4h9r&Ȗ3-g"ZDr&LD9-g"ZDh9'LD˙3-g"ZDrLD9-g_uXDr&LD˙s"[Dh9'LD˙3-Dh9rND˙~l9rNd˙3-Dh9r&|ELD˙3-Dh9rNd˙3-g"ZΉl9r圈3 -g"ZDr&LD9-g"ZDih9'LD˙3-Dh9rNd˙~˙H3,gZΉl9r&LD9-g"ZDrLإȖ3-g"ZΉl9r&Ȗ3,gZDr&LD9-g"ZDh9'L$˙ryߦr&Ȗ3-g"ZΉl9r&LD9-g"Y4h9'LD˙s"[Dh9rNc˙f9-g"ZDh9'LD˙s"[Dh9rr&LD˙s"[Dh9'LvNL$9-g"ZDr&LD˙s"[Dh9'L$˙3-Dh9r&Ȗ3-g"Yil93h9_a9r&Ȗ3-g"ZDr&L$9-g"ZDGW9-g"ZDr&LC˙Hs[Dh9rNd˙3-Dh9r&圈3 -g"Zοr&z,r>3EXZ˩ZN-rr*XN-rbi-'r*DSQ-ZNErbh-j9SQ-'>SCZˉZZN,R-ZN|ZN,R-j9Kk9r"Z˩SQ,ZΟ_,K_,'aXW˩ZN.rr)SKZP,j9(˩ZN-rr)Kj9Ìb9r2?y߂ZN.r*dqQ_,ZN-rr)Kc95T˩ZN.rbi-'XN|ZN.rjSKb9r25|XN} j9TɥXN.ߨZN.}oZN-rrqQk9T˩ZNFZ˩ZN.=7j-ZNFSQ-'_KQ,ZNFߨf~Z˩ZN.}ZN rrq?\k9T˩ZNFZ˩ZNFZ˩pԷSK\Zd~?\k9~j95TɡZ˩ZN.rrpǭR,j9Tq?\k9r2zrj/ KSWɥFP-'>7j-j9TqQk9T˩ZN.}oZNFoZ˩oA-'Kk9ߨXN rryQk9TɥZ˩F^˩ZNFSQ-'Z˩oA-j9TɥowKd8R-'SK>x>'j-'\zD}~r2j9rrq?Qk9T˩XN=SVɡBR-j9˩ZN-r2~r~r*dq?Pk9T˩ZN.=Ck91Ty?Pk9Tɥ@R-j9ZN6o4S_t-fj9ߏZNEk9q?Nk9T˩XN=xdq?Nk9T˩ZN.=i-j9ZNDli-'k9T(~r 6R-b99ZN-rr~rjKqTSV˩S\z܏ZNEi-j9TɥuZN ˁZN-rr~r2z;_~g-'uZ˩ZN-rrqNk9qZ~rj)CN}u/:uZ˩?|ۥuZyܯZN|k9K봖:uZ˩ZN.=i-j9~tu->SK\zޯZN-rr~j9r2W봖S߀ZN-rr~rj9_ZP-'rr71PrCi8!㜆@pNC9 1~sWc9 4ӐnI7|5fPmN#9 1ٜbsWc9 4Ԛk[iH5ԜPiNC9 1ҜFsI(4nF>3x4ԙi3f͜23 `fi2HeL#9 If4i1!L#FsZ4i$1bNCF 34Did0ӈ`3eWc}F2Fr4i.!L ;F24$i$.\2eaih-ӀZ&L#h9 e14RYy;_4XL<_4•id+ӈV4?d~ri*U2De4ӐSL#L9ͻ,eQ4i)L#FFr"42iD(HPNC@F~2di'Nr2d4bj2diH&HLL#/9 di4’JL#)FPr:4bi$'!L##FD24i#ӈG82ldi(#FL#9 Ud42$2Dd4ӈC&L# 9 -d_c Fr:4bi ANCF24iӈ?~1ci$ci=yc4i_ci4Žid!uL#Fq:4bi9NC14Iӈ7n1lci(6kL"8 Uc42iDhL#ИFqr4Ҍi2S4IcL#ƘF144iDH0N#D~1͏?S@zq4iD\L|nӈ-NCh1bI(,W\1ba4Ӑ*TL"jb!ihӈ(P@1|b4҉'ML"F2q4riJL#F&1 H$i^Ӑ#FL#FqR4iCL#F 1 +AL#F14iHNC|0aI;]0a4"P8L#o8 ah$†id !5L#iF04di NBc0L#`j ӈ.0la4+LV8 Ua4dNCQF0<4i %0$aA4rӐ"L#D8 a4iL">Fzi';׿_w'&U~wrXZ?B-U*! B-Ubi!**$DPQ)ZBEńTbh9 ^PWRB -*ҪB-bi]!jPQi!>nm!jPKXZ_* -1TTc=Tew 3y3dJC-r 6R 9oC-U2 9jPKU\ ;RܡCF#.O\VOT{(P߂C.*?dqQ_D- r)K:c!jKXZ(KZFR9"xDE~08ߨ/&Q߂D-U%r),K7ja>2K6QKzoD-'j@~(jFKZLF-TTTFUo. _r #02zׂE-U,jdKõhQCU\z׺E-.jr~.jx~/*_d~?\+-(aR #>kBF.RF 2r~V3jK\}?\+qKӨF-U52z׺FEkiZ*n7ۥZߨ{p|8jƑKQKeZsdߨZ*uR#>7j#ZFxԷKZU\zoԺG}\ࣆ*9ߨZ*~F-TT~V@ /R $Z F-ԷRKZ7껥hH C2zOԂH UDj$KZHFX~gr:-?:dtSCZˉZZN,R-ZN|ZN,R-j9Kk9r"Z˩S{qZw˩ZN-rr;R-'XN~\,j9TɥXN.r*d? 3iDb9-R,ZNFr R-'b97f-j9ˉb9qk9˩ZN-r2TTb9-R-'b9~rj9yQk9ɡFR-j9=7j-j9ߨj9oZNE~F4+?k-'k9~rjSK\<~rjSKõSKõSQ-'Z˩oA-j9q?\k9T~rrprjCõSK\Zˉ[ɥXN-rj~r*d~Qk9-R-'Q.}oZN}\-'SC\ߨZR-'FR-j9yQk9oZNF7j-\zoZN,~rb95TɡFR-'>7j-ZNFS_x-j9}oZNEZj9=7j-j9TɥowKd8R-'SK>x>'j-'\zD}~r2j9rrq?Qk9T˩XN=SVɡBR-j9˩ZN-r2~r~r*dq?Pk9T˩ZN.=Ck91Ty?Pk9Tɥ@R-j9ZN6o4S_t-fj9ߏZNEw?Nk9q?Nk9T˩XN=xdq?Nk9T˩ZN.=i-j9ZNDli-'k9T(~r 6R-b99ZN-rr~rjKqTSV˩S\z܏ZNEi-j9TɥuZN ˁZN-rr~r2z;_~g-'uZ˩ZN-rrqNk9qZ~rj)CN}u/:uZ˩?|ۥuZyܯZN|k9K봖:uZ˩ZN.=i-j9~tu->SK\zޯZN-rr~j9r2W봖S߀ZN-rr~rj9_ZP-'rrw)˙w9']D˙w9.+:r&]D˙w9']D˙w9']D˙w9.D˙w9.D˙w9.gw9.g"w9.g"LĻ.g"LĻxs"LĻxs"LĻt3 r.g#lxr6]F˙w9.g'xr6]F˙w9.g#lxr6]DHw9.g#LĻtr&]FHw9.glts"l/7jxr6]D_?.g#LĻtr6]DHw9.glmtr&]FHw9.g]F˙w9.g#L?1Jl/rN仜tr6]DHw9.gltr&]FHw9.g#lt3r6]F˙w9.g#lxp.g#Lmtr&]FHw9.DHw9.g"ltr&]FyQHw9.g#LĻtr]FHw9.g"ltr&]FHw9.g#lt3r6]F9r6]FHw9.glxѯ]F˙w9.g#lxr6]D^.g#lxr6]D~xr&]FHw9.g#lts"l~?QHw9.g#lxr6]F˙w9.gLmtr6]DHw9.g"lpr&]FHw9.g"lt3r6]Fw9]FFw9.g#lt3r6]F˙Hw9.g%]DHw9.gl~|r&]FFw9.glt3r6]FHw9.g#l.gm]F˙w9.g#LĻtr6]D2mtr&]FHw9rjw9.g#Lûo˙w9.g#lxr6]DHw9.g#w9Y#lxr6]Dw9.g#Lûtr&]FHw9.g"lt3r6]6Hw9.g#lt3r6]F˙w93Hw9']FHw9.g#lt3r6]F˙w9.g𣫾˙w9.g#Lpr6]4Hw9.g#LĻtr&]FHw9.g"ltw9Ow9Ȗs"[Ήl9';,DrNd9-D谜rNd9-+Ɩs"[WtXΉl9'Ɩs"[Ήl9_a9'Ȗs"[WtXΉi9'Ȗs"[Ήl9_a9'圈s[οr&LD9-g"ZDh9'L$˙s"[Dh9rNd˙3-g"ZΉl9r&Ȗ3-g"ZDr&LD9-g"ZDd9LD˙3-g"8-Dh9rNd˙'-g"ZΉl9r&LD9-g"ZDr&LC˙s"[Dh9'LvQLD9-g"ZD?[ΟJ/-g"ZD谜h9r&Ȗ3-g"Yil9r&LD9-g"ZDr&LD˙s"[Dh9'LD˙3-D발h9'LC˙s"[Dh9rr&LD9-g"ZDh9'LD˙s"[Dh9rNd˙3,4h9r&Ȗ3-g"ZDr&LD9-g"ZDh9'LD˙yQLD˙3-Dih9rNd˙F3-Dh9r&Ȗ3-g"ZΉl9r&LD9-g"ZDry([4r&LD9-g"ZDh9_a9Oa9rNd˙3-Dh9r&Ȗ3,gZΉh9r&LD9-g"ZDr&L$˙s"[Dh9rNd˙3-Dh9r&|5L$˙s"[Dh9rNd˙3~l9r&RrNd˙3-D~ݏa9rNd˙H3 -g"Yil9r&Ȗ3-g"ZDr&LCl9Ӽoa9rNd˙3-Dh9r&Ȗ3,gZDr&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,4h9r&Ȗ3-g"ZΉl9r&LD9-gZDGLX]a9rNd˙3-g"ZWtXDh9rNd˙3-Dh9r&圈3 -g"ZΉl9r&LC9-g"ZDr&LD˙s"[Dh9rNd˙3-Dh9r|El$H3-g#YFd9r6l#˙,g#YFh9r6l$˙,g#YDd9r6LDH,g"ZFd9rl$6b"[FFh9r6LDΧ,g#YDd9r6LDH,g"ZFmd9r&l$H3-gl$˙ϖ_ch9r6l$9-g#YFd9r6l˙,g#YFh9r6LDH,g#YDd9r&l$H,g"ZFd9r&l#H3-g#YFd9'l$H3-g#YFd9r6l$˙,g#YFh9r6LCH,g#YDYFd9r&l$H3-g#YFd9r6l([Fd9r&l#H3-g_eH3-g#YFd9r6l$˙,g#YFh9r6L$~h9r&l$H3-g#YFd9'l$H,g"ZFd9r6l$H3-g#X6d9r6l$˙,g#YDd9rLDH,g#YDd9r&l$H,4`9r&l$H,g"ZFEFя?`B3-g#YFh9'[F`9r6LCH,g"ZFd9r&lFs"Z6odH3-g#YFh9r6l$˙,gYFh9r6LDH,g#X4oh9r6l$˙,g#YDd9r6Ɩ,g#YFh9r6LD,g#X4d9r&l$H,g"ZFd9r6l#H3-g#YFd9r6l˙=#Hs"[Fd9r6l$H3-g#YFih9r6?j˙,g#YD`9r6Ll$H,g"ZFd9r6l$H3,gYF谜'cb9aNOT˙"_ZN,R-j9^b9rq_,j9Kk9r"Z˩SQ-ZN| j91SCXZ˩W˩ZN ZN-rbi-'rjSQ-'>n-'rjSKXZˉj9TT˩(SM-߁//Q0R-'b9˩ZN-rr(SCZdɏR-j9ɥXNEaF:/S߂ZN.r*dqQ_,ZN-rr)Kc95T˩ZN.rbi-'XN|ZN.rjSKb9r25|XN} j9TɥXN.ߨZN.}oZN-rrqQk9T˩ZNFZ˩ZN.=7j-Z~bõSQ-'_õK<\,ZNFZ˩ZN-rr|rjKZ˩ZN-r2zZN-r2zZNEk-ZpR-'ZɥU˩ZN}ZN-rr)Kk-'>n-'b9T˩ZNFZ˩FԷSK\zF}yQk9q\zoZN rr~rjZqQk9T˩ZN.}oZNFoZ˩oA-'Kk9ߨXN rryQk9TɥZ˩F^˩ZNFSQ-'Z˩oA-j97껥XN r2zOZN rjKZ˩ZNFNk9ryߦR-'XNFmZ˩/K۴SKZ~rj9TɥqZ˩ZN.=ǩSM-'[-ZNrrq?Nk9r2zZR-'>שCk91K/rj9TɥuZ|r2}N>i-j9Tɥ:rjKuZ˩XN}:};"XNF봖Ki->o>i-'{qNk9EZN.}ޯZNFo봖Ki-j9<_?յZN-rryNk9ɡuTS\6zܯZN}j9TɥuZ˩~rj)SCzKY)ys"|E]Ή|s"w9.D9r.D9r.D9rN仜w9]Ή|w9']Ήxs|E]Ή|s"|E]Ή|s"w9_qs"w9']Wtw9']Wtw9']i|˙w9.D{ˎJ4:#XK점Slz :I>w9] r.gv9c9ȻA .gw9y3A . rq3 .gw99ȻA . rq3A] rqB.gw9qsw9>5o]A ~Ww99ȻA .gw9y3A] rp3] r.gm]Π2 z? qsw9] r^h .gw99ȻA .rq3A] r=k .gw99ȻA . rq3A] rq3] r.gw9] -A . rq3A] rqsw9] r.gw99ƻA .gw9=] rqsw9]A .gw99ȻA .煖] rq3] r.gF-A] rq3] r.gw9]A .gw9q3?Q. rq3] rqB.gw9]A .gw9y3A . ri3湿P.gw99ȻA . rq3H1] rq3] r.gw9],A. rq3A] rqsw9c~,!?N. r}Ӳ]Ari3A] rqsw9] r.gv9cy!ri . rq3] rqsw9] r.gw99ȻA .gv9x3h\x3A . rq3] ri2.gw9]A .gw9y3H1 .rq3] rqsw9]A .g w99ȻA .gw9y3A]Π w9ye3A] rq3] r.gw9ŏ.N. ri3A] rq3] r.gw9]A.gw9m3_v9~֔s K8Îs 318%Æs 1,8/s 17/zs 1l70ݼ ! 7ǰۼ16(f2N6ǰ`250Zs c˸Ts K1 5/Ns 314/Hs 1J4c@3F}f13cgƨ͌Q9ef uceƨʌQ&s 1 2cca3F11J1cTb(3Ff*10c`(A9f嗗q}2FQz9euc]|ogb]ƨ2Fec[ƨQl9e R1 -ǰQfr #˘(|SO.kXƨQ^9ue1J+/2FaeecXU(AS9Ie1)0QM\"1J)cTR(Î2Fe*1(cP(QA9橀2FdՓcOQ:9du1&/j2Fd1L&cTL(Q/9djŒcJ(Q)Pr ;e1$0Q#D2F1#cGƨ82Fmd1,#cFƨQ9Ud5q"2FAdz1!CTC(2c}u\B(2Fd*Ec@(Q9d10~Qqǐ{ Q8c5c<ƨxQ2cT;(vQ8cJc9(sQq $!a1Fyc1c6(mò1Fac ecc5ƨiQ8Ecc3ƨfQ"NcP2(dÎ1Fc*Ec0(aQ8FcŘ?Szq 1Jǰ\Xw1ǰZAf11 c+aZ1FbZ1LcP*(T ;ŐڸRQ8bc(ƨOQ:q !JcT&a.1FYV1c$ I"1fq sՈ1c"a1F!v1cT! B%1*c a0FƇ1hCƠ<0Fa1cƨ9Qr8acƠ6 QlpsL1 caf0611 /0Fya1 c(-QY8aadCX(*$I1 caN0D1a Z!L cT($QG8a*Ec(!QAp1%vOF~ j=X堓u. |[B(Ԇ}u!.NG(Ԑ蔄BM  5&ķ5!P ZPB:Q!.P q鄅ԲPi!>ٶN\K uy!.N`($Bm Z| _=?.55_o.6ԥTB)=딊DuZE^zx~tjE\:"sNK-u"/ևD:juE]jK-uE]jH/ _$S0[ЄQ0}NŨK?\c5d䥯jʨCmy?\fԥ挼4RF]jԨKuFDuF} 6RF^zx~ߨ78s}NCmy龿QrԥfΑ豿Qtԥ֑^ujGFޑkNoAG^zoԉqTߨ=>PGzoiu#/7B>7›@RHF R$mNoAKH]j Km!yRjHjIXDPH]jK:Q.$x~E:a$SF륯:q$}N)>R_xI^zOI$u.%B5ԇBRRJR[I^J,K%u$4:Ť@fkN5ItMRI]j9Kj;C'ġ֓4:.5@RPR#J^zT3J>MH/%4$S ޜtJ]jQKI*yq_vJ8RVRJ^zi+uq%8}%mNaoI,u%2sNf/%/锖RZcNmOknK-y?Nԥ&F2.o.^?~K^zi/_}/u.5:5ġ`Љ0y0q0u!&/餘Du:1&:c"SdcNkK2y鹿N'ԥ䙼N'ԥ_k}NIy4ENNKu:&mNK_trM]jKu:Ŧ5'ǵԥf_nRMSMƛD?pW_oЀSZpkNékKu:.ԡ<\_o)KZ[Xن y B oA AA A /B^hMAв 9ȳ 9Ð2OC6䅖qA^y1އ29 <ye#rG"y%rg"/N ER OE^hيA^29{89Ƌ6 Fjdg#A^ td #y<2A ~ HqA2Aܐ HqFrw$8$% NId$&9sAܓ d%xR2Aв*Y #FAe NKq[r%>¿y Kd&81čA dg&yg2HC1\ oMql2k07.̯V(!.Ndp-: NqxBd'=A^ d'x2 A  Pq23C! .Qqr(8F5A e)H9I nRq28K] S2e)Mq -A zj)l*Pĉ nTHeW*8S9;A Re*y2cAZ Uq27ʻA,.gv9]"ra3E,.gv9Y]"ri3E,.gw9Y]"rqHE]"riHA.gv9YQ,.gw9Y]"rqHE.gv9Y] riHA嬹Ow9k]"ri3E,.gv9yHE,.gw9Y] riHE .gv9k]riHA,_(rqHE.gw9Y]"rqHE .gv9Y]1,.gv9Y]"ri3E,.gv9kYv,BA,.gv9Y?N,.gw9Y]"rpHEq.gv9Y] raFYs&ri3E,.gw9Y]"rq5,.gw9Y] riHE.gA,.gv9]"ri3E,.gv9xHE,.gw9Y] raFE.gv9]"riHA,.gv9Y]ri3E,.gv9Y]"r|ih?]"r.gv9]"riHA,.gv9cY]΢ .gv9]"rh1,.gv9]"rɻE,.gv9Y]"r^h,]Ҿr^hi9s[?hk9s[ -- r^hi9s[ s[ -- rqys[ -- rrys[An9/rry/rb9-Al9rrĖ3-g[An9rư3-g[ r bĖs[ Al9 bĖ3- Al9rrĖ3-gZ1n9rr rrĖ3- A; Al9 bĖ3- Al9rr3}.̯|x3-g[An9nõAl9 bĖs[ Al9r^hi9r b9-g[ cr bĖs[ Al9 bĖ3- Al9rrĖ3-g[An9r b9-g [ r bĖBKĖ3- Al9r3-g[An9r b9-g[ cr bĖs[ Al9rrĖ3- Al9r3sBKĖ3-g[Al9cr3c3- Al9r3-g[An9r b9-g[ r'-g [An9r3-g[ ZZ Al9rrĖ3- Al9r3H-g [Al9cr b9-g[ r RÖs[ Al9rrĖ3-/Al9rra9-g[ Al9 Ė3-g`9-g[ r}r3H-g [ cr b9-g[ Al9 RÖBn9cn۴Al9 bĖs[ Al9rr3-g[An9r3-g[ crrrĖ3-g[An9r3-g[ YZ Al9rrĖ3- Aj9cr3-g[An9r b9-g[ raĖs[ Al9rrĖ3H-AAl9/Al9rrĖ3-g[An9>-Al9ŏ.- Al9rr3-gZ1n9r b9-g[ r bĖs[Al9 Ϗo- ZZAn9ZAn9BK9- ZZAn9Bn9ǸBK9- cr^hi9BK9- r^hi9s[ -- r^hi9Ės[?hk9r3-g[ ra9-g[ Al9 bĖ3- Al9rrĖ3-g[An9r3-g[ cr by b?3-g[An9>w>Al9rrĖ3-g[An9r3m./Xg[An9r3?\KĖs[ Al9 bĖ3-煖3-g[ r R9-g[ Al9 bĖs[ Al9rrĖ3- Al9r3-g[ rư zor bĖBKĖ3- Al9r3-g[An9r b9-g[ cr bĖs[ Al9rrĖ3- Al9r3sBKĖ3-g[Al9cr3c3- Al9r3-g[An9r b9-g[ r'-g [An9r3-g[ ZZ Al9rrĖ3?QKĖ3-g[An9rưĖ3-g[ r b9-g[ 1l9 bĖ3- Al9rrĖ3-gZ,-gZr bĖs[ΠZZAl9crr b9-g8--g[An9rư R9-g[ r bĖs[ 1l9/3涿MKĖs[ Al9 bĖ3- Aj9cr3-gk3-g[ crrrĖ3-g[An9r3-g[ YZ Al9rrĖ3- Aj9cr3-g[An9r b9-g[ raĖs[ Al9rrĖ3H-AAl9/Al9rrĖ3-g[An9r3-gпե3-g[An9rư R9-g[ Al9 bĖs[ Al9rbÖ3-Aro- .j :-'.SrR[Bm9ܷSri9q鴜Bm9N)ԖS-P[N| ri9u-'.S-'>-ġri9u-'.N˩Km9rNˉKԥԖNˉKz:-P[N2m9/}k9a}\[N]jKi9y)-.ԥ\ԡ<ߨrR[N^JK_uZN|i9y)-.ԥD:-P[N:-m9u-'/=~Q^zoi9qm9y鹾QԡtߨrR[N]jIߨrR[N]jK:-'QZND_uZN} rsNˉKFSSrsN˩Km9y龿QjIQޖSr7괜Bm9nuZN} rR[N]jKoorP[NDSrR[N^zOi9u-'+zOi9񅟖?_/}Oi9uZNrcN˩Km9u)-'=->-'=괜ԖSrRZN]j˩Km9yi9u@S-'}N˩Km9u-'/=-'r<괜ԖuZN]j˩Km9y?Pm9in4-趜:ӖsN)ԖS_x[N^i9u-.ǏC_mi9tZN]j˩Km9y?NԥDtZN4m:-'ԥDi9tZN}m9y龿MԥtZN}Z[N]jKq:-.8iI~k)ԖSrcN)ԖsN˩Km9u-'/ש-'NK/N˩k˩Km9y鵿N$i9Ֆ辿NԥԖtZN}\[N]jKu:-.C,[IN䥯u:-.~ꯗ^tZNcNˉ/tZN^zi9ntZN^_rR[N^zi9u-'/]=->-.:Sr}rʴ$:S߀Ԗ^tZN}\[N^zi9u)-:}k9_rZ??]"rqHE,. riHE .gv9]"riHA.gv9Y]"rh3E,.gw9Y]"rqHE,.gw9Y.gw9Y]r.A<E<a ri`Ha r]"r]΃yv9yv9.gv9.A<E<aHa r~Fa rq r ri r]"r r]"r]΃yv9yv9z.Ӝ_΃ގu~3<E<aHaHa ri r]΃Pw9.A,.A<>\<a ripqHa r]"r]΃Y]΃yv9.gv9.A<E<7a r] r]΃Y]΃yv9.gv9.A,.A<aHa5<a ri r]΃Y]΃yv9yv9.A,.A<A<a rar]"rQ<E<a ri r]"r]΃yv9yv9.gv9Ov9.gv9.A,.A<a3a r]"r]΃^]΃yv9.gv9zy v9y v9.A,.A<E<<E<a ri r]"r]΃y]r~ri r]΃Y]΃yv9y v9z7pv9yv9.gv9'r]"r~r~Fa ri r]΃Y]΃r] rs&r]"r]΃Y]΃yv9.gv9zy v9.gv9.A,.A<.A7ri r]΃Y]΃yv9yv9.Aw9cyv9.A,.A<E<.1<.gv9.A,.A<aHa ri` ri r]΃Y]΃y]r.A .A<E<a ri r~Fa,.A<E<.1<.gv9.A<E<aHa r]"r]΃9Ȼ.?O–r^%qygq"˸Ἄ˸c27/|Y8޼8c\n^em1KyWay7̒l^el1Ky皗qyǚj^Ʃe\j^ơtqyWi^ƍeh^ą?f 4_!0ϼ13ǰ42.3(.22ǰ(s 8"s 11/s k11/s S1,10ļ;10ǰ¼#1l00"0ǰY1/c^^c]^Fc\^c\aoycזB cZai9eYaf9eYOђXaaycWa^yוcWa[9icVaW9Ye\UaT9FMETaQ9AqN9>EKLycRaI9!eQaF9eQaC9 q@9cXO^cN^cMa6,FcL^cLa/ycXKa,ycJa)9eIa&9FEIa#9q 9}cXG^qcF^ecEayWcEa,IcDayCXCa yc>Wg)!0;1 ǰ2n 02 ǰq 8~q ˰|r[wC=^Fc<^cfǼf(ZfqŋX`q {8WZq c1l/TqJ! wCnkTc)^ƍ&cX(^Ɓc'axljc&a8ee&a8Ye\%a8M%q8f2ǰFq [8Eq C˸C q +1Aq 1 /p 1/p!LǨ<10;1ǰ92.082 Ǩ6p [85p C1 /p +1Y1c1K_8yօq\8mcX^avc^UFc\˸(àp {8'pc1j /p K1 ǰ#310"1Lǰ À20zŃcn- b=8` A,/$Al"0aCA. % bL85a s ( RRæp VA + bXIJ0i A X1/0a AN )2aex%3,RgX0aR"E X!7QoHa"5AT);,RwHa ET)? bXHb"5EP!0C,RXqK"Eob ֈE#1H,)I,z! bX*HYb oJC)M bX8Fub E T(1Q,#"UA))T bXTHbbA+W,RbHbFE-[ bXrHb"ŋE/_,RX1 c"EE1c,RX1H)cZ"ŌA3g,R8Ec"5AT5)k,RİHec ET7)o bXc "5ET91s,RXбHcS"EX;)w,RX1c"5=z,RX1bX1cF~,RHd "%Al A bYH!dJ Ej!CO{A,"D bY*HYdA#TF),R8Hud E $TH) b#YHFd2uE %TJ1,R+YX2dr"5 &XL),R3Yh2d"uA 'TN),B;9dA'P,RBĆHe* e5(t]J Ej)S,'E *XT!QSY2Ue"uA +TV),R[ĸueA+kn²He?sY bfYβHeJ Eh-k[ bnY޲He"%Ej.]ư,Z bxYHe ƗE/_,RY 7E0Ta) bYH%fS"51Pc0,RY 3Ef"5E2Xe),R0ef"A3Tg),R@Hf6EUE4,RYR3fZ"ŚE5k,BbHfѿUGA6m bYrFfƛE7o bYH g"EE8qQYBL9b緟q矟 w>~ՃwB'ĥwRN]jҷSqwRN\:q'.Sq'Љ;w 5j܉oAN:q5ĥw 55ԡƝ8tN\:q.5ĥw҉;uqPN|܉;qĝԸSw҉;qĝB;N)ԸS(qL߁oqKNX׸SwRN^JܩK;u)q'%ԡƝԸ(q'?.q.5ԥƝw 5$ʟw 5$JܩoAN^J)Ը达QN};uq'/%䥉;uq5ĝtNĝwRN];uq'QNƝD@Dw[иSwRN^zF6WиS_CN]jܩK;y?\'ԥƝԸ?\'ԥƝ^uN:qPN:q'/~<\\:q'.?\'ԥƝԸ^ѸSwcNܩK;uq'sNܩK;uNƝDuN} wRN^׉;uq'F7q5FSwRN^ߨwNK;uq.5$zoԉ;w}oԉ;-hܩK;ykNܩkK:q5FSwRNFSwRN^zoԉ;nuN:q;y鹿Q'ĥwcNܩjC:q.5FSq'QNFSw7ĝB;nuN} wRN]jKoowPNDSwRN^zOԉ;uq'+zOԉ;񅟸?_/}Oԉ;uNƝwcNܩK;u)q'=q>q'=ĝԸSwRN]jܩK;&yԉ;u7@Sq'}NܩK;uq'/=q'w<ĝԸuN]jܩK;y?P;in4qƝ:ӸsN)ԸS_xN^Ӊ;uq.%ǏC_m؉;tN]jܩK;y?N'ԥƝDtNƝ4m:q''ԥƝD;tN};y龿M'ԥƝtN}ZN]jKq:q.585iI~k)ԸSwcN)ԸsNܩK;uq'/שq'NK/NܩkܩK﾿N'ԥƝDu:q':wĝԸSwcNܩkܩK;y鹿N'ԥĝĝN'ԥ_k}NIyӉ;ENKu:q'mNK_tN]jKu:q5'5ԥƝ_wRNSNƝD?pW_wиSwkNܩkKu:q.%ԡƝ<\_oq^-̯M;_P׶9˝Z;ys;yږ;ys;yBr /wr煖A^A^;xs;/,wr .wr煖A^ -˝9˝yes;ys;/,wr /w^hYA\?h[ rg;y3˝A\ r /wi3˝ .wqs; .wrg;9˝A\ rg;y3达Qr /wq3˝AZ .wqBrg;qsrg;9˝A_ rg;y3˝A;u9o˝A\ -wp3˝ .wrgm .wrg;9˝A\ rg;/,wq3˝A\ .wis; .wrg;9˝A\ rg;y3˝A\ .wq3˝ .wqs;cA^ rg;ye3辿Qr /wq3˝A\ .wqs; .wrg;9˝A\ rg;y3˝A\ r /wq3˝ .wqs; -˝A\ rg;%!/wqs;>7jY zoԲ .wqs;A^ rg;9˝A\ r .w'˝1\ .wqs; .w^hY rg;9˝A\ r /wq3˝A\Π;b9˝1\ rg;y3˝A\ .wi3˝ .wqs;A^ rg;ye3H˝1\ .wq3˝ .wrg ;)Dps;A^ e3˝.wis;A^ rg;9˝AZr煼sߦe3˝ .wrg; /wi3˝A\ .wqs; -wrg˝ .wqs;A^ rg;ye3˝A\ r /wq3˝.wis;,wrg;A^ rg;y3H˝1\ r /wq3˝A\ .wis;3\ r煖 .wqs; .wrg;9˝A\ ?,wrg;9˝AZrgk} .wq3˝ .wrg;A\rg;ܙ_u/˝k;wrĸ3qgKq煖3qg Ɲw1 b9qg ƝA;1aĸs ƝA;cwrĸ3q ǝA;w13qg Ɲw1 b9qg ŝ1;/ĝE;w1,RYHqg"ĝ5;w),RY3qg"ŝE;w),RĸHqg"ŝA;w) bYHqgƝE;wrYHB.RĸHqg ƝEK"ŝE;w;toHqg"ŝE;w!QY3qg"ŝA;n帳Hqg"ŝE;w),RY| rYHqg ƝE;w0,RYHqg"ŝE;w),RY3qg"ŝ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;w1,RY3qg"ĝ5;w),RY3qg"ŝA;w),B9qgŝA;w),RHqg ŝ5;] ƝE;w1,'ǝE;w!QY3qg"ŝA;w),RĸqgA;kn丳Hqg"ŝE;w),RY3qgŝE;w),RĸHqg"ĝ1;o;w),RY3qg"ŝA;w),B9qg"ŝE;w),Rqg"ĝ1;w) bYHqg ƝE;w1,BYHqg"ŝE;w1,RY3qg~FqgA;w) bYHqg ƝE;w0,RY/~tqg"ŝE;w!QY3qg"ŝE;w),RĸHqg"ŝA;kw);n)>ָs -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 ⟐wrĸ3q ǝAK ƝA;!|mWjγqgA;w13Hqg Ɲw1 b9qgm3q ǝ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 bs ƝA;wrĸ3qgA;w13qg Ɲw1 by% bĸ3q Ɲ1;wrQKĸs ƝA;wrtߨ%3qg Ɲw1 b9qgmw03qgA;w1 by% bĸ3q ǝA;w`ĸ3qgA;w0ĸ3qg Ɲw1 b9qg ŝ1;9 bĸ3q ǝA;wrĸ3qg,qgƝw1 bĸs ƝA;1a'"wrĸ3q ǝAĝA;9 Rø3HqǝA;wrĸ3qgA;w0Θ6-qgA;w13qg Ɲw)aĸsΠ8-q ǝA;w)3hs Ɲ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 ƝA;wrĸ3HqǝA;ŏ.q ǝA;wr3qg1;w1 b9qg]qgA;w1 b9qg Ɲ;n)|w>~ՃwB'ĥwRN]jҷSqwRN\:q'.Sq'Љ;w 5j܉oAN:q5ĥw 55ԡƝ8tN\:q.5ĥw҉;uqPN|܉;qĝԸSw҉;qĝB;N)ԸS(qL߁oqKNX׸SwRN^JܩK;u)q'%ԡƝԸ(q'?.q.5ԥƝw 5$ʟw 5$JܩoAN^J)Ը达QN};uq'/%䥉;uq5ĝtNĝwRN]jܩK;w 5$"}%)>}i񩯡q'/%䥯:q>q'/ĝuN]jܩK;uN]jK:qPN:qPN:q'/~<\\:q'.?\'ԥƝԸ^uNjK:q.5ԥƝD:q.5$z׉;w}w[иSw}NܩK;>7ĝQ;uq'7ĝԸwFwN^JܩK;uq'cN)ԸsNܩoAN]jKoԯ^uN}\N^zoԉ;uq'/7ĝԸSw=7ĝԸSwkNItߨw}oԉ;-hK:q'.uN}\NjC:q.5FSq'FS_xN]jItߨw 5$oԉ;-hܩK;uq'/=Q]JܩC;uNjܩK;y?Q'ԥƝDOԯ?Q'~N^zx~?Q'$Oԉ;w oK:q.5ԥĝ<_ƝƝ<_wRN]jK;uq.5$?P'ݸuNƝD:q.5ԥƝƝ8tNjIwRN^zԉ;uq.5@5ĝwLNq:qPN};y?N'ԥƝ?_}=`'$Ӊ;uq.58Sw}Ӊ;wĝSw%$zoӉ;76SwRNzӉ;i;uq'/ĝԸԸSq'qPNoKq:qPNq:q.5ԥƝt_Ɲ8tN:q'/=8q>q.5:趾N'$Z_WN:SwRN^zӉ;q;uq'/=ĝ?^_ڲoq':ĝ㫿^zӉ;3u:q'w҉;y鵿N'$Ӊ;ykNܩK;y鹾N'ԡƝ/~tĝƝԸtN]JCuj)ӸϨtN}wRN^zӉ;q;y鱿N'ԥĝ:Ը-KŝU;/q5?,wqs; .w^hY rg;9˝A;9˝A\ rg;q3˝A\ .wi3˝ .wrg;r /wq3˝A\ .wqs;.w^hY,rg;Y"-wi3˝EXrg;Y"-wqH˝EZ,rg;Y .wiH˝EZ rg;"-wi˝1\,rg;yH˝E珊"-wi3˝Et,Ҝg͂;w&"LD9qguZpDƝ;w&Ƹ3qg"Ή;w&"LD9qg"Dĝw&LCܙs"Dĝ;wNdܙ3p4Ɲ3ĝ;h;wNdܙ3qg"Ή;w&Ƹ3qgGW9qg"Dĝw&LCܙHsDĝ;wNdܙ3qDƝ;w&"3 qg"?ѿƝUo wF)nmi΅S׉;e?:uY_L't|Ο\ЉrN4՜h9r^+9q;q)8q3p|Nܩ?߹~w7ToYo|M)ĝ͟\6єm\hg=S?/`S5qZSw?o/VwJ5q'RSg5qNw4Di곂4qFwJ4u'BSw4gɟo|`~L5g/ԝL4j޷W \;E;l +2q Sw1s9h̟?bL݉ĝRLܩTOř8^}{ L|Cj0qSw"0us}g_]|;:s֧K)ĝK5)w.uO%h*.^-є[>E[_O߹;WZyOuSf;U=EXL)w+q}}gWNmStչRչUST;sI%TT:STSL1|ΥSI;:QYWQN%PN :PT{}u?{$N\8Ϫԝ\53E:LN$L9s$TKN|ΥjWBI5s$٫$u絾:H|I9s$>+>g#u浾:GNmΕh #^_"5WENQչ$MEչ吸S ;ŐN($TB9ۣs$ΔANGH)Tף]>:?5_;|εjGG4u笏US;ocu浾9G9s#T;N:N#T:c}r.sė\;ɹMɹwqQw7|Ɵϔ6*yO΅Sר;g}rjĝFܩiԝT4*y[_zۑjF5ZF4+u}}ncĝ2F܉bԙsݙF5ss#/Nxwjޞ+n e?_;EjbռE|6+N"+YKQS;ss"T)YE$%j^h];g}n.NDS\;S;{S>sM?_*HĝzDXߛռm͵j>Q\;eS;g}oAg NC ?ԙޛ|{\y;{s!|cޛլG\q{w7ԝP\k;{s!k{o.3ę*C$C|V!Tk}o/ĝBy_ߛB$j7⟼w uc}o.*gYߛ+ q'g u浽7_4N/zL߇e)2"'Rd".E&Rd".E>ѲKKy)2"q)r"/E&Rd".E&RD\LåD\KHKi9"q)2"'Rd".E&Rd".END\LĥD\K޵Ky)2"i)2 "hYlFZLĥFZlFZLĥFXlD\lFZlD\lFZlD\lFZLĥFZlFZLĥFZlD\lFZl4\lFZKHF3IĥF?/E`+5__jFZLĥFZlFZLĥFZlD\l6ZlD\lFZLĥFoFZLĥFZlD\lFZlȉHKHKHKKHKKHKHKHKHKKHKKHKHKmHKHKHKy)"i)2"i)"i)2"i)"q)"i)"q)"a)2 "i)"i)2"i)"i)2"i)"q)"i)"q)"i)r"/E6Rd#-E6(.ERd#-E&Rd_FZLĥFZlFZL[KHKHKHKHKHKm'KmKHKHKHKy)"i)"q)Dy)2"i)"i)2"a)"i)"i)"q)"i)2"i)"h)2"i)"i)2"i)"q)"i)"Rd#,ERd".E6Rd#-E6Rd".E6Rd#-E&Rd-E6_cHKK~폓"i)2"a)"a)2 "i)"q)"i)"q)"h)r".Ey&/E6Rd".E6Rd#-E&Rd#-E6Rd#-E&Rd#,ERd#-E&FZlD\lFZl4\l~Rd".E6Rd#-E6Rd".E6Rd#-E&Rd#-E6Rd#,ENFZlFZLĥFZlD\l6Zl4\lFZLĥFZlFZLĥFZlD\l6ZlD\lFZlD\lFXLåF-E6RD^lFZLĥFZlFZLĥFZl4\lFÏz)2"i)"q)"h)"p)"i)"q)"i)2"i)"i)2"h)".EWn;ƴOΧ1|Χ1OΧ1|Χ1,i :ƞOpΧ|cΧӘr>%ri4fOC$Fp> Xpi4Oc4֛o>Әn>fOc4fEm>l>MlNC9 ӘkNC9 4Oc9$Oc9 4Ti>4$PhNC4ӐgNC4ƙfNC9 efNC9 YXeNC9 M4"Ob9 A4cNC9 D; -Ӏb,3oC4vLC9 `NC9 4Ori/rIH/|i.!|i֧h1Ӑ\>4[>4Ԗ[NCkY4ZNCg4fPYN#d$6ӐXNCa9 WNC^9 uWNC[9 i4OcX9 ]4dOcU9 Q44ӐT>E4SNCN4ԔSNCK4PRNCH9 faPQNCD46ӐPNCA9 ONC>9 ONC;9 4Oc89 4bOb59 4뫳ɧ`rzi%Zrbih%TrJi%|3i$!,Fri($!|I#|i~B#|i"!*i~ENC9 IXDNC9 =4Oc 9 14OC 9BNB4fPANC46Ӑ@NC9 fӐ?NC8 >NC8 >NC8 4TOc8$$OC8 4Ӑ;>4Ď:>4:NB4fP9NC8 Ә8NC8 7NC8 u46N#8 e6NC8 Y4TOc8 M4$OC8 A4?Oc8 14Oc8ͯY 4tOc8$D0> 40>4P/NC4ӈ.NB1\m}m8 -NC8 X,NC8 4Oc8$Ӑ*>4)>4T)N#$&l >qi!N|iHL|i!KF*Oih!I"i GiFqQ'Dq:ħ1C q"ihq ipI!>|iH4ĆNCj4N#g$fPNHb p i ƾpI .|iH ,i !+i )p§!(pr4Z/zWϏ\np"s'Z2}b"ʼn,$z_ )NdL1b"Bʼn,*&UX1brD,&XLD8bZb"ʼn.&\t1b"DԋODQ0Nd˜14V1&"dȒ1)c"ZƉQ3&"gLD8Ac"D$4&"jLD՘q"D(6NDۘ1uD捉8&p|8&qLD8c"2Dt'tLDꘈq"cDԎ;Nd146o'{LD1DQ?Nd1d" ȉL @&"|EA&"LDr"J4h!'2Lkr"DH"DNd*2YDv#QF&"62qd"ȉ#ӼOdD&h$INd%L2d"B'Zd"RD%'LD.^r"DH&LNd4Hj2 Dti'QN&"v2d"ɉ'O&LCA9 e"DD('2LDGr"KDh) S>͢)SȠ2Ee"D4U&LDV9]eD?] ʉl+W&ȼ2ѯqZe" ˉL,X!L$e9e":DYZ&"LDkr"kDi-26-26-2e"ˉ.^&LDz9e"4ԗ/'LDs"D40IaNchf9%f"RD1'LDs"DH2d>͂2Qe&"LD9af"Df&LCHN}\q'/}ŝCg.ԥN]*d;up]ܩẸSQq'_uq'/}p}sN\k.ԥN]*䥏ẸS;yŝTܩKŝ^uq.w2:uqNF7N} ;u7N]*d{.*ԡNߨ;u;ys.]KTܩKŝF]ܩS߂N]*SWKSoŝQwRq'QwRq.wF]m.dQw[PK.䥳Qw;u^uq.wF]ܩS_xq.w2zߨ;w2zߨ;-(ԥN]*_ow;uY;uS;y?QwRq'o_ŝD]}.TTܩ/D]ܩKŝC*ԇw_;uS;y)S;uN6uqN^zŝ;ŝTܩKŝt.ġN6S;yŝTܩKŝN6o4S_tqw2?Nw**>Nw8]ܩKѲܙ˝ܙ˝y3;qs"/w&rg".w&rD\LD\˝ܙH˝i9;q3;'rg".w&rg".wND\LD\˝ܙ˝y3;i3 ;hYlFZLFZlFZLFXlD\lFZlD\lFZlDZlFZLFZlFZLFZlD\lFZl4\lFZ˝~^mW߉9q;i3;W#-w6rg".w6rg#-w6rg".w6rg#-w&rg#,wrg#-w&rg#-w6rg".w6z./w6./w6rg#-w&rg#-w6rg#-wNFZlFZLFZl4\lFZlD\lFZLFZlFZLFZlD\lFZlD\lFZlDZlFZLFZlFZ˝H˝H˝H˝H˝ܙ˝H˝ܙ˝˝iH˝H˝H˝H˝H˝ܙ˝H˝ܙ˝H˝y;i;i;i3;(/w6rg".w6rg#-w6rg".w6rg#-w&rg#-w6rg#-w&rg#-w6rg"-wy۟(.wL".w6rg#-w&rg#-w6rg#-wNFZlFZLFZlD\lFZlD\l6ZL6ZlFZLFZlD\lFXlD\lFZlD\lFZLFZlFX˝F˝H˝H˝H˝ܙH˝m9ZLFZlD\lkH˝˝m˝iH˝ܙ˝H˝ܙ˝F˝q6y;q;i3;i6y3;a;i3;i;q;i;p˝H˝H˝H˝ܙ˝H˝9;i;i3;i;q;h;p;i3;i;i3;i;q;h;q;i;q;a3 ;gH˝y;i3;i;i3;i;p;?D\lFZLFXlN\LFZlFZLFZlD\lFZlDZlFZ|_; Ή;hwNd9qhÝwNd9q-s"Ή;hwNd9qwNc9q-s"Ή;1|wNd9q-s"Ήމ;'2|wNd9qDƝOΉ;'2|wNd9q4Ɲ w&"LD9qg"Dĝ;'2L$ܙs"Dĝ;wNdܙ3qg"Ή;w&"ȸ3qg"Dĝw&"LD9qg"Dĝ;1LDܙ;r?/؜s"Dĝ;'2LK33qDƝ;w&"ȸ3qg"Ή; w!LD9qg"Dĝw&zw&"ȸ3qg"Ή;w&zw>т;w&"LD9qg"Dw&"LDܙs"Dĝ;'2LDܙ3F-3qg"Ή;w&"LD9qg"Dĝ;'"LCܙs"Dĝ;w>т;w&"ȸ3qg"Dĝw&"LD9qg"Dĝ;'2LDܙHsDĝ;wNdܙ3qg"Ή;w&"ȸ3qg"Dĝw&"LDD LDܙ3qDĝi;wNdܙF-3qDƝ;w&"ȸ3qg"Ή;w&"LD9qg"Dĝwy۟(4ĝw&"LD9qg"Dĝ;h;w&"ȸ3qg"Ή;w&"LD9qg"4ĝw!LDܙs"Dĝ;'2LDܙH3 qDƝ;w&"ȸ3qg"Ή;w&"L$4 L$ܙs"Dĝ;wNdܙ3qDĝi;w);'2LDܙs"Di;'2L$ܙ3p4Ɲ;wNdܙ3qg"Ή; w!|"4o۴Dĝw&"LD9qg"Dĝ;'2L$ܙ3qDƝ;wNdܙ3qg"i;ߌ;'2LDܙ3ѧDƝ;wNdܙ3qg"ΧYpg"Dĝ;'2LDܙs"Di; wNcܙ3qDƝ;w&"ȸ3qg"Ή; w!LD9qg"Dĝ;'2LDܙHsDDĝODĝ;'2LDܙ3qDƝ; wNcܙ3S ȸ3qg"Ή; w!L$9qg"Dĝ;'2LDܙs"Dĝ;wNDܙ3q矈Ko,aWݼhZE'ԥZN]˩b9uĥk9r"SQ-ZNErе:TˉKr*rg,']ˉKrR-'.]ˉKrR-ZN|ܵt-.rR-'.]ˉKr*Dt-ZNEjj9|?_b9?Sj9y)b9uSb9y(Sj9uQ,'?.Sj9ub9y)SQ-'aQ,ZNFrR,ZNFr ԥZN^䥱:T˩Cߗ~`+/p-'k9y)Sj9uQ,ZNF/˩oA-.rR,'/}׵ZN^k9u)p]˩KT?\rR-'/ẖSQ-'u-ZNFZN^ҵt-'p]˩KTKu-rrR-.r2zoԵToԵj9ߨk9-ԥZN^zߨk9u>7Sj9ycԥZN^w-'/rR-.r2:u-ZNF7ZN} j9u_oԷ>7ZN}\-'/7ZNSj9uߨk9uSj9ycdQr2ߨk9-F]ˉKrߨk9q:TCSj9y}TTF]˩/Sj9oԵj9oԵoԵTKި.rP-'>QrP-.rkԥZNF=QFu-'k9yD]˩S_x-'/Sj9u)^ U˩䡳PrR-.rR,.rR-'l>ZN}ݵk9r2zk9uSj9yT-']ˉCl^u-.rk9uSj9y?Pli,ZNd{TT˩/ZN]ԥXN:=Ng{d?NrR-.rk9uqQ-'m߀k9uQ,'6]˩/ZN]ԥXN:t->Sj9ycԥZN^:T˩,b9r8]˩qSj9uשġk9yZN]䥏u:]s}>j9ӵT˩KtZN}\-.rkԥXNzu?b9_k9ysԥ|Kt-'_k9E_ˉKr:]muSj9y鵾NrP-'/?z->Sj9y鵿NrR,'S-ZNF_k9 ԥZN^_k9qtZN]ԡZNz//}g9߾rNdDȖs"[Ήl9DȖs"[Ήl9hrNdDȖs"[Ήl9Ȗs[Ήl9hrND9--s"[Ήl9hrNd9--s"[Ήl9'|rNd9--s"[Ήh9m3-g"ZΉl9r&LD9-g"Y4r&LD˙s"[Dh9rNd˙3-Dh9r&Ȗ3-g"ZΉl9r&L$9-g-OL3ghh9Oɉh9'LD˙s"[DAh9rNd˙3-g"ZΉl9r&Ȗ3,gZDZDh9'L?\LD9-g"ZDr&LD˙˙3-g"ZΉl9r&Ɩ3-g"ZDr&LD9-g"ZDh9'LD˙s"[D7jr&LD˙s"Z4h9'LD˙3--3-g"ZΉl9r&LD9-g"ZDr&LD˙s"[Dd9LD˙3-Dh9r&Ȗ3-g"ZΉl9r&LD9-g"ZDOXDh9rND˙3-D~ob9rNd˙3-g"ZΉl9r&Ȗ3-g"ZDZDh9'L?Qih9'LD˙s"[D^h9hh9r&Ȗ3-g"ZΉl9r&LD9-g"Y4rLD˙s"[Dh9'LD˙H3 -Dh9r&Ȗ3-g"ZΉl9r&L$4L$˙s"[Dh9rNd˙3-Dih9v)h9'LD˙s"[Dih9'L$˙3,4h9rNd˙3-g"ZΉl9r|"[4o۴XDr&LD9-g"ZDh9'L$˙3-Dh9rNd˙3-g"Yil9l9'LD˙3-Dh9rNd˙3:r>b9r&LD9-g"ZDr&LC˙Hs[Dh9'LD˙3-Dh9rNd˙H3 -g"ZΉl9r&LD9-g"ZDr&r&|r&LD9-g"ZDh9'LD˙Hs[DR],Dh9rNd˙H3 -g"Yil9r&LD9-g"ZDr&LD˙s"Z4h9DL,r~7Љĥk9uSj9r*XN]ĥk9qZNETT˩SQ-'8t-rҵj9q:TˉCrҵTˉKrҵT˩w-'.]˩KTˉKrҵj9]˩Sg?TwqTKw˩KC:T˩Kb9qT˩KKj9Ì>tQ,˩F}k9ub9y7f-iWx|,'k9rXN]ԥZNFj9b>\_,TK?\rj9ycԥXN:u-.rR-'p]˩KtZNE~׵j9k9y㯇Krҵ^u-.rR-'/}׵:TKgԥZN]dߨk9uߨk9r2Qr[P˩KQrR-'u-'/}oT-rF]˩KKu-'>ZN^ԥZN]dt7ZNE~oԵrR-'/ިo/}oԵZN^zoԵ:TKu-.rR-'QrR-.rF]mdQr[PK䥳Qrb9u^u-.rF]˩S_x-.r2zߨk9r2zߨk9-ԥZN]_owb9uYk9uSj9y?QrR-'o_D]}TT˩/D]˩KCԇr_k9uSj9y)Sj9uXN6u-ZN^zԵj9ԵT˩KtġZN6Sj9yԵT˩KZN6o4S_t-r2?Nr*^Kt-.rR,'o}=`r2zk9uSj9yӵT8]ˉ6]ˉoT(k^Kt-.rR,'qSV˩K?NrR-'/qTShV˩StZNE~ӵT˩KN8t-']K/rR-'/}ӵZNFQ}ԥZN]䥳Nrj9u^t-.r_ӷ>X:]Kt-.}^X_k9g:]ˉ/ZN\>ZNFot-'/}ӵTKuSj9y)k9qTKuSb9y}j9r2gT:]˩o@-.r:]˩䥳NrR,rk}XΟ/}}3\_ebT)Kb?\xcӥ1:u.ՑR)p]PK5et2Ee~%fkx㯇KWEg^u.UR/}oeh:TKgGӥ4]Jcߨkt<ߨթ1QW[PK5kQWRu /}oT!ղF]ѦKEmKuu>7^qӥ27]tct7z7E%o~oԅoԾR/ިo/}oupR8^zoq:TKue.R}QWR.F]1mcQW[P@K㥳QBt^um.F]dΎN_x.1zߨ+1zߨK-ӥB<]_ow"t(YKt:O x?QRod_U{D]}.STǧ/D]ЧK5}C*Ӈ_tOjx)O*tѸ?6u@^ze*TKUt6.ġ A6NPJyT3KeA6o4P_t2?N*(^TKti.UR!o}=`W2z uPyӵT~8]6]oT(,k.N^Kt.*R"qbQVKu?NW/R#/q*cTShVϨQUtFE卌~ETKN8t#]K/.~?R $/}ӅrHFQ}.ԥH]*䥳NI*%uX^tɤ.EM_ӷ>X>:]DKt).}^X_k*g:]\/J\Ē>BKFot%/}ETwKuR 0y)0qTKu$S2y}j3Քg2gT:]o@.Uk:]+䥳NoRpk}@Ο/}}M%DKͻDK'Zq.'qo"%^"MEDK]Dƛxi8yy&/i,/ &d^"%pDKD\KSzzyS/gqYo"%^"M-C{Hs{H{H{|m3|Hc|Ǘ|H|͗|H#}HS}H}H}ܗ}?0J5yK4k-Fȋ~4HFKuFkDk럟[4H{8H4H8H 4;0Fk44 Hˀ8m<H+8H[44H48i@6iF0iLpRViX'U8/H 42;45Hk484;H˃8>H4AH+8DH[4GH!64a"6@a#m6LD^*lF+LFZ-lF.LFZ0lD1l)FZ3lAD4lYFX6LqF7rCuHsx{HӇ~HH3Hc8'ii1h!Fq'ѯZb# &&fb#&6rb#'&~b#M(6Ҋb")6Җb#)6(*6Үb#M+&Һbb,&b#-6b"N.6b# /6D_lFalDbl5FdLMFeleFgL}FhlDjlFklDmlFnLFpl 6qL%Fsl=FtL\[aFvLyFZxlFySFHH㏉HHCmǍZLQFڅliD\lkH3cmiHÑ󑍴 H#>S&FqS6yY%q_&&ie2&ik&iq2G'aw'i}2(if(q(i&)p۔8OH 4RH;8UHk4X4[H˕0^9+i²V,i2,iβ-qԲv-hڲ-p಑6.i2.i첑.i2W/i/q0hv0q 0i611a3 1gHCy+2i13G3i73i=34iCf4pI4?ID\laFLyFXlFLéFZlFLFZlDl FZl˩Kl9FZ|eۿ69--s"[Ήl9'ms"[Ήl9'|rNd9--s"[Ήl9'|"[il9'|rNd9-4OXΉl9'|rNd9-DOXΉl9'Ȗ>l9'Ȗ9-Dr6˙3-Dh9r&Ȗ3,gZΉl9r&LD9-g"ZDh9'LD˙s"[Dh9rNd˙3ϖ'9KD˙3,4h9r>b9r&⟒rNd˙3-D~/r&Ȗ3-g"ZDr&LD9-g"Y4h9'LD˙s"[DoõXDr&LD9-g"ZDh9hh9r&Ȗ3-g"Yil9r&LD9-g"ZDr&LD˙s"[Dh9'LD˙3-Dh9r&?LD9-g"ZDh9hh9rNd˙3-g"ZΉl9r&Ȗ3-g"ZDr&L$9-g_XDr&LD˙s"[Dh9'LD˙3-Dh9r>b9r&:XΉh9r&Ȗ3ѯZ,g"ZΉl9r&LD9-g"ZDr&LD˙s"[Dh9'L?Qih9'LD˙s"[Dh9r>b9r&LD9-g"ZDr&LD˙s"[Dih9'LC˙3-Dh9rNd˙3,gZΉl9r&LD93-Dh9r&|r&LC9-g"ZDh9'LD˙s"Z4~r&LD9-g_XDr&LC˙Hs[Dh9'LD˙3-Dd9r>-gmZ,g"ZΉl9r&Ȗ3-g"ZDr&LC˙s"[Dh9'LD˙3,4or&LD˙s"[Dh9'LD˙3,,3-g"ZDr&LD9-g"Y4d9LD˙s"[Dh9rNd˙3-Dd9r&Ȗ3-g"ZDr&L$9-g -g"Z'Z,g"ZDr&LD˙s"[Dd9LD˙)rNd˙3-Dd9r&Ɩ3-g"ZDr&LD9-g"ZDh9'LC˙OYDorrNdDȖs"[Ήl9DȖs"[Ήl9hrNdDȖs"[Ήl9Ȗs[Ήl9hrNtV|rNd9--s"[Ήl9'|rNd9-DOXΉl9'|rNd9-4r&LD9-g"ZDh9'L$˙s"[Dh9rNd˙3-g"ZΉl9r&Ȗ3-g"ZDr&r4+99-g"ZDd9LD˙˙3s"[Dh9'LK3-Dh9r&Ȗ3-g"ZΉl9rLD9-g"ZDr&zr&Ȗ3-g"ZΉl9r&LDDLD˙3-Dh9rNc˙3-g"ZΉl9r&Ȗ3-g"ZDr&LD9-g"ZDh9'LD˙3-Dih9rNd˙3-gZ,g"ZDr&LD˙s"[Dh9'LD˙3-Dh9rNc˙3-g"ZΉl9r&LD9-g"ZDr&LD˙s"[Dh9hh9Z,Dih9rNd˙F-3-Dh9r&Ȗ3-g"ZΉl9r&LD9-g"ZDry۟([4r&LD9-g"ZDh9hh9r&Ȗ3-g"ZΉl9r&LD9-g"Y4rLD˙s"[Dh9'LD˙H3 -Dh9r&Ȗ3-g"ZΉl9r&L$4L$˙s"[Dh9rNd˙3-Dih9v)h9'LD˙s"[Dih9'L$˙3,4h9rNd˙3-g"ZΉl9r|"[4o۴XDr&LD9-g"ZDh9'L$˙3-Dh9rNd˙3-g"Yil9l9'LD˙3-Dh9rNd˙3-g"YΧY,g"ZDh9'LD˙s"[Dih9}Ӈ-g"ZDr&LD˙s"[Dh9'L$˙3-Dh9r&Ȗ3-g"Yil9gh9r>b9r&Ȗ3-g"ZDr&L$9-g"ZDO.s"[Dh9'L$˙3,4h9r&Ȗ3-g"ZΉl9r&LD9-gZDr&z7??Sj9qZN\Sj9qZN\Sj9rĥk9uSj9qZN\SQ-'k9r*TSw(rR-'/rR,.rR,'rP-.r2rR-.rR,'/r*d? 3TT(S߂ZN^KZ~`r꟦Sj9y)rP-rR,'.](w-'/rR-.r2TTEb9-ԥZN^ẖSWKu-.rk9uSj9ZN]䥳?\r*d{TTp]K=\\dߨk9uSj9yc}ԡZN^:u-.rR-'F]˩KF]˩S߂ZN]Sj9ߨk9ysj9u>7ZN]XN^ߨk9qrR,.rR-'Qr*d{ԷSj9yF}{crk}ԡZN^zߨk9uSj9Sj9u>7ZNFou-'S߂ZN^zoԵt-'/S˩C<ߨk9u7ZNE~oԵk9uF]˩F]˩oA-.rR-'/z˩CD]˩CTKSj9D}}OԵ¯_OԷ>'ZNFu-ZN}ᵜt'ZN]ԥXNz/T->B]˩KTKT˩Krk9urkTT}ԥZN]䥳?P8t-'ryԵTKgԥZN]@ryߧk9uqSQ-ZN^zk9uSb9y8}{8]˩KTKgԥ_T?NlZN|ԥZNF^t-ZN^zߦk9uSb9yӵZN]䥏qSj9yS-ZNFZNEǯ䥳?Nr*d{ԥZN]uġk9qZN^z9p->Sj9ycdNr2\_ZNFt-.rR-'/uSW˩K_k9u)z="XNFZN^_k9u_:]h?sZN|rҵNr2z_k9ysԥZN^zӵ:TKO^˩ԥZN^zӵCT˩?msԥZN^_k9qtZN]Nrk}XΟ/}};/]DȻ~i3w9q]DL]DȻ˙y3w9q3w9'.gr&.DL]DL]Ή˙9w9q3w9qs"r&.g"r&.DL]DȻ˙HiD.g#r6.g"r6.g#r6.g"r6.gr&.g#r6.g#r&.g#r6.g#r&.g#r6.g"r6.g#r6q'9c~i3w9iv9a3ͧv9iv9'.g#r6ҿv9qv9i3w9W#r6.g"r6.g#r6.g"r6.g#r&.g#r.g#r&.g#r6.g"r6z.r6.g"r6.g#r&.g_]FȻH˙iHHH˙ow9qv9i3w9iv9i3w9iv9i3v9hv9qv9iFyv9i3w9iv9i3w9iv9qv9iv9qv9a3 w9iv9i3w9iv9i3w9iv9qv9iv9}jv9is"r6.g#r6.g"r.g#r&.g_]FL]Fl]FL]Fl]Dl]Fl]Dl]FL]6o]6L]Fl]Dl]Fl]ΉHHH˙H˙FFBy3w9iv9qv9av9qv9iv9qv9i3w9iv9asr6.gr&.g#r6.g#r&.g#r6.g"r.gZh3w9iv9qѯq.g#r&.g#r.g#r.g#r6.g"r6.g#r6.gOr6.grN]6o]FL]Fl]DlkHmHH˙H˙oL]FltɻH˙H9w9iv9i3w9iv9qv9hv9pv9i3w9iv9i3w9iv9qv9hv9qv9iv9qv9a3 w9gHyv9i3w9iv9i3w9iv9pv9?]Dl]FL]Fɻ˙H˙HHH>FD.gos"['Z,DrNd',DrNdDȖs"['Z,DrNdDrNdDȖs"Zil9hrNdDȖs"[Ήl9hrNd9--s"[Ήl9hrND9-hh9rNd˙3я'Ȗ3,gZΉl9r&LD9-g"ZDh9'LD˙s"[D~?1ʟl9r&Ȗ3-g"ZDr&LDDLD˙JND9-g"ZDr&JD˙s"[Dh9rNd˙3-Dd9r&Ȗ3-g"ZΉl9b9rNd˙3-Dh9r&|r&LD˙s"[Dd9LD˙3-Dh9rNd˙3ߨrNd˙3-Dh9r&Ȗ3-g"ZDrLD9-g"ZDh9hh9rNd˙3-g"ZΉl9r&Ȗ3-g"ZDr&L$9-g"ZDh9'LD˙3F-3-g"ZΉl9r&LD9-g"ZDOXDh9rND˙3-D~ob9rNd˙3-g"ZΉl9r&Ȗ3-g"ZDr&LD9-gLC9-g"ZDr&LD˙˙3-g"ZΉl9r&Ȗ3-g"ZDr&LC9-gZDg9-g"ZDr&L$˙s"[Dh9rNd˙3-Dh9r&\r&LC9-g"ZDh9'LD˙s"Z4~r&LD9-g_XDr&LC˙Hs[Dh9'LD˙3-Dd9r>-gmZ,g"ZΉl9r&Ȗ3-g"ZDr&LC˙s"[Dh9'LD˙3,4or&LD˙s"[Dh9'LD˙3,,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˙OYDor__,7j9Mt-'.]˩KT/SQ-rR-'.]ˉKr*Dt-ZNEj9-ġk9uTTˉԡZNԥZN\ԥZNEk9qZN]ԥZN\TTˉZNEb9rb9r2z\-.rgrR-.rP,rR-'XN~\,.rR-'/rR,ZNF0r2oLOTT}}XNSj9y)rP-rR,'.](w-'/rR-.r2TTEb9-ԥZN^ẖSWKu-.rk9uSj9ZN]䥳?\r*d{TT׏ח}ĥk9qZNFSj9u>7ZN䥳Qj9uSj97ZN]dt7ZNE~oԵrR-'/oԵTF]KU˩C^u-rF]˩KToԵT˩KQr2zߨk9}oԵrkĥk9yoԵXNF]˩KQr*d{^˩K7ZNE7ZN} j9uSj9yݥXNdt'ZNԥZN^zOԵT'c~-'/z?Qr2zߟk9r 䥳?QrR-.rkj9aXN-rjKuб:K/rjKu:m}dNZNFu:SKZcrjKu:SK{~zXc:˩_q鵾Nr2gt,'c9t,'^t,':ɥu:SK\zӱҿ)c9qZsR,'T˩Q1zӱrjKu:SWɥ:˩XN rr蹾N_,/K?YþYΉl9hrNd9-hrNd9--s"[Ήl9hrNd9-rNc9--s"[Ήh9弢rNd9--s-Dr^b9'Ȗs"[+Z,Dr^b9'圈s[?f9r&Ȗ3-g"ZDr&LC9-g"ZDh9'LD˙3-Dh9rNiW_"ZDr&LD9-g"ZDd9LD˙˙3s"[Dh9'L[3-Dh9r&Ȗ3-g"ZΉl9rLD9-g"ZDr&b9rNd˙3-Dh9r&弢r&LD˙s"[Dd9LD˙3-Dh9rNd˙3-g"ZΉl9r&Ȗ3m˙s"[Dh9rND˙3-Dh9r&弢r&LD9-g"ZDh9'LD˙s"[Dh9rNd˙3,4h9r&Ȗ3-g"ZDr&LD9-g"ZD Dr&LDyELD˙3-Dih9rNd˙F-3-Dh9r&Ȗ3-g"ZΉl9r&LD9-g"ZDrO-gZΉl9r&Ȗ3m˙˙3-g"ZΉl9r&Ȗ3-g"ZDr&LC9-gZDh9'LD˙s"[Dd9rNd˙3-g"ZΉl9r&Ȗ3-g"ZDWXDih9'LD˙3-Dh9rND˙3KA9-g"ZDr&?NLD9-g"Y4d9LD˙s"[DXΉl9r"[4mZ,g"ZΉl9r&Ȗ3-g"ZDr&LC˙s"[Dh9'LD˙3,4or&LD˙s"[Dh9'LD˙3,,3-g"ZDr&LD9-g"Y4d9LD˙s"[Dh9rNd˙3-Dd9r&Ȗ3-g"ZDr&L$9-g}3--3-g"ZΉl9r&zb9'LD˙Hs[DO.s"[Dh9'L$˙3,4h9r&Ȗ3-g"ZΉl9r&LD9-gZDr&'߿|?lTDrbXN-rj˩}ZұX:SQ-'c9r*TTˉoA-'P-'TTˉP-'ұZұX:SKj9qrbXN-rjKrbXNETT˩(SM-~d\-j9b9T˩XNrjSKb9qZR-'b9˩Q0;9Srr)SQ-'p}k9TɥXN.P-j9ˉc9rR,j9T(SQ-'>\_,ZR,'>XN}\-'^u,b99c9T˩ZNF:SK\zױj9}ױj9ߨc9Ft,'dߨc9T˩ZN.7XN rr鱿QrjSKu,j9=7XNE>7XN} j9TɥF˩ZNFu,'>7SCzoԱZR,'>7XN|ܱ\R-j9=7XNE>7XN} j9TɥǷ7ǥF˩s}P-'u,j9T豿QrjSK\zoԱnu,':S߂ZN.=7XN,ɥF˩P-'u,j9tߨc9r2ߨc9rj}TT趿Qr[P˩ZN-rri)SCu,j9TɥD˩ZNFoOԏk~,'ߞ>'XNF:SQ-ZN.='XN-rj)Cԇrr豿PrjSK\R-j9dc9urr?Pr*dtc9T˩ZN.=CrbsR-'u,j9Tɥ@rXN}ѵd?Nr*^ɥ8˩ZN-rrqq?NrjSK\zӱZd>Nr"dsߦc9 8SKb9=XN}ᵜ\oӱZR,'t,>SK\zӱZcj9r2Zr*?~-'t,ZNFt,j9Tɥ:rbXN ɥrj9Tɥ:趾Nr2\_W-':˩ZN-rr鱿Nrj9Tɥ:˩XNݿN?~m,dNrrsZ_c93>XN,ɥ:趿NrrsR-'t,j9/~JXN}\-j9_c9ɡ:rdgTt,Zkrr鱿Nrj)SCz~~^9 %rNC9 4TqNC9 4Wc9 4Wc9 4Ӑn^ $m^4TmNBy5&PlNCy5ӐkNC9 jNC9 4Wc9 4TWc9 4"PhiF>3x4ԙi3f͜23 `fi2HeL#9 If4i1!L^cfZ4i$1bNCF 34Did0ӈ`3e˫L#|FM#z9 e4rӐ]I#tFr4i.[NCnF24i@-HZ2e)i,֧24i+ӈWNC]F2leʫL#XF2X4Ti*TNBRF2@eyi)HS2(eI4QL#E9 e4"i$(!L#?F|2O&L#:9 d4ri&j2diH&HLL#/9 di4’JL#)FPr:4bi$'!L##FD24i#ӈG82ldi(#FL#9 Ud42Wc-F 2<4I!CNC XB2d)4B@L#9 d4i!~L#Fq$ѡ{L"8 c42Ӑ:i$:NCF1c!ihӀ8&pF1|c4ҍ7mL#8 ec4pIjL#ԘF1H4i3NCΘF10cX+1eLɘDq:4bi1NCØF14In@zq4iD\L{}nӈ-NCh1bI(,W\1ba4Ӑ*TL"x5tInkcFHq4"i$!PL#F<1t4ĉi`&L01\bi%IL8 Eb=4i#E1$bAiӈ!BLx%6iDH @0ai&=Ly8 a4bP:L#sFp4i !7Lsc4Ӑ4L#hFp24Ri '1LH04i !.L#[F0d4i ӀNBU涾76iD (L#PFpr4ЄI NBJF0 a9iH"0a 4&L#=Y`_/x:V9X:~PKZ |*!|q_t!#TTHHBEj [PM 5TO UJ 5TS tT t\!,ReB|ܱX:PKՅZ*/X:PQ!C *zڇ 0K_!* \z~~Z6R! 5TpCF!C-jKa\;TTx*̯̟{9¹D}>RCF" jKA\2D !r)KG"2 Eȥ`D-U#jQ7F} jTȥǷ7ǥFߨ+ps}qP#uT豿QG:jQK\zoюnu#:Q߂G.=7G,ȥF |P#u죖tߨ?2ߨ# @j}TT趿QB[P RH-Bri)RC同u@*"TɥDHFoOԏk~d$ߞ>'HF:9DN3W܉ȇ"'ȉ|*[XDyE˹ȉ|/r"#DDG#'D<w#pDH#vD>#|d"ޏ$d'$ Jȗ%?-%ɉ|G2I&%D<%9oI&1D&9I&=D<(H%ID)G%h*観_6JÒd"Lےd߿Jx_r"L xb2oLN#xe2LN;th2cSd"Lkdp-'D>97'D:g'd"d"Lۓx|r"_LtrL x2oPN#x2PN;x2/Q&)ʉ|2Q&5ʉ|2Q&ADH9OR&MDkw-Dl?Qm-'uDHw3pf"^Μȧ3vf"Ϝ3|f"LfohN#xE3h&͉|H3/i&)͉|K3i&5D:y5=D<5DG5D>Hw5f"]֜Ƨ5f"ל5f"Lf"Lf"]L3xgs"LKxj3:-6f"ۜ63'7hG7D>w7f"^ޜȧ7f"ߜ7fSΉ|3Op& Ή|3pD9q&%D<ř8'1Dƙ8'=D<ș豿NIΉx3 r&U?v38,3-Dh9r&弢r&LD˙s"[Dh9'LD˙3-Dih9rNd˙3,gZΉl9r&Ȗ3-g"ZDr&LD˙s"[Dh9'LD˙H3 --,g#YDd9r6LD,g"ZFd9r&lraN&-g#YFh9r6l$˙,g#YDd9r6LCH,Dd9Oɍd9r6l$˙oEP#YFh9r6l$˙,g#YD`9r6LDH,g"ZF78Fd9r6l$˙,g#YFr6l$H3-g#YFih9r6l$˙,g#YDd9r6LDH,g"ZFd9r&l$H,g"Y6d9r6l$Hs"[Fd9r6l$H3-g#YFh9r6l$˙,g#X4d9r6LDH,g#YDd9r&l$H,g"ZFd9'l$H,g"Y6d9r6Qd9r6l$H3-g#YFh9r6l$˙,g#YDmnEF3-g#YFh9r6l$9-g#YFd9r6l$˙,g#YFh9rL$F,g#YDd9r&l$,g"ZFd9}-g#YFh9r6l9-g#X6h9r6l$˙,g#YDmd9h9r6LD8r6LD,g#X4d9r&l$H,g"ZFmd9'ls&[Fh9r6LDH,g#YD`9r6LDH,g"ZFd9rl~LDH,g#YDd9r&l$H,4d9r6LDH,g"ZFmd9rl$H3-g#YFd9r6l$˙,gYFh9r6l$˙,g#X4YFr6l$˙,g#YFh9r6LCHѿ)U[Dd9r&lF,gZFd9r&l$H3-g#YFd9rl$yEltO&,DWXΉl9'ȖOYΉl9'Ȗ9-DWXΉl9'Ȗl9Ȗ9-Dr^b9'Ȗ9-Dr^b9'Ȗs"[+Z,Dr^b9'圈s[?f9r&Ȗ3-g"ZDr&LC9-g"ZDh9'|4+u-g"ZΉl9r&Ȗ3-g"ZDr&LD9-g"ZDd9LD˙˙3s"[Dh9'L[3-Dh9r&Ȗ3-g"ZΉl9rLD9-g"ZDr&ob9rNd˙3-Dh9r&弢r&LD˙s"[Dd9LD˙3-Dh9rNd˙3-g"ZΉl9r&Ȗ3-g"ZDr&LD˙s"Z4h9'LD˙Y˙3-Dh9r&Ȗ3-g"ZΉl9r&LD9-g"ZDr&LD˙s"[Dh9rNd˙3-Dh9r&Ȗ3-g"Z+Z,g"ZDh9'LC˙s"[D7jh9'LD˙3-Dh9rNd˙3-g"ZΉl9r&圈3ml9rNd˙3-Dh9r&弢r&LD˙s"[Dh9'LD˙3-Dd9rND˙3-g"ZΉl9r&Ȗ3-g"Y4r&LD˙s"[Dh9'LD˙?PWXDih9'LD˙3-Dh9rND˙3KA9-g"ZDr&?NLD9-g"Y4d9LD˙s"[Dh9rNd˙H3 -rob9rNd˙3-Dh9r&Ȗ3,gZDr&LD9-g"ZDd9L~Ȗ3-g"ZDr&LD9-g"ZDd9fh9r&Ȗ3-g"ZΉl9ry쯓-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&yoX tZD_ȉұZR-/SQ-b9Tˉc9t,ZNDr*TT˩߂ZN ˩ZN,˩W˩ZN ˉc9Tˉc9t,j9rұZR-'ұj9˩SQ,Z߁/(rjK\R-b99˩ZN-r2rs ̯,|-ZN.r*d?!3TT(S߂ZN.r*dt_/S_x-j9ɥP-'b9t,'XN|ܱ\R-j9r*d{"}}XN} j9TɥXN.}ױZN.XN-rr?\rjSKorjK:SQ-':SQ-'u,'^ިұu,j9TɥF˩ZN.=7XN-rjsR-'F˩F˩oA-j9tߨc9TcFrjC:SK\z̿Fˉ;KZR-'F˩F˩ou,'ި^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}dKu:SKs}XK_,?~l˙w9']D˙w9.-w9.g"LĻ.g"LĻ.g"LĻxs"Lûxs"LĻt3 rN仜x3rN仜x3r&]Ή|3r&]D9r&]D9r&]D˙w9hHw9.g"ltr&]FFw9tr6z̯ԱD8%]FHw9.g#lxr6z|Oxr6]DHw9.g#LûtrN仜tGt3r6]F˙w9?Hw9.g"ltr&]FHw9.g#lt3r6]F˙w97w9.g"lt3r6]FHw9']FHw9.g"lp3 r6]FHw9.g#lxm|r&]FHw9.g#lt3r6]FHw9.glxr6z?kt3r6]F˙w9.g#lxr6]F˙w9.g#LĻtcxslmt3r6]FHw9.g#lnFw9=Bw9.g#lxq]F˙w9.glixr6]DHw9.g#LĻprNĻmn仜t3r6]F˙w9.g#lxr]F˙w9.g#LĻtr6]4hƻxm|r&]FHw9.g#lpsltr&]FHw9.g#lp3 r6]F˙w9.g#lxr6]Dw9.g#LĻtr6]DHw9.gl.g#w9.g#LĻtr6]DHw9.gr6]FT}3r6]F˙w9.glixr6]F˙w9.g#LĻtr6]DFw9.-w9]οcr^b9'Ȗs"[?f9'Ȗs"[+Z,Dr^b9'Ȗs"[+Ɩs"[+Z,D7ZΉh9弢rNd9--s"[Ήl9'弢rNd9-DWXΉl9'弢rNd9-4r&LD9-g"ZDh9'L$˙s"[D-;_x~h9'LD˙3-Dh9rNd˙3-g"ZΉl9r&Ȗ3-g"ZDr&LDyELD˙JND9-g"ZDr&JD˙s"[Dh9rNd˙3-Dd9r&Ȗ3-g"ZΉl97jh9'LD˙s"[Dh9r^b9r&LD9-g"ZDr&LD˙s"[Dh9'Ltߨr&Ȗ3-g"ZΉl9r&LD9-g"ZDh9'LC˙s"[Dh9r^b9r&Ȗ3-g"ZDr&LD9-g"ZDh9'LD˙Hs[Dh9rNd˙3c9-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-gL"ZDr&LD9-g"ZDih9'LD˙3-Dh9rNd˙3-g"YΫY,g"Y4r&LD˙s"[Dh9'LC˙إȖ3-g"ZΉl9r&Ȗ3,g~9,4h9rNd˙3-g"ZΉl9r"[4mZ,g"ZΉl9r&Ȗ3-g"ZDr&LC˙s"[Dh9'LD˙3,4or&LD˙s"[Dh9'LD˙3,,3-g"ZDr&LD9-g"Y4d9LD˙s"[Dh9rNd˙3-Dd9r&Ȗ3-g"ZDr&L$9-g}汿N弢r&LD9-g"ZDh9'LD˙Hs[DO.s"[Dh9'L$˙3,4h9r&Ȗ3-g"ZΉl9r&LD9-gZDr&7urt3Q-OC':KrjSKXNE?R-'ұj9˩SQ-ZN| j91t,j9t,ZN|\-j91t,'R-'ұZTTˉ;KrjSKX:Kr*Dt,ZNE_P-~d\-j9b9T˩XNrjKofeZN~ ZR-'b9˩Q(SQ-'XN} j9˩}}XN}ᵜZR,'rjSC\ұb9qrr)SKZd˩ Fb9-R-'A\c9q\zױZcR-j9=7XN-rr鱿Qr*dQr*d{ұX:sR-j9Zߨc95TɥF˩ZN-r2zoԱZdsdQr[P˩ZN.7XN-r2ߨc9QkR-'b9QrR,j9T豿Qr*dQr[P˩ZN.=Q?.7XN}\-'u,j9tߨc9T˩ZNF:SKZkdtߨc9}oԱrr鹿QrbXN.=7XN}\,j99ߨc9TɥF˩F˩/SKu,ZNF:S߂ZN-rjKooOKdXc95T˩ZN.='XN-r2{~^u,'c9D?Qr2OԱj9rr?QrjSKz/T->C:SKZR,j9Th,'@˩K:SQ-'@˩ZN-rr?P:Clu,j9c9T˩ZN.=M,'Erj8˩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,>uiKu:SW˩ZN.=XN-rruqkc_,'u:Kt,^Rǥ:hyӱұ\zӱnt,'>XN-rr鹾NrjKTrjKu:SKS-ZNFF豿NrP˩ZN.XN}\-'t,b95Tɡ:}X.d9dYixj|s䜆'9E?rs㜆85Ϋ1ixs_✆8ixjxsᜆ78'8its߼ߜ7ͫixzs^ޜ7w7ixusݼܜ'7ͫixosۜ64˱4F64:Fw64G6\^w7Ӽ?yLf]Lit[sL˚itXsLitU3jNÛitR3.jNÃitO3i5IxL3ni)ͫ%4:F4:9 h49 Oh~+hix>3gy࿼F34F348DW3h4F'3b4<涾:>F24F24:Fw2LJfLit"s^LipsLit3ncNӘit3cN󡻘it3bQix3NbEix3a949 a-4:F0!$Fg04:F70fLe]LitrL˗itr޽Lit2^NÛit2 .^Nƒit2]ѵix2n]y/]NCit2\N+initr^Litj|2[q4m9N[&e4:l9 Z:jFG-M4:iF-4gF,4p2nUѩ4T9 Uѝ4:S9 Tё4QD'*4:PF)<4NF)64@](eW(^ߠLeLip~r^Lit{rL˓itx2NNóipu2N^ oN&/Nixo2Mѵixl2nMѩ449 M$:3FW&41F'&4:0F%$.fےd]LÒitWrLitTrޔLitQ2 J^I94&F$-4:%F$!4#Dg$$<"F7$4 F$~d#xdݎ#rdLld]Lit3rLip0rދLZdߊLSit)rLs[L+Hd݈LBdLCNit2nCNӐip2C]Ix2BQ4 9 OBE4:9 A94F -$:F 4!4tohNd@8h#NdD8-p";‰ hNdK81YNcN8=-p"‰H )NdU8Y-p"‰, '2-Nd\8uDW‰ '0Ndc84V&3LDh8a"RD '6L Q&"9LDs8a"Dd'2&"}1Zc"lj@&LD9 d""DTA&LDr"SD!'Ls۟({4YD&"LD9Qd"Dd"h(#=/h#'2LDs"DD4LPi&"Ӽi&"LD9f"ZDĚ5'2LDH`sD$O.hs"Dd6'2L$t34ƛ7o&ߜȀ3g"Ήl8q&LD9gBDr&,g"ZΉl9r&LDyELD˙3-Dh9rNd˙3-g"ZΉh9r&Ȗ3-g"Y4r&LD9-g"ZDh9'LD˙}ᶜr&LD9-g"ZDih9hd9r&l$H,g"X7N$r&l$H,g"ZFd9r&l$H3-g#YFd9r6l$˙,g#YFih9r6Ȗ,g#),g"ZFd9r6j$H3-g#YFd9r6l$˙,gYFh9r6LD趿Qd9r6l$˙,g#YFr6l([Dd9rl$H,g"ZFd9r6l$H3-g#YFh9r6l$˙,g#YFd9r6LDH,g#YΉl9r6LDH,g#YDd9r&l$H,g"ZF`9e9r6l$˙,g#YFh9r6LDH,g#YDd9rNdH,g#YDmd9r&l{l9r&l$H,g"ZFd9e9r6l$˙,g#YDmnEF3-g#YFh9r6l$9-g#YFO@L#YDd9r&l$H,g"ZFmd9rl$H3-g#YFh9r6l#˙,g#YFh9r6LDH,g#Xil9rLDH,g#YDd9r&l#صLDH,g,gdH3-g#X6`9r6l$˙,g#YFh9r圈ml9r&l$H3-g#YFd9r6l#H3-g#YFd9r6LChF˙,g#YFh9r6LDH,g#Xil9r6l$˙,g#YD`9r6LCH,g"ZFd9r&l$H3-g#X6d9r6l$H3-g#YFih93d9'l$H3-g#YFd9r6l˙,gSh9r6LtlF,gZFd9r&l$H3-g#YFd9rl$yEltO|OOT˙"XN,˩ZN-r_b9r/SKX:Kr*Dt,ZNEj9-бұj9qбX:SKX:KrjSQ-'>XN,˩ZN-rbXN,˩ѱj9r|b9/}a}\-j9ɥX.c+ <5˩SCZdɏR-j9ɥXNE'dFj9r[PɥXNEr R-'b94SCR,'dˉ;KZR-'XNE~_1˩oA-j9ɥ:SWɥۇDXN-rr豿QrjSKu,j9ߨc9r2ߨc9r2QrraXN,蹿QrjSK\zoԱcR-j9=7XN-r2zoԱj9}oԱrjK:SK>7XN.}oT-j99ߨc9TɥXN.}oԱc9˩ZN-r2zoԱj9}oԱrjKooԏK:SWɥF7XN.7XN-rjcR-j9ߨc97XNFu,\zoԱX:K:S˩ZN=7XN-rr龿Qr*dQr R-'F˩:cR-j9F˩ZNF:SCZsR-''?Qr ?KoOԏKu,'D˩S_x-'u,j9ɡBrj99_c9T˩ZN.rjSKryԱk9c9r2ԱZR-'Uˉc91T?PrjK:SKZsj9i,ZNr2c9?Nrr?NrjSKz|{~=`r2ӱZR-'t,j9}ӱj9XN|R-'XNFm:S_x-'t,j9ɡ8˩OR-'^t,q:8hV˩S\zӱj9}ӱZR-'Tˉc91t,'_˩R-'^t,':s}^t,j9Tɥ:˩R-'t,b99t:8/:ɥu:SK?k}dKu:SKs}XK_,?~_w_-DWXΉl9'ȖOYΉl9'Ȗ9-DWXΉnrNdyErNdyEȖs"Zil9hrNdyEȖs"[Ήl9hrNd9--s"[Ήl9hrND9-hh9rNd˙3{iW'L$˙s"[Dh9rNd˙3-g"ZΉl9r&Ȗ3-g"ZDr&LD9-g"ZDd9LD˙˙3s"[Dh9'L[3-Dh9r&Ȗ3-g"ZΉl97jh9'LD˙s"[DZ,g"ZΉl9r&Ȗ3-g"ZDWXDh9rNd˙3,4nXDr&LD9-g"ZDh9'LD˙s"[Dh9rNd˙3s9-gZDr&LD˙˙3-Dh9r&Ȗ3-g"ZΉl9r&LD9-g"ZDr&LD˙s"[Dh9rNd˙3-Dh9r&Ȗ3-g"Z+Z,g"ZDh9'LC˙s"[D7jh9'LD˙3-Dh9rNd˙趿QLD9-g"ZDrO-gZΉl9r&Ȗ3-g"ZDWXDh9rNd˙3-Dh9r&Ȗ3,gZΉh9r&LD9-g"ZDr&L$˙s"[DXΉl9r&Ȗ3-g"ZDWXDih9'LD˙3-Dh9rND˙3KA9-g"ZDr&?NLD9-g"Y4d9LD˙s"[Dh9rNd˙H3 -rob9rNd˙3-Dh9r&Ȗ3,gZDr&LD9-g"ZDd9L~Ȗ3-g"ZDr&LD9-g"ZDd9fh9r&Ȗ3-g"ZΉl9rL$9-g"ZDr&LD˙s"[Dh9'L$˙3-Dh9r&Ȗ3-g"Yil93h9hh9rNd˙3-g"ZΉl9r&Ɩ3-gSȖ3-g"ZΉl9rL$9-g"ZDh9'LD˙s"[Dh9rND˙3-hnr_,O'?rtXN.rjSKb9r2=>\_,ZR,'>XN}\-'^u,b99ߨc9T˩ZNF:SK\zoԱj9}oԱj9ߨc9Ft,'dߨc9T˩ZN.7XN rr鱿QrjSKu,j9=7XNE>7XN} ߨc9tߨ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-rjKZzod4k]ɥ@˩}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}dKu:SKs}XK_,?~~8ir^b9'Ȗs"[?f9'Ȗs"[+Z,Dr^b9'Ȗs"[+Ɩs"[+Z,DrNcyEȖs"[+zrNd9-DWXΉl9'Ȗ9-DWXΉl9'ƖOYDh9'|4+/-g"ZΉl9rȖ3-g"ZDr&LD˙s"[Dh9'LD˙3-Dh9rNd˙3-g"Yil9r&弢r&L?%'Ȗ3-g"ZΉl9_%LD9-g"ZDh9'LD˙s"[Dih9rNd˙3-DnXDr&LD9-g"ZDh9hh9r&Ȗ3-g"Yil9r&LD9-g"ZDr&LD˙s"[Dh9'zr&LD˙s"[Dh9rND˙3-D-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-g"ZDh9'LD˙s"Z4LC9-g"ZDr&LD˙˙3-g"ZΉl9r&Ȗ3m˙s"[Dih9'LC˙3-Dh9rNLD˙H3 -Dh9r&Ȗ3-g"ZΉl9r&L$y5L$˙s"[Dh9rNd˙3-Dih9r&LD9-gXDr&LC˙Hs[Dh9'LD˙3-Dd9r^-g6-3-Dh9rNd˙3-g"ZΉl9rLD9-g"ZDr&b9rNc˙hf9-g"ZDh9'LD˙s"[Dh9r^b9r&LD9-g"ZDr&LC˙Hs[Dh9'LD˙3-Dh9rNd˙H3 -g"ZΉl9r&LD9-g"ZDr&gh9r^b9r&Ȗ3-g"ZDr&L$9-g"ZDT9-g"ZDr&LC˙Hs[Dh9rNd˙3-Dh9r&圈3 -g"Z?f9r^b9'Ȗs"[?f9'Ȗs"[+Z,Dr^b9'Ȗs"[+Ɩs"[+Z,DrNcyEȖs"[+Z,DrNdyEȖs"[Ήl9hrNdyEEr6˙3{iίDh9rNd˙H3 -Dh9r&Ȗ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&Ȗ3-g"ZDr&LD9-g"ZDh9'LD˙3-Dih9rNd˙Y3--3-g"ZΉl9r&LD9-g"ZDr&LD˙s"[Dd9LD˙3-Dh9r&Ȗ3-g"ZΉl9r&LD9-g"ZDWXDh9rND˙3-D~ob9rNd˙3-g"ZΉl9r&Ȗ3-g"ZDr&LD9-gDrȖ3-gD-3-g"ZDWXDh9rNd˙3-DnXDr&LC9-gZDh9'LD˙s"[Dd9rNd˙3-g"ZΉl9r&Ȗ3-g"ZDWXDih9'LD˙3-Dh9rND˙3KA9-g"ZDr&?NLD9-g"Y4d9LD˙s"[Dh9rNd˙H3 -rob9rNd˙3s˙3-g"ZΉl9rLD9-g"ZDr&LD˙Hs[D-Dh9r&Ȗ3-g"ZΉl9r&L$y5LD˙3-Dh9rNd˙H3 -g"Yil9r&Ȗ3-g"ZDr&LD9-g"Y4h9'LD˙3-Dh9rNc˙hLDyELD˙s"[Dh9rNd˙3,4h9R],Dh9=id9r&Ɩ3-g"ZDr&LD9-g"ZDh9'LC˙OYDb9M[!~[3/j|s'v8Sv DSNTp9h77Go)DSt?{71S~M4U?h35g|s&v 6~pMTk)|Yj9T;)|s4TioDS&DI/@ /zTg (NlvB3SLeb,;Uj2Y1)NEv2SM&M-PLWbj'M}Q0SLL&f/~~K5?K^b;j.є]=e=E_%K.SqK|jKWXKZj汾:Zb;ejs%vj,X_#,XX_+TW:VjΑwT\_*SUJWJTTj籾:Sb;Քjs,%vJ)W(JQbR;9;j>WI|N$fj'5Z_#'S8I|Q?ILbd;js$rI5s$k%S*ǷW秝'*s{uLvs$v $S汾:GGb8;yΑjns\9*Ey!wc}ugCbR39;ڹ΁h |Q S澾:G@)Ts[_^G>ja93jۣs#fS򈝊G5oOk}tw|5G秝9Q}}ttDS爯Q;9;5 qs}s Iyoэ)nNmvBSوF5'F|EyO!h*'xF3bQ;ɩe|?s(JF%9;eyOAةaN vS䶾8V/bxQr_svss"vǷ槙_ˋtĢrET+j>7*bTQSTr[_E5!jks"DD'b'6Q392UDD%j>7%H*l<៻Q;9M)9;u)C}}o tVBݹlߛNAi>3{.|x];;$dw y2;A܁ 6;A܁ dw y2;A܁ @q2; @dw Aށ dw y2;A܁  @q2;A܁ @qrw @;,z<w Y"@q;5ځ dv Y @iH;Eځ dv "@iH;A܁,dv Y"@a2;Eځ, @iH"@qH;Eځ dӗ"@i2;Eځ,dv Y"@q;5ځ,dw YȠv N7;Eځ dv 7;Eځ,dv yH;Eځ,dw Y@iH;Eځ dv "@iH;A܁,dv Y"@i2;Eځ,dv Y"@qH;Eځ, @iH;A܁,dv "@i2;Eځ,dv Y"@pH;Eځ,dw ow "@i2;Eځ,dv Y"@dv Y @hH;A܁,zڿQށ,dw Y"@qH;Eځ dv Y @iH;AW@֜Ow k"@]Ow Y"@dv Y @iH;A܁,dv "@h2H;5ځ,dv Y"@qH;E؁dw Y"@qH;Eځ dv Y1ށ,dv Y"@i2;Eځ,dv kY__ @iH;A܁,z?Nށ,dw Y"@pH;Eځ dv Y @aF;YsڿMށ,dw Y @iH;Eځ dv kY @iH;A܁,dv Ȣ7@]Y"@i2;Eځ,dw Y"@dv Y @iH;A܁,dv "@i2;Eځ,dv Y"@q;5ځ,dw Y"@qH;E؁dv 9;Eځ,dw Y"@qH;E؁dv ~wz2;Eځ,dw Y"@pyQxH;A܁,dv Y"@i2H;5ځ,6;E_m[An9i9s[7k9s[mZAn9<Цs[An9s[An9i9Ės[mZAn9<Цs[An9i9s[mZAn9<Цs[1h9eo'w-g[An9r b9-gZr bĖs[ Al9rrĖ3- Al9r3-g[An9r R9-g[ ڴAl9 r b9-gГAP[ r}ur3-g[An9rư b9-g[ roԦ b9-g[ r bĖ@3-g[ r R9-g[ Al9 bĖs[ Al9rrĖ36-g[ Al9 bĖ3- 1l9rrĖ3-g[mZ Al9 bĖ3- Al9rrĖ3-g[An9r3-g[ r=ߨMĖs[ Al9 bĖ3- Al9rhr bĖs[Al9 zڿQ3- Al9r3-g[An9r b9-g[ rƜO[r b9-g[ Al9i9r b9-g[ r bĖs[ 1l9aĖ3- Al9An9ra9-g[ Al9 bĖs[ Al9rfra9-g[ Al9 bĖs[A.- Al9rr6-g[An9rư R9-g[ r bĖs[ 1l936-g[An9r3-g[ raĖs[ Al9 bĖ3H-A۟on9 bĖ3- Al9ir b03-g[ r b9-gZAj9Ǹ bĖs[ Al9rrĖ3- Aj9cr3-g[ r R9-g [ ڴAl9rrĖ3-g[An9r3-g/.M9-g[ ras[ Al9rrĖ3- Al9rĖ3-g[7k9N|'S?Ǵl80+||guӌwZq>.icK8q;+||g07Uo4ބi t3+ęvlhgl>>wV;o~||g嚸Z㏵ZwV;-5q;||ge04i´ф|ytA}9_͇_wÏϔ~~֙8Sw._6?ߥ2wfLLi;2eecĝ&"SwdNzL25 cb$ď%$Ąi)s=E*L|΍0q $ԝ/ 0q$||g՗2/^NKiy; /e]4yd#s~-?&Rw\Y%>VkKݹm_ZNRKl_ZN;Kif)sݾ:+ĝ6sپ:i`)}uV^ ӺRiꬶRwn^Ye;+n_UNJiT;ݫJiQ;zJiN;)eWgӔR}uVH ӎRyꬊ?FӆRwWgӀRy|Rw^NIi;3Ii8;&uejZѤĝ&bR}uV/ \RyX?TRw.^ܶ$IuHgHyBwHNHYu$4ĝs۾:ogwaLHHEu$UDe+9$δԙY-$4ԝY!$L;H*H|΍ q yi?֏w>ëɝ8Q{tV3qѣ\Jqţãm;>W;gw^JeGg097sԝY#qĝ$:sݾ9 7e欺w7NFݹw@NFi(3]m䬪rFݹn4´h9o3NsFiͨ;Ӗ2>>ӒQ}rVLj;u}rVĈ;mq \ONFř|oEi(}nVrsE9o-NEI3gg^l^U,ʜqVԝY"4Uy=7+T|l)ͪW;me(\ 9OԝYu"4Nĝ:s>7Lćj;u}nV;u}n$Hj?ֈs>7Ei(}nV;qM#gVJu NCݹmߛʜvJe^vͭyެwZNCݹlߛc8ĝsݾ7+7ĝԆ:s|ve-RC{BCyپ7+3ĝmެPf{}oV`]};+/ԝYqiެPw^ q]\wͪ qQr%X- qA\ q'5ΜM[B23sپ7#ď!"ԝY !>VBݹlߛNAi>3{.|x];;_]w;A܁ @q2;@q2;A܁ @qrw  @d w 9;A܁ d w y2;A q;A܁ dw y2;A܁  @q2;G8dfH;Eځ dv Y @aF;A܁,dv "@iH;A܁,dv Y"@i2;Eځ,dM;Eځ,dv cY"@dv o)dw Y @=}y/*dv Y"@i2;Eځ,dw Y"@qH;Eځ diFyH;A܁,dv Y"@irw Y"@qH;E؁dv Y @iH;A܁,dv "@]ow Y"@qH;Eځ,dv kY @iH;Eځ"@i2;Eځ,dv Y"@qH;Eځ,dw Y@iH;Eځ dv Y @iH;Aw Y @iH;Y"@i2H;5ځ,dw ow Ȣ"@qH;Eځ dv Y @iH;Aځ9(@h2;Eځ,dw Y"@dv Y @iH;A܁,dv "@h2H;5ځ,dv YȢ+uA܁,dv k"@iH;A܁,dv Y"@arw Y @iH;Eځ dv @=Wh2;Eځ,dw w Ȣ"@pH;Eځ jXK܁,dv Y@di6yH;A܁,dv Y"@i2;E؁dv Y"@qH;Eځ,d w ?߸"@iH;A܁,dv Y"@arw Y"@qH;Eځ dv kY@iH;A܁,dv "@i2;E؁dv Y"@i2;Eځ,d w gYAށ,dv Y"@i2;Eځ,d w Y K;A܁,dv Y@a2;Eځ,dv Y"@ݴY"@i2H;5ځ,6;E_y}>]9-6- rrv-grryM9- ڴrr9-rq9-6- rqyM9- ڴrr9-6- rryM9- R(ӜBl9Ǹ|C3-g[An9r b9-gZr bĖs[ Al9rrĖ3- Al9r3-g[An9r R9-g[ ڴAl9 r b9-gГAP[ r bĖs[ Al9 RÖ3- Al9rrtڿQ3- Al9rrĖ3-g[mZΠi9rrĖ3H-Al9r3-g[An9r b9-g[ r bĖs[ Al9rbÖ3- Al9r<Ц bĖs[ Al9rrĖ3- Al9r3-gZ1n9r b9-g[ Al9 bĖs[ Al9rrĖ36-g[ Al9aĖs[Πi9rr6-g[An9r3-g[ r b9-giDa9-g[ r bĖ@3-g[ r b9-g[ Al9 RÖs[Al9rrĖ3- Al9rư3-g[ r b9-g[ Aj9i9rư3-g[ r (1l9][An9r3i8mZ ras[ Al9 bĖ3- Aj9cr-gi6mZ r b9-g[ Al9 RÖ3- Al9rrĖ3-gZ1n9?rrĖ3-g[An9r3-g[ ٴAl9r3-g[An9rư R9-g[ r bĖs[ Al9 RÖ3- Al9r3-gZ1n9gr<Ц bĖs[ Al9rrĖ3H-Al9~wnZAn9r3H-g [ cr bĖs[ Al9 bĖ3- 1l9r]t5-ۯ6-g[An9r byMĖ3-g[An9r3-g[ rư b9-g[ 1l9 bĖs[ Al9rrĖ3-g[An9r|i Aj9crhr,RĖH-gZ"Al9r֨ bYH-gZ Ej9r bYH-g["Ej9r,RY3-gZ"Eh9cr,䖳H-g~\3-gZ"Al9r bYH-gZ Ej9r,BYH-g["Ej9ro["Al9r bYH-gZAn9r,RĖH-gZEj9r bYH-g["Ej9r,RY3-gZ"Ej9r,RY3H-gZ"Al9r,R9-gZ"Al9r,RĖH-gZ Ej9r bY-g ["Ej9r,RYH-g["Ej9r,RY3-gZ΢rYH-gZ 5j9r,zڿQn9r,RYH-g["Ej9r,RY3-gZ"Aj9kN'-gZ Ej9r,RYH- Ej9r bYH-g["Ej9r,BY3H-gZ"Ej9r,RĖH-gZAl9r,RĖH-gZ Ej9r㖳-gZ Ej9r bYr֨,z vj9r,RĖi8,RĖ-gZ"1l9r bYH-gZ Eh9krbYsڿMn9r,RY3-gZ"Ej9rQY3-gZ"Al9r,BÖh-g["Ej9r,RY3E-gZ"Eh9Ǹ,RYH-g["Ej9rQY3-gZ"Al9r,RĖH-gZ Eh9kr bYH-gZ Ej9rư,ڟQYs["Ej9r,RY3-gZ"1l9rRuĖH-gZ Eh9kraYH-gZ Ej9r,RYH-gZEj9i9N|~弼fOjw^rj9u-.||])Ԗ{rR[N\Z-'.S-'j9r jˉ/A[NZ-ĥr ćk˩Cm9qhZN]jˉKĥrR[NpĥrR[N]jˉKĥr=4lj)S-/˻w-'Q~זSrRZN^J˩Km9u)-'ԡԖ(-'?\ZN]j˩Km9y)-'/jI_!jIS_S-'ypk9ԥԡ:Ԗrj9rírR[N]jIS-' zrKЖSrRZN^zٿQԇkKZN]JCZN]j˩Km97jԖ.7jBm9oj9^ߨrKЖnިO.VItݿQԥԖn7j:Ԗ.7jԖSr]oj9u-'eFS-'Z-m9u-'/oj9u-'Z-'/ߨ:Ԗn7jԖrZ-'>j9y)-.ԥDZND7jԥtF}zV˩ז7j:Ԗ7jԖSr]oj9u-.Z-'iFeFS_ZN\Z-'..7jpi9u-']oj9u-'/oj9r=ߨro˩Km97jBm9N7jԥԖި.ԡDZNj˩Km9yV˩Km9OmDj9yZ-'yDS->񶜼t?Qԥ->X[N_rR[N]jKi9u-.$V˩ϻ-'/]j9rj9u-.jˉCġ4ZN]jKZN]j˩Km9yrҜӴrL[NZNry8SrRZN|x>=eV˩Km9u-'/]j9u-'qZ-'P[NmZ-'ԥDi9r 'ޖiԖSre8S-.qZ-.qj)Ӗh-P[Nre8S-'qZ-.ԥt޿Nm9qh8ZN^j9rR[N^_rj9^ӭ-'y:SrR[N^JIV˩Km9yV˩Ki9yu.xr=_ruZ-.>~꧗niD3ZN|ҫĥrm:VK/iԖi:Ԗ~wS-.uZ-.uj)Ӗ~.iԥtۿNԇkKZN]J˩C/i/k9_zrg-v9y@/]A]7]A]mv9ysw9]A]ysw9y@]A]1pZN]jˉKĥr Z-P[NBm9%hˉCԡZNpm9u-'V˩Km9qiZN]j)ԖnZN]jK2=xj9񉮖S-'j9r i+||]Itpm9u-'/䥴ԖSrPZNj˩Km9råԥԖrRZND2QZNDi9%hKi9r׻Sx[N]jKi9yiZNj˩Cm9y)-'.(-'>j9y)-.ԥDi9r=?":oߨw-m9u-'/䥗ZN}tۿQԥQ\Z-'.V˩Km9u-'/ݶoj9u-'/]oj9u-.$ߨԖV)ԖyFS_Ԗ7jԖyF^oT[NjCZN]jKi9yeFnSrR[NZ-P[NZN} rR[N^|x>tۿQԇkKZNjKZN]j˩Km9.7jԖSrmFVIV˩/A[N^ߨrj9yV˩SruFSryFS-'Z->񶜺ԖV)ԖV˩/A[N]j˩Km9yRZNjIt>QԡԖ'jԖOj9񉯖O/쟨rOj9roKZN]j˩Ki9yrꃵZ-.ԥSrR[Ni9injru@S-'y@SrR[N^8ZNjIs?Pԥt?PԥԖ-'i>M˩O-δ$z?Nj˩O-'/j9u-.ˇC/_vj9iԖSre8Sr=or9ߦr ZN]jIV˩O-'/oj9u-.qZ->Z[N]jKZN]jKԖS-'[[NqZ-P[NZN]j˩Km9yrj9qhtÁrõԥtۿN$:m_rl_[[NuZ-.ԥtٿNԇk˩Km9yV˩Ki9yu.xr=_ruZ-.>~꧗niD3ZN|ҫĥrm:VK/iԖi:Ԗ~wS-.uZ-.uj)Ӗ~.iԥtۿNԇkKZN]J˩Cm9y}޵/k9~鳖*۔0.9&<;8<+W80N8lø<77x0n7t͸<ø|3l06h n6&<8|3^05Z05̦< RG;"߬qf6aiƕDqy&qjvcguƙcfaycfaygcXea9Mada9Aq95Ƙq9)cbfcXa6c`Qyc_a~f6Ɨc1L/r̳1.r̓Fc\c\aoycX[alycZai9aYaf9aY9m_Mb9aXa_9ya\Wa\9mofSVaX9]fqU9Q5qR9EcS9֔cS-cXRaHywcQaEyGcPaB9aPa?9֓a<9q99vcMM59䘫z8br 1%\r k1%Vr S1,%0<;1$Ǩ<#1l$0B0$ǰ9mwC=Fc<cԗ!/%?jHt>\ D}Mu "/%B䥗/۟u"/%DĥU"%Eć[-"/%Fԥֈ(=PDGQ(]oJu"/]oԪ)=ߨ* T$zڿQUۇ7KVĥ+]o uŢ.5YZѢZZݢ.5\ԥDvQ/]o/=ߨU0KЄQ0yFQ1cԇkK/7)eZ5.5gVшF^N]KuU#eFQa#Zimuq#/]>Q^ߨ75pZqZ.5sԥvDJG]jKmyVHtڿQw$zٿQxԗ#/]oԊqiUtٿQ{ԇmF򑇮7j7jBo* 7ԥ6D*HfDBH} ZBRSH]j KogRCPsHZAԥ&t?Q+ԥVDOԧVO|tD}zeD8V)>RxI^쟨HRI]J$C LR$]/*%u.ĒZRKM/Is?PdjEB&jupRZNe@ġOPIZ.5Z .ԥFt?P(iNiBJ}-)u)%qZ1PkJ})yVPK-*u)I%]>\L]jKL]JCӧn_vYĻ8y:<^ 4u;U?t۾N$ڟ_i^&.PniDbM^JK5u&/]*6u&/R]Ѧ>\M]jKM]JCvS&Q]7hK-8yVé׈.ieSru:K9_zrg-jv- ڴrr9-ڵrr9-6- rhrr9- r9- ڴrb9-6- rhrr9-s~OR๐[An9<Цs[mZAn9 Z Al9 bĖ3- Aj9crrĖ3-g[An9r b9-g[ r bĖs[ Al9 bĖ3H-Al9rhr ⯒rƖ3-g[An9r3-g[ r b9-gZAl9 bĖs[ΠڴAl9 bĖs[ Al9rhr bĖs[ Aj9Ǹ bĖ3- Al9rrĖ3-g[An9oԦ3-g[ r bĖs[Al9 bĖ3-6-g[ r bĖs[ Al9 bĖ3- Al9rqĖ3-g[An9r b9-g[ r bĖs[ Al9i9r b9ZAl9 zڿQ3- Al9r3-g[An9r b9-g[ rƜO[r=M9-g[ Al9i9r b9-g[ r bĖs[ 1l9aĖ3- Al9rrĖ3H-g [An9r b9-g[ r b03H-g [An9r b9-g[ rư z vl9 bĖs[Πi9rr3-gZ1n9r3-g[ ray 1۴i9rrĖ3- Al9r3H-g [ r b9-g[ Aj9Ǹ |s9-g[ Al9 z?Ns[ Al9rfr bĖs[ Al9 RÖ3H-Al9rrĖ3-g[An9r3H-g [ r bĖs[ Aj9Ǹ ڟaĖ@3-g[An9r b9-g[ cr ߥi9 bĖs[ 1l9rqĖ3-g[An9r3-g[ rư bv-gWo߹l3-gӡVˉKԥԖw-P[]˩Km9qiZN@j)ԖS-'m9qh:ԖV)Ԗ-ġrj9u-'.VK2=xshˉaZN]j˩Km9qiZN@j)t?ԖW]һerR[N^JKi9u-.䡴:ԖSrK˩Km9u-'/䥴Bm9+drԗ-'/jIt>\ZN}m9u-'/i9u-䥴ZNp䥴ԖS$J)ԖiAyFk9%h˩Km9y)-'/ߨrõZ-.Z-.ԥDZN]jKZND7jBm9oj9yj9qiDi9^oj9u-'/ݶoj9u-'/]oj9u-.$ߨrR[NZ-P[NZN} rR[N^:ߨrR[NZN^zٿQm9u-'oj9u-'/䥗ZN|rRZN]j˩Km9.7jBm9oj9%h˩Km9y)-'/oj9ruFSryFSrR[NZ-.ԥtۿQ$:ߨrߨrKЖ7jZN^ߨråԡo7jԖSryFS-'Z->񶜺ԖV)ԖV˩/A[N]j˩Km9yRZNjIt>QԡԖ'jԖOj9񉯖O/쟨rOj9roKZN]j˩Ki9yrꃵZ-.ԥSrR[Ni9injru@S-'y@SrR[N^8ZNjIs?Pԥt?PԥԖ-'i>M˩O-δ$z?Nj˩O-'/j9u-.ˇC/_vj9iԖSre8Sr=or9ߦr ZN]jIV˩O-'/oj9u-.qZ->Z[N]jKZN]jKԖS-'[[NqZ-P[NZN]j˩Km9yrj9qhtÁrõԥtۿN$:m_rl_[[NuZ-.ԥtٿNԇk˩Km9yV˩Ki9yu.xr=_ruZ-.>~꧗niD3ZN|ҫĥrm:VK/iԖi:Ԗ~wS-.uZ-.uj)Ӗ~.iԥtۿNԇkKZN]J˩Cm9y}޵/k9~铖aw . rq3A4{r3c qsw9] r.gw99ȻA .g w9,.gv9Y]"ri3E.gw9Y]"rqHE,.gw9Y] riHE .gv9>rsHE,.g w9Y]A,.gGE .gv9]΢/^E,.gw9Y]"rqHE .gv9kY] riHA,:(ri3E,.gw9Y]"r.gv9Y] ri1O,.gv9]"ri3E,.gv9Y]"riHA,.gv9]ri3E,.gv9yHE .gv9Y]Π'riHA,.gv9]"ra3E,.gv9Y]"ri3E,(riHE .gv99ȻE,.gv9Y]"rqiFyHA,.gv9]"ri3E,.gv9Y]"riY] r=(rqHE,. riHE .gv9]"riHA,.gv9Y]"ri3E,.gw9Y]rqHE,.gw9Y] riHE]"rh3E,.gv9Y]"riFE*]"ri3EOɻE .gv9kY]riHA,.gv9]"rhsw9kNɻE .gv9]"riHA,.gv9]"ri3E,.gv9cY] riHE .gv9]"ricY]"ri3E,.gГv9Y]"rpHE .gv9Y] riHA,.gv9]"riHA,.gv9cY?]"r.gv9nɻE,.gv9Y]"rpHET]"ri3E.gv9cY]"ri3E,.gw9Y]"riFEQ^ߨrõZ-Z-.ԥDZN]j˩Km9yVItڿQ$zٿQԗ-'/]oj9qitٿQԇK˩Cm9yV˩Km9yV)t=ߨro˩Km97jBm9N7jԥԖި.ԡDZNj˩Km9yV˩Km9OmDj9yZ-'yDS->񶜼t?Qԥ->X[N_rR[N]jKi9u-.$V˩ϻ-'/]j9rj9u-.jˉCġ4ZN]jKZN]j˩Km9yrҜӴrL[NZNry8SrRZN|x>=eV˩Km9u-'/]j9u-'qZ-'P[NmZ-'ԥDi9iry6Sr+Жe8Srm8Sre8iI֖S-~m9yV)Ԗy8SrR[N^:_8ZNZ-'/]p`pm9u-'/j9NiD/֖V˩Km9u-'/]j9rR[N^_rRZN:x>=t"޵DiV˩KߩuZ-'e:j9qitۿN$:_ruZ-.uZ-_]ԇk˩Km9yV˩Ki9yrʴ$=uZ-m9u-'/j9re:SrP[Nn_w-KZΟ_7n_t?}{6_w߾?~o__t?= ׷h7OO~߬zmN??~ÿ~ߥӟw.ϯ`zvϯW~ t%տ%_NU|y:߾I미?~9Mo_ _~t?qU}>{~o+mpn]>_?÷~ 7xR^?qp\޲Wp}=o;^o;}'kOqy%~wl/?_tL<iO%Go_8~\nQxGgkyyZe>?3oϯ?g|c^'o4>_O?7tÿ׷_?7?^ӗNWG}ߔ}E~|?[Fvo}?}%yV?Oǿߎ׿Ͼ?}_~ܺ?ϯ\DIO_sq?I~ۉm~~^~~zϐ܎!׷/7|ov;@B?Mtw?/C`?u7gyֆ_?~/ۻo37{y?'Or|_wg?C/_?]^{>ϾΟ/k)w_98;pno7_oXq<_Wۻ? _T,endstream endobj 311 0 obj << /Filter /FlateDecode /Length 1162 >> stream xWK#5W 7"e"(=dfw1TnVH(ҌG=Fph}a%&6 hq_@:.vwz\\{c<[Cد+: uB(5Vlxʾ.mi텐(*q| ?оD+@܆ -ڬ̇:w%67_Vo߱Z']2Kuգni&^'0h3heeh ICiGτ飾 8ҠjaK. ?Ԇ%98OYG(,sSf̔hS>% |\8.0 Z 5^`v`십}l%Y p0j4p9 >޹rv r*B;OʅcT r򫨐oB< 9"Ef`7W:4'!A7]j?hUtTF$*uJEa2 sWYd dtt?nV:Eendstream endobj 312 0 obj << /Filter /FlateDecode /Length 6359 >> stream x=n%qosQym2@A$C QVvF?ެ*]9 J-^ź_?Γ8˻ɏ'\ޝ[S!&o<=pBSĩ3Ӭ8]ww'f4Fgdw}ޟIc'7|,zЗჱԲ /5}n)SrSQ@sXc6<~0S8u%Év{6]ž|NF,v@ls*BMolQL;4ҧ? ((ܰ1Y(k-ݟvll'Xl .hL@Hvs+,X_\)&ܸ0`}'ң;-:*qgᆵ֞i\Y*Ւ[ S. KVz(nœDFCFq62suMt3JiL2DC<9?kw. [6ǒVEq`\)B .E& ^\R+)'`""̃qYoɮvO>i9yG>If LA\b^(,]zW˾b+8Wp$<ԏ\BV |Ww[G$n GDtKc# c&i(4 vkŠ>j#p0dTidc,\,AKf&6#(-*tW#,=IWQ$tErf'9pT7ic :Ј-8ཬVPZ#TG]`%tɅ .6퀴{@!,xGZr_[׉da-!̔8nيґdF~dHYN҂dG*pE?eTqgdL'ȴ(Ĝ%Ua1 ( [/#&l+Az"Q"֒u;K# ֤zA*H/>dٲQ,z2 [@|E 3PX\>82C:(1YRZDax ,Z yP2|)У_rRCV.y}0k"/+:vzKޗvG,Ǹ%tѝ7!"HLPe A9Jy*ÉT|9T#VqSUx)/oHtn3szũ6(kɁ%x碣ѸiDfNDpnCtϻR̥ٵ2|iW2ym6X9" N-R] gAg}ZzjEz>ˑbˡkV)ɋxRV5P"R" XnM%y!\63Zrpm?3;B,YtrI#k4z8O [=H ֜@ϤGY9,k2t;K2?,oNU8w74XMޡ, 74 V[4&SSXTNFe SI}ͮ>;i7eUƍC[zL)(lTi"v'<9,Gr<~9*')1'I`}{N%`/su>,nO[M UЭ2Ugy3UuGw{8E:R?L[Kwљ덎 iHh7(A= E5tUBc-0:rCdm⼎JٖY,T~:X/ca}îOq&_h\CТZj(y)_YcVb-Ҷ2lsc-+3zDܤ>Yiϑ ̠ ;M0D+d(2;@Z٧?L+"ɐnA>h=K'?\?FX6`k%̞8֨7xXq ?b~+2zqRXvhs0;ʉ?gMaKكx +:ws04H<Վ2RmRdxRKR YSI4mPDyYGB`*ߕv D鵣+vC֖G.hմp3#䟹 `1|Mu:t6%x҉*gaW/)7 Do?A WaxA{IS>L_,H?]ׁD0Q=3AHOŀW|32/FX֧`iFV4(˸$s q'fwXZOsV-/"Mq ̤ͨExJԑpأ nu3/^Q@ݵ/F.i2 , 1˵tV}pSVdPP^nEQq~ @.ň,?,DáUl1ji_NzP>L?i3?Ig'D',S3mP=A?gv3p/rR;fܞ~9&kq;)>bXKr.COJKmں%ܗs _ XQDAEC Zr&W;q1VCgpʀʵ9Ȋ/4"QnG|T>, y?%.Il{q\.}A-IdocG0sqnBsa;2Tb](PBq#w"C#Ρyأ (ʁBp!mMB ="aX^7(,b^bߌ'!8asWK5 3%ae"b(x'׈_2<$قUO7Ɖ) DP;i[s_yf|˜קL~."c'FX"速0eMZ%Ts`*sv3 C5)9gϯ&\P܆-eЏ0A=|HW5Zk.0:ό]͍S ִ. l*gΤONS@(}fk"fs8t+,r_b4endstream endobj 313 0 obj << /Filter /FlateDecode /Length 4544 >> stream x\o#; c{<}!Gwy6i74-iW"w:;vo/˻_0dL׷nԲaJn4/n0F3c\v~G^?3K?BR8[kOl/zS9Y@,)lϦ%WCy`3uFJ<c'6k}60cnj_&7`uS8^rh=n1݋c1b%w}ײOH0L`K&9AHßgsGW#v0?(1ГC5  x 4PAW @r9p[>oFήBgO8?wzpn^E oasGe!oxZ Q- [عkb s3f)2aM`{F=KRoaそ J`ܤO`ք<#y˚^ kg9nFV-Ω0:B:+n {vB2vX3ƌR 8@^Y1[-(v0,sqNuy2wsy2xQ]5WX&ZJ 2ѭS>бɗoDTcb$ߨ ƌ܁6&bk/J&=L9?KԥPk܆PrNdJQFHz sK'fMxchLJ0J&"[X0\X0}ՂKzbg%S<>L$6M\~K&0Lyqw,wCn}n[nÛavZoc_67ӼNXSWO1{qZ~^ǟ~8rn13HgW_nk>PEF*ԝuSl18 f2)Yf 3-k)̩6\ZKxt';0wNQG8BIh9_XCP-fܞaVZɤ?iёFg0⠄c=nX4I%\LI3tcÌſݤL$^xw>Q/ oR 6NHs)2#R?z2 69YÜ.d} û;.XlfpND>pklh-1*i8'X\|`0^^”ahi@Qy)NsTB,pBLbHM@ }5p5cp^T^b 8W=6&ۈ)KΤfXM <8TNY`~\) ޤv yyGG5 P4rz~$ "[~z9)=zCJaLwP_=kyoS̄pTsЖV-'yS-gaԟ-RGy3~~{}ISj' ~rRn2I|IHf\`0$D<~~a^My4nTCQc**S)-l*5RtCRԥaൊ͑0m(hd6[MLGVNNcZ誳K.>6ʰrGH).nٌ. #qzp*axS)YMC>j緊zNb̥e B7nXDg?#HDh%~RP3ֺ%yʹ (_9g^tkG9Dcլ4Xfjezq'nꍡD겏 \#R*'Ҕ .0H 褜^iX)>H"8r45^@b O m_bWZ\7hLZ:*XؽBpԢ@-RBRZ䐿okAuCyZ Q&SLh~0zS&_ab) mEujYR'7/"͢ d=RKb&eFz)WRDƔMB8k6"udRaz _TŮTzCRiic[vxƂ$j^ ]im>?WAҘV', SX&x(M*F()cX>VOJy q D$:& EY8ڿ 54טGr0h{ig j~ģ幭Dgtr gjD rL[c4 ;*'v?"3,ٴ:m䫊ef*nv4)o s[74[,E2CEig3`!i+Z{]T6aY:POt/w}$ xLJ*c5ׇnʼnY ,Y^/\N eHᅀ8>>~]=]}><dB=Lvoޮi:@$>Ŋ,(ppXc;t~yot]kͻOϏz`H%E*A+c=tpkn з&0nGD.x=x/y@c!+# ِ0q)*s~c)ee6~V[IqYU.S0"Wq a9,@9V{ ~bfS`GyGvvz IP1QĹKő;<2c}]+JdEU=sԱ ,O*O]brV72K{/y̝q2E /:V RK, b~*;[69ARjqk9o A|ժޤg)8~Z W@!գy3]+I潓OQ<)/ ENZzxR|q6ABҪ0rIWhZV}I-A^]RG,뢷nFf#JFzv# 5;KW;[&! 8 FN;Ok,ޤezew;d oa{6e.Ns[Xl@C={Մ炔uɞ߳'r/ #n\Zjpj%]? 9W+NXÌr cO\u*`ً ,PB]%4ޒv/dH8g?w4N"W\c-ǵ =kN)d۩DB!˱n?%rF,K}r0JDX"o$(5wK(0X'i{7Z)K?yZyds4׷ z^ؠv ,4nTY!m"ҸJNM*Np hX''?+ UY>K%CwdʳApS2 0Z+2&nBίLWF&~# ׄ%nNuka|  =[uBM.q?F+(!}%A@W+fNl*_y wLW;_Jp (9 r6endstream endobj 314 0 obj << /Filter /FlateDecode /Length 2791 >> stream xZKok9QMX|3 Am7Fkd${*.>GZkv,b;o.!@([ӏ&H܀TKĉ.@2yH[5uLEXQYb.AIPA%-߯P te.QڻʷO~Oj ΁Bu1g@BZXo g^y\ Ҫp'޺JJ}b̡q:,9gG^>smBrGr2!]}nJcxa#=^eG&m)Q;P{ZMרD;ŞSfedF3WCq СLzs8QX@d~JqUEⱈ;c|TTR7~s+H8_LmY":.tF }ިPUX[ ?_3xGM|)ti})뮥$nj7dXz/q=t's相} }Оx5SݵԞ D-g/| C~Wӝ#IvQosɇj:_ry֡34 o[#P3(v4_w8ͯYm4q:+^8{Vgoq;e* 5Q_[Dpi\)p&J7B:  ԳD#A_Rד@7C;t˂bR0oU^Kuח_ Cqø )5H͙MB18P:2̞.h/t΁; I>]5Gh?G޴wIEnq &g}A$R0<+8gKEv'A5xBswa*VP//s\K-1:5aJ瘛ueWoّw4LaN}\. O ʜ7%a{S7=gx͆O_`* yi)s+I+RΈ-W~Xp&f#q`[W].ȓGE]*$m{zf\R^;|7^>e9\!CAyI7:?;/r@endstream endobj 315 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 372 >> stream xcd`ab`dddw 441%~2;Âw 0Sb/3P 2F|?&7,!=swO 质 e7t/X2k܍ӏvrLmn*m (^6sRI_?{䂪 -m]r;UdΖo5o޾`'l 閌i>rs/9snK;:[]St+4 tΔ־Ʈ9 Ɇ3w4vtuwV]#>m˖̐n>_Z:Z\+%!5q<|nnn!endstream endobj 316 0 obj << /Filter /FlateDecode /Length 3612 >> stream x[Yo#~7#CZó b,6"jqdKc++3T.ٲ=GiEX'l/ Nn?/~pUKՈ'FLZ>i5k&ſLg֚S m.әluL[-YSM͘n0Ƥ Zeu #YYZt(vTLLgm˘PZ{ĩ/>| K܅$O/dG۰6ugK@і*Z[k@%vTD0 tGEtfZ8l*H %^:j`ᓙjb܆rknD0~1͵;t N,hpf@P4AA`Qxz0 ;HϭsCW~+o/>`:p{B1f n7M[}:YOdt,ؙ[8BAoɻ'RWCH^YF*U:zL>JH6ti0.%u6z"kXMЦ{IگpTbdm|.zX>9ojcڨtfۚ+9 Yy>56-M[BOٰ;#9׾3tAmd{߱wah,8BmA?™}^b6$u1}$ƣzC177>!XV&qLaM@حSg~ڀi} pO뛟NWiެb0s ٨ [?pAqC-yj6,4r!AtZ1:{#1edi+DQ c58m>Q̣W'LBmڰ A#I4Hǫq|ҩl:3zs`"L2:q.o[191ˠ3S7O .}ad;Tݲ/9^^n-Y$`b@CX`6V^,(_C锤,KP9B<pIėN>DOرCht;eZ 2۵org)`ScHO?c/Su8}~,Pd3cƣ`H!B)ڦLf)KId+9;i+iAtu?@DeN]{ƪ* a @S^@#p 4kY V۰w |'ܼQ xJC`@c܆L 1С}WȤZ:s !dC~N K'DƓw˩w7D kizWF[0oς4CR1u=2rƭ.ߤE76~z4BG0.qfZp/'F^Z`6ME5ACDMF|R \dS@Ɩ9 M i6xU?SjLgH2*0mVo@u @aqZA;125nHl6rݛ׽(vz]z( ;ǥz).5VV*WU6vZwqz᪻-:U%FF Yo/U6,]U܀QUa_upE*x6_3K_(U{fLŠIX`.[gP+|ղvFy*.TV8=oz*G G/J.sՊZ"298zcFs D]XO]2wA{5gvaT|7OH R'!Ԏ?c X6.R >-}%>gjėQ󢥃6 @-eXQy&Ĥ{*0d٘̓hYbXHAքH`J ##Ձpe4>5R{Mo%VnRR& mz꿏ھID]-;.5{ >Ļz⫫1,A\5.^%:m}>SNuUՏwg dw-8rc&\(,X@A/-\wH$X30̼ Aʔc(3Dcaň\KQ8 G1^814# XcO)ŒQ SU2sVFb^/ oeAV,3$0}K=ŶwZGpc 409QA/Dߒߑ?|6p/!7P 0+ffCIKї&;#٨R.ü/R`C3 ] p11>uueb^d!>@ZQƦ/vSᲤuQq˥̟&/ZweaIwj},v`6$3^^?=[Xeu=K ac5U }1ģyOͶ>oˬ.b@0@rνFT$@H=59[􇤞MP8;5%ûfD4 @-7t(55adtw6MQlZ|,QHpG$4e[A}3h>{?B/F*7B>k朑b^󔲈3?V20%[geՠD9[~O=0*c?ۺi}tvқZJOI홱z2]RB养~"J:@7xBy* 2a{[b vb _5Zʲ+c|W{X3XqBP}yXp NaTQa_ɰ ԸN4BXɄc^2Qa1=-7V,ӌJC6%x3 >f2#=Xe;j}8l0a PPxM zt`X?x)F ;c+"ۅ>4pRR]ĠV wh),k"1 Cv"DIfqW)< لpUkRo\ГúrJ)b/? ^ȭ=_%f1,^ > stream xWϏc5 WO\H q~瀐@8mgKۙvY`{$/}4Bn8ώC$t>{aay_}rퟡ+[ 袓$S|K) eB;U*_Hwt*)PI'C):I9$UEi DM-hEq~lH6 48q,>3zCeűm;̋-T+ߵN.g ߖcQ*OlCo O=Q5Xw܍dRg.E2A\fzooY[!EP5yQ)WY(-rHgr]Щ2*Vu̫Ԉ?zk/  p*TM6Ôw#9D_m4x_W회%~gO,@~ Wt%mXޒ]Q:F[\c9haۂB4֊[f6Na:U/F9p(?|º"xbRÌ";*\#rl淫Dv \4>^;"FDXJT+!1&8` h ,st!ks~>!58WtX`Y¶8P SkhMO퓻+- μc4 =-9XJVxQK7%W}WeaTmHj۳*m&iGxp̚}fmKl 4PxMˌy.[o!^=Sf䛜8T|8cl@8F3&u28bD̄QZ#\2r$x-3C8ˀ,Zw\ims)|Sڐč'ނ!MvW`#\C\v5v\leN+endstream endobj 318 0 obj << /Type /XRef /Length 228 /Filter /FlateDecode /DecodeParms << /Columns 5 /Predictor 12 >> /W [ 1 3 1 ] /Info 3 0 R /Root 2 0 R /Size 319 /ID [<36902f397855adcf678a5e448d6033a0><9b838a50295c047c0eeb02c555336b19>] >> stream xcb&F~0 $8JP?@6P y=BFI6nQ=mv⠴!"EA$g"vHh)eZb AL)kV6GD `F7)fA$[!lZ-"%" wl,"9Dd6䜺f"%~؅i`5& endstream endobj startxref 843560 %%EOF plotmo/inst/doc/modguide.pdf0000644000176200001440000024141614664222460015614 0ustar liggesusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 4462 /Filter /FlateDecode /N 94 /First 791 >> stream x\[sȱ~?oq1[j*Y|㕼YeS@Ę"$e{$҄nqR03Ɍg*3"ә&3_y)2 t3|B&xtUdx)QIg*p inQfZz]sikXfՙhׂL0&Wu#ufq4 .mC=9d&}挷 y<8KELba0yb } ]Y}ͳ ^K*I.C@P5(\jC4ĽC!E/m|Ȟh6E|6ûl\ %:EzwJ]3+C"P]>oKQ8B?)^U Dڕ0#7Y9C$̀'4Np)]z JU5ΖD\&B2QI eL* 鲘⅐nAGWPi$U0fbv3ajdȵ&φ'؇CpY|]g W>,6{͏t ^Lxzӽbq8/9At \vݠ"o[EFjhyI.qQՏ72,L@u2L]w>%?ZbH$r_\.z^q'%;b섍X [^΋.I|DDX`ł`JCF-'b9thkpozаbqrGTÝeqw\#6F-6&&ȒZ[DW[B[[`' 9ڇ,Zxz}OGق~;WA8" bm4pS?ݍ`ڨ<,OOanKC^4% T#)GFqmD$-+$tth ]CB a=g쀽`0W5{8޳D>6`gl>~*PΗUyNِ gѲb 0sv7apK{YLab`W0xZ"g{ͮ&c)5kdO N!BN:NNN߿}6I{%dXy9"Yl}XBcUl\ rA]' rX|J!\WDAikekѾȲȚ*%lZPίUEiWZVȖH3L aǟ^},*zf0)'bQ_:v @6QYjkRߨ-mhk:_DմlNDrp]C1-C1D5 Ͱ ?V;ư> v[llz,'oޜ~$}SMo`%oC}t%ߴxCےO$ڒoȦ@Goz6#Tl|3&#++V*k7{5*+n-U6QZ6D-Z+ϊ~i%nn$Uvԧ* z̺P$}t;Ӆ:QRFHX~`7Gүcx;^pݶO"w A7/Sz=bC>_/d;Dz2[^񋽃j87|6r;:x.^4=mER$Wbjn9QH-˥AQ;D8^ armW8Z[,?smSh䜹6$'1XD O[8ylXB{2-l+_zǯ]C:_|GK|e(A?֓>&պN{0hV,0Uޥ] M 76DgWת~Js$>N1!CZT[o- ^`HKG`úsw!Rw\dk-$}[O+}DR8TtbJ"X@mk <UUc.6G{:ɠ&#ePrho;Dž.nH$"D =JF>(n>Zn%-OFi6C8%͋mMl$Ti{K)=^YE}QҶpY-s)P[T1VL扰ь{W˧iC9?_o?!uiVy/ Cs@mʼnn3tLL,Ӥ&M4&wgmܝYT}ڥ uv 9rF5<@(A> ?-g/^bȽrZӵ4 q<^X g6kBN? swng:D/p2(Stn5}s WrZ yWp5|g֠ac U؊#72l Q3J)U؜ٝ5+hҷܭӜr5/}G+g}5w-{||_'gLӫ(?=Q(J&}|^iwP&)8NB^\RCxPr{+ )f5>W҇7{ISLwcV[ j[oV&>xt7/`uU,/g]l}(-]h6D:seoSB m8cei, `/aG>b:ُ9C;+ތ5}|zo?{gI [1y5r}P#(x]MI#ULIY`NJp%@bfN0w(5 R+ 6}C@M/IVp#VIZ_⫝̸VJ 86d,k>7;;9QÆ,x>=Vb^Li2qjՙLB4ɋ'2v~ccBqʦE+Af277뿂>e7S772endstream endobj 96 0 obj << /Subtype /XML /Type /Metadata /Length 1460 >> stream GPL Ghostscript 10.00.0 2024-08-29T18:49:36-07:00 2024-08-29T18:49:36-07:00 LaTeX with hyperref Guidelines for S3 Regression ModelsStephen MilborrowS3 Regression Models endstream endobj 97 0 obj << /Filter /FlateDecode /Length 4584 >> stream x\Ys~g#-˔wxJ9q*NeVCb\ҲӍ0 `fErUjhu7F?l$7͛dv8OF9e7'GHk' =99vNLZ) ?+Pli}5[[Vz#N QKe1*D’oM_h\yNMKCN"J`Ev93QWrC?ڂ(O ʈi&mBeD9ɠrApR}$ a%D_ ј[\~ 8j~ ]^aRdU@9%w@H ax)?`q~b{g[VՑ} ),3̟IlOJZ^Mٵj^gnp z@?<ϧ۳H fM ]-Oƒ ()%9YTq{C> ZޕMZGj GhiJMf K(˃t#m52>gω*@n.C2#y察E|`|1BF,-d bSsd؁ˑoe÷mbGO)> ]D0}U#<3kE!μ jO} 1TXXv+F;7dvˇcWzClni`\J3|M 3z$ 9bm9X#⢒y@t {5bgE7+Y\ڇ2:0FDlmIU7wsZ'T8}HYH#jOxKKH Qk chu= :g=ÉKP<}ִz(e\cNʙ@JX-Kmj-+i 1`3Vmr2ۘOgePf^T{_ ].@Be /%gP@|Jk풉a9p05ȇ SkF]?)Sczcx<6֐'YL-\t 5(.*.TAf*}N/N;C!n#D(a]H u #K‡]Wc3u2#R m :GޭU fL\_ `VMِ ywlH5sS 'R3BS O]NZ]$tJITh m@>x)\Ԧ'*զB+ٗN6y]DrMϼ.Ctb`7!%R<_3TC<=NjḢA?ֶ/p%a,)U1<3HA]; Si恪b"0VAwOm9<7?z-[#\4#WZuc|su oT5 P/ Gk5ȍ3:qwj!T> S~r|SưF J4oسS;i?_?4"q)?Za&=93NqIOWtq0 mQL{eO7 rehG׊isvndelE}#,}#`',P86 W:s0nnCBx嚁QgpW8pxz<ז}W @8 ت0!59}j7=b#c'0t3葈t_ZM[is/7~Ǝ 1d!u^_[4>E|ܑX`"~!`NS̏M?2d^)mja,Ce0dQ3҅nkep ܴ.efC0W1a]f$!{Lxt,?iYDj݋fCGд%ls6R>~f&:N>7b; n;= Dck*o}fG)M9~s}AІ| `4C"/x7&u% Y'/b+N- m0U&q5])m$;k_/xv0|r^@7ivaVHEb1j&6C`.8j BP->@ u-yIu")c9JIy^&R8qTxmx'uQbj,`g;A]>cz/|,GԐ(([Х^$SI5&p`m.D\ Dr|C<~:2'jiWvWl.qZM^bb"WTrWk\HhuyFB,Η~oBdm2 1\V윘tjr/TVRI+'*ïÔۇ ?xM7+g-$$J;D.3hr?(EL\rb7['te9umC_f?UDU-PK lBi KC@Ե{ot沈r)gIS; 2Et{mj8N2m(==E /.C~wʹQspY\^6cSE`BH9_4B.YcCKRƨAU;ZxfgGo̚*閘)'ۚ貤 B[MCL-$pW7vVy9i|61VίHO)ԹiÍ2 ᆯ6~gH-Ç'?O>3-8 x:#$G[92;0s]yue, 2> s7;x {ӽt1LKIFKA&Ow7w'v%>ȗ`i۬T) t7_P1u8_L,*e@5nj \*q_郣+_>a|6%@e&Cfgn gD t"7]."$Jƙͦ#Cy>?jotKy "ٻd3F (쇴QE~ jOSUY3T,@|#$?cB'V·.!oSI/O2U('7~mՍ9I5L > stream x{Tg\Xj-`Q|$!V4IQD . kw², F=FB9>b|V5>bsJl.= iszs1s~($Ie p<aJ'<k<[geʺџDžzbBƳ\ed !"7WC'HP ?x=,Mq'`q( BTgթA8Uq5mDţEjC^Q~At{$┄ ct1UDb)såTl Zc:urs ucP?| sMbR B+uOl ρ z!%rdKHmTg)\dE *A&Z}ޭ@tgQ9o13g'_>`G}@q?ʓ~6_f !=1yo\B\~лߨ@!cD[15\y*!8PJcZn M`ƯI !j Zͳ)+C>Msp6V04zK;\kCƫA[D+.gdJ1)|V^kƐ$Zlb-&*x, Pwb %qzIg{I ;ծ@ <zDM{B3tZPf=/AgW[˫2b*6>ƺ %+׽| ƚ%B$}0(|)Ѩ'WT< %G176!(W~"Ny{0ws";ttseUZѷm\a/dNC];T-Vܢ>5b6M=,W4BK-}JnץE`:_;%BAPapNj`+Q^Q<ލcfz{rʙI{osV ?iqW%'8j\Ue;)Yl~&U GG`(:IJJ!Ctϭ%w] i;Er |&>0e3-nZJmҜ̲g4:e ~iY.#";-&s5;FC=i9n{_xYX!MdKR9Z?\T6$}gua珷܋u;~~e>|ύk5(C#^knz"g6AZ]lL)߻O^R KorW.}ƒ uՎrQL/O7}I6.aGa> > stream xYTW۞uegTDآػbXQJ# m)KgAC*[,1jb$M%9]ML˗#9}y":w$lҕciZ ֝ i 5hI\  daa)ci2>VھzGv8jO8q)S ֬al(j D-R4Mj%5ZE VSoQ.0j 5ZKQ+5EQzj>eO-P "jO-&PNDj)5r&S);%fR6T' ՋRSW)C^l);/:Տb(_ ՟**F-#١:SjIwI~NwÝvε>%}hWf3ex-ۚ^oڌ1ݞ{Rk`/{OՅ6>](^mɶQvv'wt=}֯׭ߖ7ވx;/mC/lo` il%kNlJ:=b@R^lc-0rN{Czޢ .!O> Ez -v}!Yɰ nA9;iGuv66kM&I!R޿}[ zEFHܦo:n.%؁<ǠEh4uʁxF'q?x>tC[nuq&R$Mx QΣRSX >fs cĢޣqRT".' N݆<CViF}˲vWw\",ewʼGG6zEJi(l{= IZ*Zy?`aG<4K ̬Y_}6I'5Z wJ{,6LDŽ3H,Tv:o_ dFpcJfi?; x0S* B!Vr̒_OO p_7$a1g@%J@F^_h4UVo(H4H*}u''?D՛DJZZ]*.wTd/;.ǫsyK?>$Q8r}=$I㴉 LIRM($efi71ux aqYx\_cL`2!pFOB}MhQyԯT CX4 0fψ1*f縖ҫ9s{7l5=Ws!<(,C9w{ΉXe;U(Ȏ4`0ݕd p8J2"HOMʁ,Ч F'QKHHaDbDQ[%-R냌,a&vowfb!}9XރU&LfW?8tm!TɰUʐ/8^->sܾmkadf8B]Ll!IxԸP|PnQl&Hԅ Q ɉK^v/}Qq @թӒ f Sĺoq#Ae̅@>fdfi.߶(1w*uGlC6oٴ"u!K[oH(iY17gǣR:-5-{t-΅b׷Sc^bK\`[]TUl n[ ̣V14so;t.Wcj%dpl,.ě$kRaV]85NAJ+LYNMQX*Uց< J*l9rpBE)2j3KMAy֐2CSqуDMAYYIJШT|<`G#ϛ[OD{6˅R>M2hH uk@0,=h$Z%ܕ]b6eW^RmldIO_Յ̅c@IlIP*%UB'0I(_ sQ oXEꠔC7t"3ˢn` ORt\ԞFn\L2CWqGP-|~:WYRtULXȶrW`0\m*kj[ mޕEW.-lBFF6J.Ptf/љΊvܷ͎j2Ҵ:FD#3֘}lh  hٲ% Q4[S;{bEJҕiɉdIonfːj47Z-A:%ڧR灴}-Ex$rYnqG#X4-Doqh#o{kԈ[yp3#J'Zr>ѷE1ce4"w`sf:9K' -UV^XXcZ?˛2C Vʉ :@X2_7>~{j52bPʈ)V~Dό _ ]%4#$h{ȯ rwU;v{Q+R gb 31z˶<3Wyg'qёr25Vg*7n̂+Q*[V˭t IiPd'ҋo8xZV EUT]] ["*GmK20_>k=BD첿c Np( /!=iD',0=`-,|)3!,@qB9DDԄBJ*k jNĵ,JsV ?gT(* Yt{gsBxCzG> m@T,|"Ր6qth_eu^A;`BU3 |׊rOH|,h2A g23/ߢ-ENu(AB- ^M]Ν o%7bEq_ꛟs'\AxF\'\-|ZC 5L[IBxf;GNNěR&S !KRβeɅzbHOT2Ŵ*n'U*sq\"V,yKyk{'-C!Qƒ#R M'FXZ+)a%!i/U>WYN_[|Yքu-ZRY:3\l;xϏͳ6g2qU ?^7rrhNQ $0 =a-~Jr~$#!A1^_:>_͹2Sq#1s=j J jv%Ox!̞"Tyw_Uƒ^ęwHfJ*d*cDfR*920ǭD$lPyh2؛ǵҀ#{{Rt̶V}t>cLzc|}}XMo#3{`afyT Wέb` O:vf6O={ƒ[):t[&.Keӡ)6 ZںzuGvNIm}rïN$Y <`H8 +Lm.\Cn0I^#qfE+ww:;!cObgTG<ɢ Pq*Ҡ:^4^@JɁba+J#BBDGY]RZR@(DTt,\WYO9LRuQdI<fk6idtUXjWݺwedMZ7:DxTX,LA]d_+UөV53w^;࿖4{ +5w7&.PSMO"mӕfuJKU;u[wIюb?ܫomP9wobTd^D `vd]X> stream xW TSW1$H;ڨZQ9U;c]PTK,.!U BWÒ| dQְ,QdI")U[3ө)uҖLgΙ3'ܼ{}0Dz Xq:m2pCsOM S=_k=l=9(Q-}CB_ |qe/3,5Ɨlc2~vfx2̋Ƌlb63oƃ02O13tfd2%$[18T/pW*ϖ<{En:&L1k Si'L?|g[?X*zWK= MAm&GLӤ6:?6?KRO>FhϠVl+! =8e䗉lRb6h~tBSȑNI;d`D*>ŷw8O5aɪC2%{ /%[k'z|U 5TZz":![# ֓aEj6*"e<PϯT\!"q#DϓQ^Ȣ3:VS S'dDaYж<|W+Ġ&ސ]ՂNM$;fJh:_2ylQ*kG#Ք3+wIpNÕX:;ZU 6d-}eDYQ%Y9-S Iʜ\_o?04JWܢ4P78Iv SIʼnjEh!;GC$/2 or9##WA| ϩ铁SC~@X64e(OT>TE])tŘ*թ0-%@`BqCקhZYL ZquGDCD7α9$??{ ̺ގqlM'ȟ\L_⫊Ǎ `Wyu՚hDڹ(&V iR=Z8XuXNg~LcVTH 6M۫7]C0sWq`JX5dC{!{Fm~6jo~ed&Kr|]gW,+^ HB16X p6ɼssZѯ_{R1cFo}^f֗$2'w\ (K]~zYHwpz`ԷZZNX'N }mwHȭdO%ȧfe'{%DMkzw"O8m&ynn`)Im<8l-)2;/֌bp!?NxǫLuI-AJ:Iͫr7^Q ɉI`S8xhnŗcK-N0{!W,h^rT_Vr F\?w߽ ^wK}ܴ޶+Lx<77Gڳ;Ol0xƌIT ]NNO?js~D6Ny#o+]?C ;] 0:mKv!KW*HOiuBu4lCɩ9=1S-W+xl+}y %αFmRETa7u;yl{"Q$\yq26Cr?bU1&}ww&@ Gሾ=5l^fig f^B$ZwO./֨7FCT8,#B=* q`^_T̗`t?}^xh7h)~fN=?b 0c.P^NMD%[j؛ƳlyiٱJHܧ Wun8`IԧdFǰ;>dW=1n{Km_QNw8ݵ1@%_\|&~ DuH1(R#GE^zZi(6VѨp~"9ITVOC7RC%k1 ~C2nOx]^tA_|F*0bZ㛚uH R,|~ys8S,aMmn5D"zwv*@"IBV63%Y\a?2yt>ciǡJ8ޡQo.8(XʚjTEE-܎OϿ|7[{ß.-D +}_ٞrtչڬS yK505xEF#BLXv6Cd#TcF_Z.r9q-jNi?endstream endobj 101 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3671 >> stream xWyTSW1剈3hq[l]T:. %%,aMְY"^l*m,j]jժSVv}= VzNw~]a3b5o2˨+Ul*&4験 ӟPKrيȨ_jkw^'#p3hcpkN3gւӦ˄;L''Dl&N,#.kV‰XN$V+7wUl•CsՄ3XK8BHD`-1@}TA00;6 mjE(t$+I,^-B͢ w~6ahUvߏr?iёcc\=WdcFj}ݡU1 GsDBhh#ȲFhj`VlDșaQpo_Gh]|%OiȜȲ>挗 GFirΨޫsL3Ȅp>xYTL'"=e(x08O<*ϗf@_#mG4L`ix vv>B ކ.k>|ٹ >[4ch* CFtGȅr7 *ғR3LJU 'anh~ 97| qY  3hD?26'(M tXf@jk"o,Kn~~Ee^;SX=z3O6~aXƌ+YvcnGes4^EiH\ uU-qI@`G䏲 lCm5sNܒV a4hUYq$Jθa؜ˆV_`F#n]<&gϾ**kVly#d{МlUܳ؊ jK_&)j<3B$Gr$P ~0 t_~#r( zKəK@CS̹I7bqBnw`L[fiCɫ &Q+t$%P 㫡JS9ćoԪ- RV1TApYfdJuԳu0 djUiQ̓,Ҿr*A o~6HWu꠯z\/ VU볏hhjK5{`?eRB躬kbĺ큕;?h=!te\͛|< v;dΧGEmHF#1!jzܒɋ~m$g:Oh%a8AH1 ]%G@5hs_dXoIk?0EC5*n@ȝ Gޒ ~ۿ̜;4=X[o9/qYޣ6[s5p.Ӊc (W2^֟WeFqr~J* ;;ϱ4WKs\Q/ ٩dfINq%$zP9!7y5ЁW4c(DϪ Ƨr>MҜ6v} ?@sj@h WBb*Fv.@+U[_QWb_,f4yD.|ja@'묾YCC$.|{]L8F 4R0SL>:|1NJnЍ=Fxy|B'zBVWu¥; i-zVWVSnRk*m(loPxgH|YI]`ח/kV. DxlԼy-4/ c}y샓G<<|6M)=}ٱ򼶎: nX<^<<{Udh}*t>| NQ_/m菘VFRr쉯Zu!:"\Ϗ.۵){#B"RR3apL'7cʦmbz D~{}3O(i3!F+dژKDzs܃I+ִXPOCɾJN'΢gܪ>:Kl=Q[ų׵OcVfSv%2AZU,)}\ou2bLV]x9s>0?.cayElrIG{yr5@np{D>*Xd: q# ~ReбS u]LqNVav5M0|1 !%*]%|Ыfųbo< Gf+kbWdη^U_X}v9f.>Lv. bDJ^_nkU{rj|QۂZ@6v1iQ7RԭѠ*ZX#}k` fjlgJ;K~sHg榙RZN* H¯7!@"B"!ևՇdA!f}}cHj~ p_99P@ĖGb|_3S3S!u|tebyMaEIY,oW7P_"tsU̞},[Ѱ9PDUGD(91|H]Ybo …ۖJ+j+TEaϮkPSYqY*U ~%J\.)9[K&I@jCP(M>h4(Cr/V_gjZsw\9%]\PUT4RYo❉I8%XQVTyUiMiZqR"-j!=6 /x HZEt2?;r[A܄b< Dcx؊&Iˊ ra/U^![ՋٰPr:Z* 4\?uyعs}#bS ҫyP<2MJ%[p`d 7u]ʞQH톃-؍;endstream endobj 102 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 423 >> stream xcCMR8vz-  123OEpbcVs,jŦf,hjዸ⋴ #h,t`‹ ' <02ZYΤ<7#B? rGlwYx?{FvťbڽQ"DfVT@htkpozc,MI%ڧϋ1# :Q?f{ku؎׃$Ena}{mltNx~} 7 :7endstream endobj 103 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 432 >> stream xZCMR7w,  '123QN͋oKL0bg͋§j~'eg #e'͋JiuP~>}L讧Ǻɋ !74/XWϡ=:4MFkgo0w!¨oU CfQc3asloozb-N K֋06U;ixwlЖu4a}]qljeoYr} 7 R endstream endobj 104 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 4017 >> stream xW T׶c /ETmCiPRRRdyId@EDp젗[U-ZzJOI[oյ˿VVs>n%D6dlǩ(GgltFLFY_c<6H7Mܕà=^[#"w}kiK_`!EyRQ[(/j>F-E'vj-ZG}JGSSj#&Dm>VPSU5RQ3DP)0eGRǓ…vvvD2':CsEjN=Nzuڜim7M1}:+.^iQ:YlѤs(Lq/XO`A4`A\3A~t3%>pA^4 9-*LւfF|gϑGE9J,JѲ hn-(E3)x",14Ms8৏9w6uM I~Q;!co3r3X\{#P卙]#;DyVw.$B':ԘTbOl zOEED|w%K2Z\xqq_.xz5AIԠ#͞LEh,zcF[F:}>RZKQIk[ 5k8% L>Pm,mnhWBȆtiE0>3:|@\rmt;v8NtE# l!j^%vÏf3FAY%18{V+2T jqQѫsQdd[5-Ƹ#(٘pdڍYz*ct9},ɀd vS $_4T }s,)TּhW!WɆӳZMhR ` FrBY 238"+[ j4`SzD|9AM:Ɉ̈P<:fhe\)N/|q~i3Mz&Η$@d ٟq C2B 93{ Ցۖ3'/@0r)HA+&Ulp6r?w8Sy _fw;8/zK\ =ҾsGN`{lԥuܖԒf`O~CLۮ\Oqg8bdw19mv>nGO@ 8Qk 4 J-j!BlSGG]g8V5UE Y+]V.&`BE~mQ {G3yP}0*~n疏T{56ij4BnK9ePƖ/<ߥHVJҘ3t@oRٖodMB#c+#Ž3!*iDTU#V1ΞH"N[ >D:*Y@C K*;O(^h 2h?VyF RND ē:P}"%qShYJxj:3 >8f2Ht|.X bUjqS-#ĥPhL&ϐn js^*SReB4#ҷ'SH?"-v tB< (_9 (呐V'6tUM_\)<g[49g\EAf00b҃hi 2 1Ͳ_b-#l$sHEj$"$"n-亦 Qec~! 蓮*ILL;n:eѳtTibZY>  ]4ɈJWoM)#[yn^8BOٷ$ؤe6X7Qlv)N"VE4*@WJ5IX >lYZb}K.3|!0PX# Ta&t9'F2Ol58-{(ΖY;7yXg,j.Y?/B4rEš}l| `6%G!h#Rr%Л7 d7t!ZgY"#Se*3 ILoյx{.!7k:7 &^Bk/)EлzusQRTZ0?!OL$`vUne 0wΝҞW+i;Ж_MXZ^ȕA&RYY\SX[ټ;OղK+5U~ ^IFZr2Q "ʂ̉)Ȭ9!GW[7p [CRkBy퇴Em{oB Fk D.ÿ;y1uℚl302|idL!_.~9)%ÄfqM) CގuQ-Ǖg6x('FZH[֔rj[ E: M/?7^wY r=Z.h3[(}mt9;DIXJX9ZVт^jzJ$0d~/qn8Lmx XhAyu^ W *2ۜ>(G02$yʃR-]|7<Ϟ2 ]RId]si#8.t .&HTޅ/ hVRf@4m֤X/N.EQpH֏~>+USi`$:~?oy_yWGkJ|^{zQ@ku Ca-۵.¯imhpyM O͞ Mi,-(*&w*{OK~>A+K]C4爕,~!n "'4>,F<&BwHty(?w> وp4\tu:;[$68G[mWe"T]yq Z 96mdfVڀ-q9pOd#>XP72 &꜑AY2ZXSJ}Hbz\*QAy^s7gZ%Z07/WjY{d l#m? 8%]BR#pЫvh*^V},ێ'eb!%x l:A10yBoGTrvҲpUlEh겿f#W(JP$K~Zp /xu0~O?ФR$`s 8:S6endstream endobj 105 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 5493 >> stream xX XSWھa o;uZ֪*ZmA.+o ;_XְRQ 6uj[[s=t:7,&?3>y8{η~;B xy{ϘnMqܾjG8ڂvܸQh(o{xĞȥeQF+!ݹ"n~ ]^tٌY sO#ޞWOO"VkIZb2ML!%/bbxLCL#ˈw1$+ل&p #Hb!D"F[ gBDc_% {$D 1N~㈟s66E6}vݷB $lfQUaaWGaAGW'# G:<E 4q7EEE"ژ?iM{A] .]wVmu{<}lc{ыU'#2sݦU u( T~xDUѐ:(g~$+jIlOh6Y=>@a5PHAcIj2MɎ9Px Cn y\Dyv1I_Jc2BR~&1X_{x҈,-Wo<9h'H*S ՚lJ~vn<lͷ!go^7W]>k;/F]tAûpCtׅn\X+K=IO;㈪($x-!eO\h+zАQ; äeFALWBUP 1{v֭Cm7q*Q߼loֳ8dP.в-_4_t3 !zs={c@zbȷ91V_!X%[ ^f E}(wuTU2_v2b^\61}Hy$oyFkpWMh]1$F+oC#uT*^<q(e?і)-#4 윯jt=BQ>#[ oQͨ⛀2ĚZ JS$g0z_9~+znkO)XO֏um-1ZV 9#B b#ldE'LCrhDQnBuz)lVFY7h2bmMM 3v6;_xO 9?Xcc@2\1> I'C̑4c!s|{-/q:ʕ7n}`pfl43Z+Hz~9Q|8O#ª-E>&VigMc-ha $Xn~7YI$tJiznBFK嶙wш8 ɸ(~jd;M}&Vp\y(RzQ !1&=yf$T&Ph>\Eܛ-?n!X4R𰜤 (6TQCa|ht>gދr6tUv Ub؛ĢPuᗶOazYMM@Z*U@P;+:cM]vGFy'DB;. ڹ@mhb;DH٢HL#M?Hi0UPϺOZȾnм7xD< a V,_ ^d3a=v X?S>9/ޮ4#&4b2x|JY| Rxuӂ` ^ƃd)-#qHx!)EhPg_%%e*}r4Z|X7h<~2 2sLPC UW!c߮ǐkQnBQ?ІpH͐$3) ҭ@^I@Ū+5@O}GⳔ/| a~kyQMS"Օ~/Pdi<g/b+}W/(bpϜ{.w~'cF+[{z׊lwsjK/ fց[cqv;ijfZ "2~E4(8gB5Gki}%!rdG>hzZsҥluXNɾ]z t ^xb][1H+\ tF |u@$c!E EN.dB(*_] "gLET%a_c%%t %! m 쨗eA>PreAY.⼒@s,*ǣh+CٴkL7=.$,q]a!~ M:+jwsO26U!/$R_%2uUye%fym;eB 4Z9`l7Şx h,!=p4M2pz_d<$:e n9 p0;ˬV4:M X0+LMABdM㤛x$>lCbPZcʎh:ԝOZybEmhR"'x"+xc2S~WYȑ![!˄m,v)0P_ /;Icz/6Y['R+rfg&0)CTDm΅JdסMPeڅhd/:"~)ѿ΢–S ƽIJH6^_S5usv͵> stream x\YoG~mR)`4^{wzERRMY'"2*2+ic V*88^X__?HEjo\cQ"gWG\88iD,k\:_5k|}\^K&^Ȑ!$r!xۋ8y9{# llxCqp)>q@ia+V7:{Pz}b=(wy]1+os2ϗ˷Vws19y/HtqYc,Ȯ/wH">7ubxt&r((`/cDNk:f|r$ѿߛsqoώx-s rhT^8: Ii 9W8uy|1u-߳痌U.}Oa\sޱ(@*KutoPut2tR. ^jcM,TO ]҇3U z?2(VwL"P4Io+OnMI3u}S2CRiT)8z$_*1h! +. i(^)|`a|Q6*5vX펷]cg=fd0j8z.y\z~iH 7&0#M[_,NEQ*]*B p6Ng0 GѼǕ! dK4CH~06˖..ebgfs >4yܚ,c终 I "Tiq[!ANLιvhFLǃWpKgrX=:̾o_#@SkDo7ggz'mmÈ3>N陮Ip[]bQvqQ5s㾋*638o!fV9q kNYB;~8dW82|w|u$F&+t$3o5H#Fc7\VCOE eo eT}'=j7hpH{|[W*d4@[2c[b~6ΕäuMPR.8I2k'-\n:^(Vn:9޿Z)a&Wzh'*tR U.g|g 穲K+:#7@14 ~5ZBMk?s 0HgC(&%ɐP dى.Rc/QwS5@^"0pREaU8/JPMls<YUUU$%ƕaJ 4{aΈ}#D"OdR YO:'`6l.,T́5y :%E􈿥 U3fwF{65 D%Z|9Ia(9A\?mgU's9j X0 :EZ.#ܐk|bwOa,wcl_huNnڊ힭L{1*261q. !5vdghUX r;:0b*U+kxwUgn] fa lW ed e8 T҉`>9Z[ "뒵y@̈E6%_Q(V̙̀1Χo;) KyDZx_*#i~?*~ fT5Q]}$j4*~'u<0CA5} (FpPn$c㓳B";q;k 'AbY;܉_fTVcH?"{ =Xr>BF0C37:1U4Q'|.ϧVqއORߡRYJkR00p밞fRkʸYw^*MG~_rIbȽBTY۬ 4 >D.EhӮ,?HY̘Zf$3fY1e3Z._^XC1P) ̉1 ^ǓP>?^2IKےTp&@|FUa2O (4k8TpYli`Y+@s(CScEq ~AY$-DE9&ĂBFG?$fH@ G{@. ?THyY {!dχdRB# ,DZ;~B2$ޙ@ӅX5=dB,/o:.: <"3$.]U"Q\:onU>~^uҗTY36VC*d{G`[ef?,gzؘk3*̏?w9iba ;`בZT䡊~c-'7,EaEE,8[%:@Uc <^i*dxdG ϟ)ӱ1Um!MIn- bf U"Ōgot$I;wRٌAf˱[z~(Q)p)̠U}z+8T SS1fBav|qEFYV̨Vg/[{QRuOydxu64MpFӱ }߲.5\Ɉ*&|N85\.P-$5}S`)س #5<,W7[w%Zޕ~v4bVA' IɹQX)o$sm5~fN(`\YJ}oQz7` a}r" `o3̥UGW RTU릀ex!ǜWc[F;ӣ+r&,6C;v۪<puY4'7lWSo[ovM:e>K\{%r(ˡo.Cm5 RKǿ` 2BW=/zKJ?0+:WTӐx@a{6 ~ը)e.+ez@t56Xb D /p 7Z(,*2`2ŹV,F#!F>݊8_ )皜}b__] a1禱whjpw/M7_r Zr:Pp83] x\5B* dPu'dyxOaendstream endobj 107 0 obj << /Filter /FlateDecode /Length 5871 >> stream x=io$u߉Bal}bF,1YfICp?>jɕ~UJ?2/}ywNߟto.N֟r>yŻ?uzbSd;;~oglq7gҊ:=;Cja1 exϙqM^!dW^mnp &vL|_cb !~ʹv3sCJ-&y8o # ߕ/g@LXF Y'2e|vsſH) Dc$3,q6뇚䗸P`4iS$8颊|gv0'u#;uR1q@Xd(M!tv|K>%#Y(Qķ0@rxFEL! @x.&ͤ>t9dffg^ÏĨ (z` 0wo͒N#&~C5  ̾P oj|/9v"nꉫ]9ho_ƝCa3Pq EY؄]+p8 5V "LpBh ڒ&\, tqqqm ,sB>Xd(¿G_P~7EtXpH,MyIOxAYtB$[PK,)XҵYUU_(.چ; N5\pQAkD#4eO;I%i֗,b}| i G?4=^]>X:|TGW}ܺy-*' t_TK:?TJ.&S$Ĭf^c'`{*ИO'mgnXkq'ŗ-_5T-w,F}b%1pT4`6I9.<(! q~/_3δ C"1E°Vԏie7`ljIv$ 1'b:j￘) Q#uVKfOYVR\` DABK|l-IU=#4=hDm0VM8 &[ߟ]؊3!G0SD7DM1bz Hp!a {*, aŊ"| /1a5(41LU~Uc1"p7R.(Oa*F)4=>0X T4OcT@3yYt+14V9]VS(T8C]KZ3N(K[pL,ZH+~VXKc4]>![Of8R+<.3FHJ+T$ su! }l`]+c,׿&QB45ɗ3Co@BJts|["XLK| ͏4J# ZZn #Tw5q莫26(WY 4B:FIsD4! ھ:>oCbXO{5|U6N*9/G( !j(WXX@MochH 4*. oK%(|n reG$tu:6 ktzm*8hIp &KްU~Tj8yp`J0ҽXǕտUײ*eۣYa֍IqUYcշzud :yh#P#RB N: quUǔC=ֈ $+뚿%"(Qwn@Gi>ŧ%*e#TFa`5y$!m(]أ4֫$qkYޟ`}K&}T y]%I)NZg6*|hL!=eMZS6? xT$-Bbb`' +͆8 Ȍ9'nbԙظG7Tq{ڨ>W3ȥ6z*obm7Es%'kZ9p<(# Q%ԗ 4eӲNyZ&NMOy:D92ugKA$6tˀ^b.zEI >$QDL &'B?'~^5j&g+||] + U}  "GA ;?frֽVDT}8, Nu(I$/RyPjd_ ջ3cܤNT>u.OfJ?'mp9v62۠NYv7:P5(&B a {<0tl/d9 RC}f]to*ރ)vH]%qGk/Yº4DΤ˳ȩ5֒HùIdY<Õ> Gms}4ǴCb] Ž 'ؽqNHlsM&eQgѬ|;nBt?I uiQa;507oAƥa.lt÷IzZvWR]pA?,ؗ#f[:sfPDžczbgqlGgN܊&Q)pW, įU0*C>ޣ3I#NNN&{u5'*xmbYK><-Yvbnrq幜QidLlQpB\,9C: u܄U劂+Ȟ̾EEq5 h/ ~^쎎 +L/c-k{8,`+5 _)rY#/W8w8XuHKޢ̠],l9q}aC3Ue[iկ0itϿD*[Ɇ(]1 Xw|_dVD袂CCTm"}I@գQDUB4wҵ?OES.m#te]c%Y>P2^$a B^Fn^FڊI1!!< 5͏1X P>p,qt1EwաN[(ڐ^x.S M~(4SʈֈRW,#O>0cm%Ms wᑲsoSx!hWI%j-EB}ij|Q*]KbI!p4 rmg}Yllu\eYˏJKÐP#_2ܯL\bq5unKHv8Ex>7l3!|.az E˰ݶ3ISKIߙ!ezHEDy5`Z'MrO]|ս^K7UK *Y slv M`} /W `"hoBJRYbm"ɤᾛ;ga|8gKRߞ/NF>讱ҵ՜Y,h1GU/']^SAS,OT>jJ^rGcضՆ?[ ]˵#^qUF& e%Nzj6aRr {{iN(=qk3B n8;p֫7!=kP&b&xP~FqVKeSHzL>z.܁ Oc"Rd6$¦?EҝvK|njv$ AHӘ@gcpSE8`n$J˲Ä;ӬD=q_K|l񮥀b{d].cs-)rOKUcjV=,]eDL.q:gfmf5_˜T cN)ON]{"QRl?i ,F-tFR}xyh`!PZa|HUmfT~-#{a-ѥS}Z0q1 qv2]$A_8?4endstream endobj 108 0 obj << /Filter /FlateDecode /Length 253 >> stream x3532Q0P0SеP01U0TH1230 !U`laT072̀X$sU()*M*w pV0w˥{+esJsZ<]86$͇]9>U6ݷi%Wm??͵/~/|}ww‡؎k[6sqmB ?"aendstream endobj 109 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 898 >> stream x]Leߏ|u`L:-F TD&J+_[Ҭ]Ki 6d2`ǁ3&b&e&8cbMh-Ee[L$dG-Tvh.u|UH293yC@ʈo#@jÓ2luq*:QYraY.Bz!Ia{_(mSg<u!oeeMzT_%uvu;ſ5r_(6r;Fmp'əُ_`edB ,{Gc q\.'+TJ6wNDo k' BgU`枪1ABDvI%/iLevv.ǿ[$^Xj*ɞ '@дǓKܕ/.Ϧ > stream x]K7r ^4t˅W aX+^: CQLU Q3)<g"gx_~4?O}8?={+5Eg/'ceivwjZbx''3F5''4F{ÓJi/~a=>o~ ƿoh7ŰMg쵻xǾ~<+/eMX.^9x|m#G=?GyIo߳Qc`g]>߳}.cmZe|>Τ:"%0 ne>u|/g|OýW_op7O2O|>[RӛLEJUsznR߻DTr2a磒g~d"܌`1FGoq}ONt+iMꀉP/o1qA^Շzc}[L pk~O;]>E>Y;l9XPޖuvmy|Gz2 ?O=@OXK[ly|)$3\^`PƧ.1FdP?j9gsN״+2DՋJM_4 n;iӯv.Q>.iX9A\q A bգ;S8c/˘WY6G\HPG3ym sI{d;Gb sq1 beTܭ.TK{ y}+\*Ie.NKFgVT@.V0"nf*O0q9 |7(ƅ/dE8xve.;U@V\>̮`lu^'^]Q-ʆv?aL& ɇ)3,¯v9HF JIoq28Tj FK"mBdB\e@i3 + pT&=4$NS4Nw3fr߿)k\?ԔSzK` /qY֭IeW>ikDPk ϫ+EySׂZ Y`cyfy#2IPVi$0w4p0yE,7-5 >է=tr~̨i~ҕV p۰T˲M:HԺ GFn()97k_gM?͠*FAjUsebg Y4Uڜ2:ߞ:-vRΗqWI,v ooGFW|C3֣M~pے!qIl, ,wmu~G4isA@.ߎWos%=S aϵ=Q;yk@e;b\%Jۺ i~Uٞߠގlɂ4FPx|8YY?FK]<-Ԝ l`2LCԸeB5 :+P;ŸfPPgx~ɳۭzXvaM}'amhEdi<%qo%$_3Gv?KF@Gh_> E=Kk˒8N/o}Sd:mkzJTO'k"Ky G8m1_m1mw/=|א7/a A3]\qrU Tμ3`P>*#*2^ZdYg_<Φ8%Âʮ[1qW]}E7Yth^!XJ^ҼKϩ-b;ĉl+LЁX4tYgU6ȻonZMl8B mEi?v߱bD Rr*@-^N̢~=ד1.ϸLc2X$"Nmpd !t&<֖D"޲(RµB eh;ahND8m=T5W!{ HZEB78KwԾ.]&=ܤ^+T6E HDv.ߨǽFaJ,O-P~s9] UH#IJ~9Abq:FcQOZ Q*@e6j9+L$%9eG[XtJHbje2h,۶[Xb7 mh L|ux m2=sk*CeQpH5cwG " qB;`W VFwuCb{`5-/sqihb|B2(Sꁿhj7]j@ 'Lh*!uA~ܖ59[[3sdjgT2HrFL)F}#L]P)$mpN_'D$KcGyH'!O\h-74*q|*ӮMoc-H2MI!*h5u|P>gpYFGGdZb0wbFaRGDV2z8(Aehu퉱4zRTfg3؁J&kj+ɃBuhG q62[k W|OU37h5`񯍰z ]Nʋب;E};?v}vv/ r3NTBOPb_*6$ !WP/͔5Cz-ҝݕIk|jEE Գm)g̨9 >4$CS<]W.#Ņ N~KW{/ټE ĭ`j"))6~[*IN6-ݭ?U 06J7iaqqkRnH8Pg/3#y>N3s66Gp&3}! 75-pGTPhw_r/b 鳏Q'^ ? tŊmʜN /Ef[em:G E*t+iE"'Bf-9KښµlZ⓭x$~^Pz>*̅-)X 2GΛ`FԴcŁy=Wm*>y列0L)4 v xSӕsj]iQ}UnՀMoߩwO&xLr\h\2p^b;cr7ѹ3&\.te0plgDr\VZŐEcdB±d3#@,,SkO@Nԋm Y*)D rlHiu^Qp/GLO|sT VGINT]Ӌ25E]sdsi?KaWd’k*rƎesĸm'M6d{xPʡ`x1sAڦ :;jdb[q2T}%FX]L! dnc[R/u( ) -JpYj*XK pCS9;^ZA$o *.[h..k Q%q&AeZAIyx>G)],5/U)@:`&.f2uTE|M|(*ZNم] 2'S!{ƅ#0Na"bfroJ}ؕ4YZ>wPi9oH 8V*\PNgS4`}-^>;TR| v5R)N"zx*fx^D!RJx!>ZRbw2kMſ_nW򘜠W4Gڿ6AMI%[nm)q>;t |n.,H9dN>2wj)0 ;l"<~đI4Ԛϩ^'&.8|dޏAHq|Q} : ǖ6 9XMr Z:,>PwclG/-Tq7QOFoBxn)l[)H#ufCL=&٘r9Me!;o(mo 98DhJyz؂EҔvCdR޶]1^r _Y̑ʐʿo)=|LWB=hg,ܶESXŒ+Eo _ Y0VVm+pPMQ ?ϡWQLh:d:ZADs[en~Nz= JO΋NFG]Ks*Hjg2#J /υ@kH\I.9#lۚ#?\eK~iU̡n-8P}`1|Q׿Fiqìn,GbTďkK 9fP&];$)ê//=a:T)F&hs3_*R8+;m 9v|KR+;RR DQ Av  Uvjb1 BUѥw4Qmx-=쎫9%^w3ngxG6S, AzQRF{_`![/wmt2.԰0Ns w29w`$v@Fr*Nr|ɀꓕ纄˽Jr4¬ #U,;I-SA^Ε>uXT>XmFV )JbMf0TAFjTnr@~=T )iRkfza4fa(0KHe<<ۇʨkx}ZסΏIh|u2[Gz@I.O7;J\. اTKܹVw%UtW{ct[TQj/N'|fԓZ8!ݙ/>r_#Jlst9|o'5]{H߳3[1}njLJj={jTσAtR|J&Mq> TP #dosJ4I %C纸}\Ҽ_2w7+IHV qI{$g|%nѮFMM~~o MHFyF=/w7Ix=h*y/ G:~Ȟ'yp|u O"0Xp RU}s&%aa:J$Axo+ 6'Wg\-+n$O'̟8xEΟ=7v9|S;>L{ Ce-Dw?jjl hN/kIizbymc /(s˓xq*S]=wVz*&Ya[;wdim0ʫsX@!H3*B% ߽{IMY'gjc)!gwN(teEYBgu9j-q!Ca1o6G8X vn|k^AQ?c?P2H^KAr|d$x14z^Zx.?Glf#1ic:C=ήyOx9?qpes:2*ze+'&ցSF4۳G>/endstream endobj 111 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 4337 >> stream xXyTSg1bE1_ۯ[;j[[VTPY -$'7@¾*Knk*ݦv~]洧z9s htzz{<a7qٺ ~}(D|xA]zy_ >@~f~H,s DiuI7nJK8O-|sģzb8I"bDB,%ۉS b%XE&!:"BL#$1Lƻ$ˆj w uG&ΘDL9yoY4%l4SL=ugioOϚ< B6h9.P4 fĉs& dfu#ʩautYQ Uq9+GPcu&B RBB Zi ׭z{=C!Mզ`iI !ڄ>sGT>^0D[|ĢZGaln.BVK j#w4ӂZj0J B_nvdv$ Ty{E!5VfY*?[u z8T,5RߠDŎb孴PA&фK?C-מYErQ_9k(E,Fqh-yiȡdsqT #G6FМaHb![:L:0Pk5/oZ".Kr8M!-Yk@1F*Mz) x =F}D_1jX]fb|ܖzzUsӅ n?JH5vJCM~YYPd(vIR[xh"z ͼkzZ}<&w!g(ߔ ?> dGU4nj~"b8utHF%75 DG;T5\FFGs=Nib@4OTh@֡(Iќ"in*xo'6碟+u;IJ7 -N0KT`hFWqڻ $9f~5㐋 bFCl uPo" kam` 0Rd u|}: zFzRk)xKZpDր*=iШ`s4$XVNF竪{0~GV-,)GS>+4B - W)6u aڟ5RSnGp񧙇ΡaᧂB\iT*Ǐ m.Pg2^ t\.#ϽZM{7$c(Kw*xc^8ҥ9$eo*K'|`T0Lb`T>辮\D=UyNU)Q释!~3duHdy+]Hly7iKq@?Y_s@^Df=@KlM>G,'Jט6W=hkf1ENmTj-_$ q|(jH< c i(TqF5X{rR\sW(Uud$xpXbgX#^Ɛ(?19u s_/ |dOvil:[P/YgKTYyED.8}pr'5C7eҷw SA*2W_]uo$Q75e$L&@Zi&V^7ꬅWz{hwL_/V` \C_:9BɨohW~ nxC7ѩ\]QiqC2fR֌m@ƉCur +ر@9} Z=hi \(Z(%.YV~n澾ޖ5#>V!${cgv uGՎ㴭koyA5xX0V[t)wL/6D#M5jwq|j|zBJ^*dLy̆:\c6w?J7IB)W ٤FtuN $v[]M&ڲl8w#`AF@ܵ 6λMMTr{36/25&6S~׃>٪AFW nfsp]b;60'.7 v`gF0KRa:ʂGGGm8Ct2VXp85-(iaF6SM3& HAPd6pjE$tQj3?]t6*ЫaEo#* 6<3N,J߅uzm>az8%H#ILs*ZeDnQ[ Gl:܃DuP.M2AIJ=Jڝ{0MKq}>+X>/^Ϩ1"eb0-v-MڜI9 \35Jע˘wS>⣳hƷh'/>BsݿF_C{ 6?Odq-X`ܽc>;Q.ڷPO})ʓ1IKڰ#ܬ7}Ns*3YL]/a@17Yz Wtu}X[Qcs& 5ȄSY\h)lShW 341FpW^5M:W{>=wHN۠k~+6-rMVBkdl2^{'T!j-*N=d:hl4`v.mO/ g F{MxV$/|O PCӆOѵJdŹ|z 5Pjrcw^_ւMx){:h6h@C9xFK5 Ufd 4 (<sX MNJ >Pj732"׼#/5; o$_}|߹ Zu蕌InrI&#lӕ².\aEGah:zpx_ Zc^Q-;wzOQpaE 3&mwh#m`'{͊lXnVt yjB.`t5aa@/g}jLJ [SMV}(v5E *Q8nc0 rb  f97sWn;oa'</j+{?&i 5`v*n,T=}=JIk$P8zi JbWk 4d$*QFf4?o{ݣDBіԣm>z.cêh4Ee~j#yuDү>tO2A$RR(ݕgl#w&v2:kZ<& 4^ЫJ\ <`{,]7W%_Pw|[.~׾b!fV(Mѵ&g3ժ*eCk!(匰))gdfVjZZC7y>TP|JuwO __E {́2qp^jVLx7TnBXQh#wBRj皗vfrO<5uB9[*ꥁiH$Cw@AHuf2mYE1me)|EL>o4|v=v;L^Ai@9&:e$v]O.תE+6}@S&+ϯlWy5B袝 >e^,:ʮ`* B : hpJ'`3,?WIjeNuwPh1ZZ xKn} b2DQ_Fendstream endobj 112 0 obj << /Filter /FlateDecode /Length 5708 >> stream xU=3շ9GV3=u_O$O??Dү8x*U' ?I sꭜ\ '=h=!&Wٹݜ'%L)ӛK70:M.CZ/a%}:;w7rwqhHD(' X`V4_/s /#I1r>䛸ǗOi&aw!+TgyRYwoabB9 @L3.8a?*LNV {?'Z)Dqq pOwk8;у0 <1Qx8 kpJpl|H dRN3,csYSb6kftI tiO3/dT?s΀#N9դ<3xb{}aD[qJ0yLGB'>8#}A[\( []盄 oLR>ĂꚞgݤL,0onz|Kd,?&EcbPs>9Iw:YV~T[A BIR>է|Mbu%a;5>gAᘆTt($p 'O1eNb_iȟf|b0] {߽fp"%m2g84>yL($|ؓBd :8 nzD-8]J[!G:G$SHA?T!D@ :[1{d]YKn3IE99B&@ t9V*_A+3P}f]=28F@ ڱ1øn2L@6T2KeꔟJ}F0]:Z T*"ɃF_A`8k3mϣS;*g $Y B&J&Ejg$>36? `%oiM%R!X/Hh &тC !( YV5R>QFoWTH',%YXon!C!ȉdEuzl侟PC}9G 3ws'` ]kO{ ,Doֵ C;pG(_et6~lѯ!qƇxGOWdrq^Ed?B ˠ0$Ȏ3~:&εpc~\"fL1(zf0Ӗ(ZX5jTO'p%.qNL8%2+ sD8b[W fC rXƣFeHlP,#a*M‘/W||83YGiDX#/>.tJ4~b'tjwwd|zf#`L&}PO3o=QN׫9$dtD$NJe݆a2M!t7ł`'DwLU2J/d~!b5TVum G t'ҩlXXSĉB8IL~'+=O ɓVbO-oN۔Ը?2 jAGf0hA* 3]%Nh*Ŭے0O =h֙nI3G1޲Sbk|,eo-.H<05389n|$EW@-P2 bdT/m HIW8~p%c_RB}̠~8 V"&5ƻthXJq}Tf>&ɒ54/3*U7tfNF*L0PU"7YZKL.|ƹ?8j^~.%{qpq*|e|x 3aRat@~2mU(GSm9L9 O>@oTse s/sI6vE(<*-f ֟+8 2af)J<3a^-qbKU])B; H,d U6#=ij+$⨒S!"od2r.SAGz{H 1Uy(@wkWTeb6SH0*~ ~3Qd@?z,1RWlKοY@ՒW]fDj/wn l]P:<:ɡ+9XXlUfJV`:X~osbh9Zm秡 '!#5Iy BKmr'Z2K-pNў8ht8u]Vf&_<֠:>. :1 xV!S!JSQn)mL4_ۂ`t<&-i)$[PS8f6eLmei~v*dECƄ,~XZ'OԾ[F 1R=M K7k]]< d=Inwby37uTw:wHBY~яh4Gg+›8<P%>'0*̣#_Uj^2:AU]Wv@= l^+q#z[rk (yel> ?𒡊6Bz[= ɄS1l6)+X@0Y_+6ѴLW6r-˵[-Iu(bbŭ|cs=B7A~s.\ߏ6 (*&%YVO\&uX"|ly*1Lk6&pY㼨i6U H @wJ=K hb9k?O/Ap(&)p=8Q25x%07e #ê puth.m# p6SW±u\Լ~\H.Ru #"tb#TȏR: ܭ]t}iZ =fF _ O"H_ͥ).R7*˜:V2#Ԩqz_sn/3rbGc\gwU[N)% ]EhJ-&;2veW&њ22|zFl6ٖ֗cmXwZ] ;‡O PĆ8gF "JD7"Z&QjCq$je(:յ}-rGW> P]7'EGu>j]䒰ۤAO^Imlޗw+wDžh4~jٵ@^KyKh'kMtukG㒤]XM؝`~9Y,7͕|b*9M)UK'k:f@_Ec ,1r(ц7Hw 鿛n<5<p~-m[YA1L1JQOMZE6UӛKwxi(ʧ5$|SR<Ke'56aI()a_JR~63UYY4I\ܳs cbo7W,J]F@NQe ]M>PEmmVy<P*>fP8`gKzp0[d_'SSx=ڬ]T`ٵ g r{&i,dSznGqH)/B>cHڬj1mFI qH(+WIP}t{|v54]_)P9N?$!7# *rbi6{c.4|%޶_Kl&2)f†e!~TԘnr da\1.nّ^19&UjA4x1`<@}/ĺe? [`-Qғ6ev!s$-?IlaGXep.ɑd=b/bLxHG&۽b̳h:;!2YlF*pbG־cX)a+{vŘ"tC >`_BFR8~鬇svw˾K f|L[-m,'_$1f_'FW( Z{W~);q83#R> HkƢ2ž8KvS``eM!]KD)٥!дѪ 0ݔ(Y'<dendstream endobj 113 0 obj << /Filter /FlateDecode /Length 3857 >> stream x[KsR p*9$U~(,ruMJ<$m\23=3{aֵlr{ͮ>1v,^}ZΔ]?sSLM# Ƹjk/Vci>`gu%7|!r7{Vn#X4{xZլvx)uCH`3ۋ)̌(oՠ⧳o48w047pf6yi7H7}/ovHJF`Jpjݜ-H.= Cw@-n9G X6S7vвy;}`r7|vs{NyU[S;K1W*gb3Sg[0J3wė9ϭzM(cDJΤp[ O)7)I~-'A$WjFպsÁQ6۔~ҥݒf2w0뛠tp*۰ey~,z[ S:]4*?-EP~J(seV8tHn ,<:::YK }.5ڄځ I\6^d`N/玿( Gy ޣeLUiӌP mpsBq}'e"Y*tO-ivJv" Z ߣcZ+4gFy5Y،mQYlaGȍ|2it.&͂>N,>Fʭ`t+Xs%M*9Hw} XKg= -#3E P$R~\+&gaWI+| Ɖ$BO_BC('RIR'3Il/o!p{#.Rt鄏~yrpS|TBw8| (("p<H#1I`xh 5k19%DU.U7~F.1}&vNqږltVVQשףєjQ )#Zf%8d^30&'1)'K+a[R5:p&=vfotZEնpZ90ЃE)dv/A(M_en%5l2 "H#ng5J<5 ʈ!1j",CN-oOӳA8f@ +ȜKF$/ [|Ro~#K`5~߆>Kž&{fUԋpOk- yQ̙m Az`;L~Db1(±O"Z~ƻN #`^b|JͧRu 1|&=e{fd7&'PO4\rōN+| x=E)B#n_O$ry&~8,2iP G"pMpy+ŤQp+HlC$@S):MU7&87ك a,D<1րn f5T7ƿ8.1$Ԗle̜7c$Y |;eIM[16Rk( &Y=nV2'uL$?|o=ggLvMXq=$?Kz, &i,.(_9-X{Ҵ\095G,b3v i7qiUTUs^ٶ)>RBrC7OPV0L%FUf"`W)aTʛ^W"^*3}NCqXoX-qI7xou&6}1 tCj*&4-QNY \6$m(@'tR}u94T_ǞM$22v8'׶:PҳR';$TxlceSuEHf\8~:[ކ2[-n=+~BJ-.>lo[9%Yð@n^:x$נf/ w^ BEqF KJ1~tY2d7хkG\ZP y!Yr#` W$V 5G#Eʘ"Yڿ>zf*=-;ٰ؋eRkJv{Kel=930@)Rfx A7>ra" WR~ |ԓ`VlW{B`d,@mRd}ZPbǁ;U4̀x?K]d] &ӄ=Vg8 rԊ=K6,T%q#*e#(laEmT'&'.ˍ15>'OKq#x_t1EMqS`~\̩W.$jA\.=Yy2ŒlΗoϘ^9Z!;U[dn/-yF#4HKKu_+jv+O;ίպ%TXeȽD◸8ߟJ,M,@>"fR$fm/u9Y+қ*Qy~awL$&-pC7mDejuC.[v"[<&㩻w̟:Sֹ-{ K)ev{JaGr%uδC_um'yOdN>BﲺFߏDmrapϙ|VOjo15b]}w(cpWh[|(?{4(91H\!ĘFW]+;DKWc:䮥Pݴ} ;zyUu !s*d)-Y4zQ\}DG"犎DY7 1k)r]l*Rv.ovD(fJEq8$ن=G^j593܀ ~sd\ڮvWq;>*Upkfy+SvO{Ajl~7EY?BFDZFws .JFGB0,RW9%_pƚne|w ^>nֻyb|ܿe$<8]*#v,ӵzhgp9Ӫ|\߅}BA͜9g/yo[/\06=Ws\TUD7~Krz6VOu*'T* ʛj~+njP]Շa}OttY~onןGj۫aۏ@oV0cwokB\3 y%endstream endobj 114 0 obj << /Filter /FlateDecode /Length 5294 >> stream x]Yo%u~'#.@l׾ Al2?Hz!5psNm}jfZN;K~>{u{o~>!og8_p,~N/Lz~/ƻwǿ_;my:`aL:sB28z:ς1.<6SL' |N__ǒ*NNw.o~/ mZ0@kƇzvIW#y^Mmz#Ϸ7WRm3 VJx ?!{XcLs} h9@!UweҢ@Ϥvn s= 7)qU=\2N+o(w-)hc$af&O5Ľ-JWRGRkk%5Zu3!wUMGK|%`!| E&Q]s- 3iCgפs)­V&ꢔ2 (%u5o} 6v#|JWo`h]=VkE|vNo5:SI41?g9U ˇv#ߒF~V{¤Sn-H;BqXi7~;Pe2INMu`i*yf8̻# &HrO3;0Ծ~l͸]0.k$=b5S>BawkN)fܵ  U[pX>%{pЎyjˏwg|֟mD1&s+lmiDkC,\MT\N1lA)S3ߍʠx|% Pf>٢ZkwM8J<.͌l!עCA0iD>P q.PtdWT{O mL2Y}NvoVc7&"lD~NEղVwOr#}+d*D$c﷢Yt"1"&%b=::v_f\"@T,zmv2l,bqXI(ٛ 6Noӹ!U牱hFLTҒ2zWĝڿ dlW [dJYp'LEm6')` v`R56uV y-kUdu_j8s]5 |VLk7u0jH( ^jR)W!ʷކB)qN$ɴ1XϚRyc =6 _:a]% +Ǹ L5B3l$ɮjTgrX,՛]{M{IlEx'yާfofd>̀Y%e9F(PJqUC\a%թim{~m}u}AH֕`#K~y'3熙B;_Х׎p")Vq_σi? >dH).Iw-[LU.j.JȲP>< v%rFM]ϊ.oz{rj۲_?4appn^jLm0.mBBCK@˦xwVau)uuE{@++tUYuALНPgO։J !$Alfɨ,S'DҠk$V44nۑVbHiM1r2ot33mtӊl[ve&mi~Mu#SR0ڢVBI~JuFoњL]Rt1w7ISpB:p6wlȞvzpxEzyvTn  n* bA#QP|R\C8qorExlu~o:*L@?$bRT!%k+"sJ&[?&uOR ^LLHlL,|陭DK=33̓ː@kU\PY~AɅAjbCw gy$ԅ=-Wӕv\61E{ELL@ IIG$o 0C{A9kTEazakͭ$&mzI؄7g1N1 hgT,z7Q.$.\Ʋ!0R~ȪMZ9wqK$}^aXqݴUQ,[kQYuJ(}aތٮAUZ< 4+g^8ڮ+3=KHSҕ8v/RVX/ݡ¼6V:C>2tvҕ6R_>*g1O1;1Ԣ=u. Kͳxg_<WPhZ8- b,[+Ǿ@ GR)5`+W0_wZ9;M9I BVMkMV~"B2Ҋy?'K!thR2U䛎!Y}MI5ݖ\K]πc>?4L>āI<4?2fǂZ*'dIOچOD>Dg^oL vүi]5Pim˪2ˇ5%rmX+]Iu( Rڥ q[Wt!TW(G}ZLī]Szaj*W963yU9=vKwM)7)_0>P'x:dC ]}`[t]jXJs{ҾGxgNn 4lkXYI0[aٱv[ RsFx%yCD(AoK(E94m C!+/F7M-|8}S$H5* 5%cw`[A0P5U>辗ۮ@G3Et)<9XV +qJ܁6]îL~זIKqL|> stream x[Ko a{6QHZܥd$A~{1S%ޞz7.X nNGşN' zX]WItN.Yv=yK΅u7eix?]Jkx1iTw f dקKxݷ~s>4=n X#xJ썷0.yǁt-]wGvؒ+z ҩ"Ӝ u {+ sO~Swvjyo kdW05G;D*|Y&[@&2ƅ Ϟ -ݏĿMoA&x H6ۖR S8r³2w&sto<pgkE:DF> kg!;L~w!5htbf2]fxūgLJ>4xep vA)AT h8pn#kAF7D֨Wp%6Q&,3Ipm3Z_N9|܇-">j$<4+B9UgE {")z ]l(e h dSVpmVhM4@҉r2WA|BK{5''܋dFJ!8HkL^^J]ږ:xZ}|mQ=;$8üxrZ30 7{Qrr%]X8hԺAyn d;C4Za"7 +F>p3N)Q9 F!{OZ[ 8pwv2(-`XOuTOp@xUw:B maa a#!S]xwt4Ă2;|JzЫѪ%%Vp+VNks͚5j3kVz\2sHw ]hH>JkI/rj|1Iճ9`}H 5:\l>2z}X~#+\m0F҉4R0%zi!7 EŠ28V -![xQWs#Lp7'mxm|恃 A#"y]e Ø&:Ķ~ d][Y2iqGǰ-"a.s1Q-2!0x FnjvT5YREժ"!Uټ*P颼o! NmQrr?XyvN|(6*u<=:IFe `vy̍XJ m֦:Ltd puBϙ{9CST FrceCocxv[1o{k.H(*JUp*( WbHurN)fD/d%nK1fBɬK\Ua9n_xPyzO^%=btT+Z!0^NZDN:qPz9!qD;0H$޾9\ϻV8dTOywl/OТ8J{6νݿ7iҊK'%ܺp2;8y]& LFCcCa\/ m>yٲ`nufZ&< CJ9g;dgG:yO䔞]_g4rY,ԑkV㵈ʡ'u\w^EDsg\K%;?\qשgL3T5JFX m~QPMۜ2@F\=+Σ(w's=6Hoƾ. ;NC@Tՙb&**#ZJ5~])4]NrG4/W*Ju7LU`Psb7<1M'7eodbz& %ECBeH@Eʾ;EfZ  e֫ğw?"4F[GvQ_C뜏Xsz"ʳФLl¬ˊ[M"74\L}C޴lJᢊ-`0-=xqy]z"·6RR%<$(2 9Ԏ1hK.)e;x8'ϻ&`_aިWU.aṓ ҄OшQ[GYXg20^} &NjGߖ=:-.g~ϋӥ}! Dyl9#HF:-n̑>Hh=dp"ds27h χU>1/gOMȷ%kq_4DEY*r\*zij<G<{ /78HpأэL* PY/nKG3/AZ75~MRPwL彫  |[2}wicq9ֺ dž^ Mp=m&Hl ,LJՑI ܊ '?+}Z|XޝQ2v|Vp<.JC?># $a㯿u81Pdp#a럃@=).mwN4a_#G0i'; xUS($@=p6 Р>ORXG &Z\e^ga+- ػ+tF_~=5KБ|W]N!+f{#ȧ~MPuzYvjOV߳ƔdJ.)ą+ sH-hD8[jר gLjW=F/Z,_Ɲh9VAxEJ> stream xXmo6_!-F#O Ӌ#Ɏb}GRIGvWh{'=Y&?zXOGV[l.bnhm8Au/&V8kS/B^-q5A}Y**T M;w洒= zh\> Qѵ5 JweUigۤ ʴJx!8bm&w&ʶ*l |Fe#M4lvǛ\+0y$ݠLw;oʀi}U,"q=Ǖ(XϟlY1F qcOa n`YYM(%8Ḓ iRZi+}ˢ4buߧR8q=2ui?rGQvu QC_H8+AD:8vIlٌf'^[*|ܦ=> _tc¸e0ZT hߧIxF4KKk =IQӁ>#E< }xsKfbr<9#,ki:P̜>M#µ SXbI`?%&J!{|8|?i1utlkE.1ǎ^Ӊ(`)^'ac9U 7ohEBJVM)&갎^'=\Ydom-Kk `vjPPZ1j^>l͹$fH]~$]Ds4V!tzgŮIbɰ8џaXu}π8Ij~H2+i3B+NO-Vj(eO:ܮ~ZSVs_`6T3Pla5רȠ!G/:`JH=Y s{q1^$\SvVxNX-4)2_/"WK_WJ[b3wD`/9r> QckȮŕ*œV`uf<`!bE^(D(]k[4{K;(*q 3D+UWUʙ'׽a )q]7|Ů 2ܜ&I׊ &|y?~!#8%T1kѼ̌ h?o yrx%LBke Ew$n,$' x*o&S6*ӄ,vZWm>ib셷:E+.񌽆hJ\|6> stream x337U0P0U0S01C.=Cɹ\ `A RN\ %E\@i.}0`ȥ 43KM V8qy(-xǡ7oݺu;GGBS! 4 endstream endobj 118 0 obj << /Type /XRef /Length 115 /Filter /FlateDecode /DecodeParms << /Columns 5 /Predictor 12 >> /W [ 1 3 1 ] /Info 3 0 R /Root 2 0 R /Size 119 /ID [<5c6b7d475defc96f74c2aa80e7c030dc><1c4845f8719a5822441f8f6fcd154cf4>] >> stream xcb&F~0 $8JD/@)GD2?@$o'" DrH)vK D[HF7rDJ>@Q|؜h) 6YP lF l endstream endobj startxref 82313 %%EOF plotmo/inst/doc/plotres-notes.pdf0000644000176200001440000062616214664222504016641 0ustar liggesusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 3982 /Filter /FlateDecode /N 73 /First 601 >> stream x[[s7~?b[4߶r\K+Ď@#kԒ#9緟 9CPFshn`d UQpQj^›PBȠ _'l ),/((P^;ՅgShPn $K)Pd  xaH;- Hjp|!Y]$Xi_^.heݣ#)Sxo,/P_|AB,TE'D$iK,4z -.(kȅB(Cs\(s\p$zPĒ!rqf (K[ /2,= 4\Je0 ᶰ,[PV-(k@u@Y+jNiy Gh(kbՁ)48w{]ՃѠ`h0N fpQ-0UQ>]ϟ&7l^|w^snNsn gmŹĽ:6N#^xühPWųHeq7\~v28_eq ů?E 7gȽF7 ~xsRp9[ԋ||]cN㿫at7vqY׹unIzMXcGfR}zP{*=\*}~vyg7Ӛ{5U5tr jrnSC 19SHN7)Ͱf2MXiʉD%V$)4e>QAͻgӺ4&}̯xp0 肤osTm&i̇|:?Y9۪:T}Avߚ Ul~룃>|}vh<(ػt`NV0JS>I r7: ƣ2onIshV[(6k!n}9CN5`_VK1?̓gl v^){~a,q=* p6MjFbs3sv.e5ecoMM+vͮizN:]c[ls3 [LKVr^U2c73¾?VM'㞄;f/&98arT 'O*r!YOjcvY B|mxDo=y[WWgnkγY|C>={wpWvʆR) mR}ɑ'K裹@D{E@ȷ 89k9vjT`%<e},S@ ;,$⃋=әFD W]&$˳ a<2h>.b\Nϓ8ҹyF,ЙIUN鶥Pϣ?^eU'{~ {U j}:[N U#ҺsvNc>WNdfOP^TXIu]_]3^f 65]cAĻf 51?n _߃;rJ/z*=~݊o+FBGs9RQD0%@R)i,M:.X߻dvbI˰ABi"h*݊ur:KU4.?!6)8>(p'PFeEeL7oT FҽpR1Q1t4LkؚV1}Eoz&ywp*Ԇ4'hqwZ]ow]B8VoFDj]$ώ\ ,g)jAXGd0EpjHJ~s/frQΨ&Zw[Q5 ^WIy{Q\l>98Ve@n@2^ӛɄF%'ߡE8s%%팑VFd<0ޜU5M Рʨ1]?֖ \HBb)ȽȒ|LV"0;e%V ':-,G1Wx8;MFmށ&kѻ0>?B:>:8=xA41]JW\)GsL:=GSܳcr4"(9m,S@B\X-[˦rWq&_+O5NĿY#PUWfqĬ❙x[;'VP1^L2$z@ZyƤsE=MoC{b8{1h5Z@o e6!+9(H{yI3@:SzG>)K1GrdHQj$m@4ɜ4`VEoeN0C͐ .u.2͎-캳Ύ;;/cǸ){:lLtV.,R?pDFi,uhLMtF4z?b%QMl"2Y↙U1Ş%hx=] msxnC6P7p.`!RGҁ)D6gmFn^ΈY6 < oENa RvW<)Ql1x [14*iCWI%-~+BZ-&:\LIh"G)! 囉NPzZu,IA<9JJ. )diMVcmy`LChD)D(U6҃SZgϰP kQ<cʦNo 7qe6jWf$X <ئ :xSZ.)D.m_ ݏ(YG[<*VzD[f m/i^sZv K6EFSB#-332/=H gvq:Q >4vFLaZްw-݈sd䫓9.žnxI] ; J+:c o.:.;06;aE'B*1}'1]X cfv\ m=3 Aj$8BFP%c٦Z]$p @J`n֬i mKi g6Z/Wv- N)H=Ul[85vɒ6K A0SWwp=/+ ioKz첮`ttz>l~O0}3nɴ>0]6 A9zXXĞq@<}cu)L J@} ؽ戒P`9黜g 1'@+ńď}FX.) K8qžTWoA}R  ?. | kKQTr4}%="&Z^*'h!e8k 3Bq<#D}bDnW[ s#a7Bt4z1'XXpG_ LX#ZiD ꏗ/4wU IKL;\oKy5|š_EP*ؔ8O@dfdrO9ag:}gÚ51`h|~^!`/z \R rqs8^`ZPlG;Ӈ&髁bKF6YxӼVhiihkSfA8endstream endobj 75 0 obj << /Subtype /XML /Type /Metadata /Length 1449 >> stream GPL Ghostscript 10.00.0 2024-08-29T18:49:55-07:00 2024-08-29T18:49:55-07:00 LaTeX with hyperref Plotting model residuals with plotresStephen Milborrowplotres endstream endobj 76 0 obj << /Type /ObjStm /Length 2534 /Filter /FlateDecode /N 73 /First 634 >> stream xZks_xwߙ43\N##ی?$"l%HQ2)%e468{EBD" pF"~kErX^q;\) 4Q`~dY ֈl9L$Ȼ,+-NP QX$u8zZcBa+$ln/#196: #Id 3tc0xwʅd0psBxhE0#,s  2lɊH3EoTb0<'=JP3s,k N0VN,[qfxRB<'A,CVg`NC0 㠄ow,P)2#FE̶Vs9uv(>~(28+ uԛg8./ᴚgꩁԙ:WC5Rjj5U35W7B9 ֯^zg3e_D4~ۇ͗Q}_zӻn7g p6>6r:.~)γ&5ݨ Ya=T'fy__IKmTb2xr4⹯QϿHNjKYq,|ÚE4{0# $ye&$Eʈ Wf̰ak pY"g F!;$ruFrdrdsvuNzNk9rdax фj0-h["1moxpi ~w 6;˽Ӻ~/^le^YQ~GD"!9lHM#RcqlDkQpc3Azـ 0!Kε]E昚Bl&FԈG}+wj ΈxdN-fl[iCMAڼ@Xe`YK"h]}|%ǘ= ^rn[$[Qxc%VF89R;l'F*'/LM1sf\F˕H߫j? {Ynqpy/\4cKH Cv [6B6IyK0%ZZFݡ9i4ly -r Fm4Eٹ n\? Huv\\\ú;#@Pz.cL30=Úԉ u&m^#Z4 ӋهZ5m(dz$5B]": +GIFjN֢0\ @V FrIs\*%v2w;Vld`@ 2L⠍pk |=iL+f_ۣJ7fzZv|!Yo6͹>쫮~>-<ޣW=j~Wgk=Ta=hU(ZUVn[bVMulV-z늯,ZWwulܽ*pGZV<(1</M*9{U6ZXCDBxG51Bk}uGGM}*pOҡKnV?mD eӃJN"kH іU/6,@zw|DV8mt[ombɷu2>m׮bl2sLfr2aTBQ|-֫WxQ[p?iL-^^?Ѷm=&b(.%-jJnyJf؁::Z(ೠ 2/[#s2FV-dzpv9T{DKF&] $yW{Q6 En[n8qV1CG@˖FmR]+cm{w!ikWAa5l@Nx?O^ڟҳ|R?Z35p )cinВŬ } p wHvl!68d%tJ3ۋt'_Alɒ 2䀟F`dz/MM%LËee^ΪL/\U`y&d$AFl4md !hpϒo/09fSQ la>^ X˽M(6bGo% QznKp}v>\.1!`Ĵ C-&y:+Azۤ&ns^aC .i.6Xukާhs,$e/@+!˟ǧֺ\a mB39>8=n%y;g]?~>"\pȟY@M3~?nIfbq'l릴|rendstream endobj 150 0 obj << /Filter /FlateDecode /Length 2585 >> stream xZs=v+h4dIQ<"-qLQ IUgwGٮv<#Cwb~`O?D 3A7gbvuħgfRJ3;sV j3'TUBRLű-MVHc_6lŎ>g/47JPiT͊!͚ZUV@g ٌ Uʆ=*)L-𞍗L-H;il yd\?aiDFW2 iO=PM*m%m ]I"@.Qi^|!Sh|Plhږ{6a'}:9V9Ԁ/{a|vnȤW|>I[T#_)s]l5J0:m k:2 <-3dgY8E-r~,c$wwoŽmHEB5ШVAugRҙp5#{gݜ):t*֙dKe!#,qA)gW xe~j] 9Q'¥U} @%=;fO8˖9'yչ gVkӛ[ Φg@NSJEUX^w7fLL2uW@[d*V9n{yjeWTp+jm9iffKXO擭9HW 9f|7, ]oqkoH5cG,s|šuk t|,l[mLω_Hy D 5b7#Lh}wJ_UrF7.6hmC-KTso3Czۻ7sbh@E{WU%buvR3f=;]S$s"]}xsؔMG|-ƄA䙫$@᫛}oBWdbac4yʹÑߟU2G6LcfE?b7eɲ58}L,I!ؾyʚ("Ӯ7%S%P3>S6q ;@ mq%pX_+\оy6$#.boڍWIhR%nc̐WI%[*18_)3xE\^FŃ _>$m(r%5$Me&։N [>s9 wE>.e!kECSVY:'hcwm.Țy ,M:Bv-""t!G*>$Ht .﵂L(dJeA=wht1:lnbW~K& . g襁15 p;])*Z=*~n0vx s6?с8(oX,s>D^uCBe(ǸboKİ2){cHZWU< =f> 艴!6Y0*17Kif3}~Z:d> }]-%:vINd5 *,9:~g%{.q!Lr<1Ȝ6]TeL ~hwbGHu=^ ]h~Ca=+#}JJ,2/nyvyR`jQJhn}[}3ԻZˮ qYg]*c]l~=$5L*JqCLֻ~y\Kdܽ(Zq,}jEPp՛r{l_A0-H3[xj+轢؋_I2endstream endobj 151 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 4054 >> stream xWyTS׺?1prPDEϺk}"׊Vuj(!0!$@0OIDPXckZPkZkӵyIvc:|}}6@ Zv7e8+Vc/{!TBpD9x7gYdEJظ YwR]vA)bs3]g~c7Mw!W b=1%gb#Ll!%[LŸxp%VUjb Fxs /›p'uXG'&DbL #Fn<†H lGG }wm4EYMb5hnwl13׏]:\r9~3aքGgG#;&'$ Wuf.P>hšDH 8 **fhi "w FuYB^!*ׁ4Nr2g ш6; ^znY2!2-G<-Oșl@֐5T,z*ϧ4 M=Ox#azzO׸XtH7pU{Ft_Eq*h$ee39 ERNVmP{Qe쾺M[sY0-+(Ww$@3ЌD;{>pV%_jLԀ ר(D;.&]Q}@v;32zJ3~nXƌի^nc>d yx7 v0wD5 ,N(I EQ,CEѠyPmy&ťWCAeRM!@4s"P2{n8T siPq+-G*iN!1(br $k@l_D"<jar-4@Aj$ |x}V'~܊ j2)/=ɘS!pNOJ\D-`{*׍g?Brt0]*oQ#//{'/0TCwQ暾i 3"_9w wX]PԑwL@FSW!=$ D^5k/~C2u@$ie!G?=Ʋev")DhmeN]N/oLGI1xaVrer;Jc+-FLp ,5Wr} l^zH?w˦;b+7#nv[Tmv$+Mneh4hpUFՐ]N/n&W]jԠnSPm4 v%3G/u>bG߇j})۔bg.%6KTbCqJ!5}{X'7 #c:=uiC@ݻ|uQٖ6U󵚢ƒԎ I;AXV"j w$9Ւ̍`؛7/ASJ3Ioq9mi']:V-K@}F[.:dHO6醀q(G9,^~f"XIȉ{~Kt |UVӔO. 'CQF#;Q.oK/0F/GQWO50}'@rҍuRibTZXWzS܏IfA=%Urd>} t_q(%Kw*Rǂ)\(/pފoTZ0l+9V^:OUW9lQY4}\ѮRE^V Sgz>tt~&_'?`5 {&'o<"F*9 &!%{C%v%ɣV: {pVaA7NTBhmBYjIbwj~5AOc|c>|C6fBr5#fUcջC <7mՋ=lź_H<뙏}k՚pl$Avz`U3A 'r4C+&.7y2xTw,lS~h3uJ &JF=JR#3}2VG7q K(Rd m,mP"oѝCgN( `(yFWOKLdhd+@-煨%VE$OMUk}3c;$FEcۊ5yE&n>ag<m|*xSd+Dp4<)CbQ{\7Um}__ T}rEj"9C;'+' &'TkK -1.]F#'~^Hz y18W X\.|%g삧{cC mx_ٔAOȆ"SZ~"`Yh_'B|Rt{5kݜwi4lAq~ R) r݃Ӓ+n7Rז m[&n̨2JQ j{nyM͆\ҨzJDv@-512u_*SՁeaVIt"@!JLӖ0z("U96tii*+iUC 5ր sFE_ӷ>Ml<-=F3-|*@|?G=YB/^é7 6n_6?xs}Y; e=*A_'|7 i.% qf&IB(?PP.aN4Mh6(̺@Ampb"][[y9wT1۠EO봶:# OIy$/ɏ(-uԏYiey^MESV~LU+]lX$q s=: K"ܔ=^0{g|#S&gjy3׍_l oDagtyBr*(Yn7Rh$؏1`H &Xendstream endobj 152 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7024 >> stream xYt׶! @h0j1{rt$[]rlCHB %H)1yߑ !y`-={7J"Wl+4g<LK)Xv/2~hkh@a}AK,ly;"WFy8zZfZuvqߞ4vioN1s9]ˊޤVQéljIFQz-ʉCmRq&ʎOm 3zB-&RKIRj2.eK-P˩ j@MVR3(Gj&5zS)+ʟCFS(HSS֔ 5L ʇAV\J[$-]r[ P&ޣiz/clg>aIϠ^-)`{;nr2:ڛ,?5`KC>x}.6\?hݠRwj!Cx<.C2b|gtAiFf$lZ*3bALƞ]cwP3rCB-jUp#]TF Z]adctSx.TA$U0/Z`P"ecdVB+! . Ra JcԆ쑷dXΨ! rRv3+m |I|:^lE<#gnrp_>@]Xu.#@\6F nKt.`j‹瘟 {.\.X{w>ǽ Gu櫩w^?fޫ:ȡ~Ӝm[UGF}َ VB\5HnRb;G`p?<8$C=qxzbCa?4Çj,nYQ v@-[#<1pR{+v1T*h 9m, S)@Q1"S# ՞:_HռFRURU;kj}TDUUj!hhz=U#]3PMA/}MFqC!Fʵ* RC(昺")"41MPl}lߗ|8TB*4 -Smi~ʥFQeH:RsuMY mQqK37;vI2eL}{H$eA:0y+%QQxԿsnI;y̶dmT-? S! Is񪣨tꚃWWsڄ:)Wu@xj<2vS,V&t]dCf1D@L hHFhC2qLk!'={{/t=m/px0h:C')=*g0ʂU@NJB^4.VdoMh"b+hmQ):K)d"[_H`ǾdRzEJ=rC_xXVwݮ>L#>H/M:#Bx!RCnI\X4R9YsiJ{ 7r}P e`T 7lNyɁ2zX0I_HTƏyָ;jH-Tl,H̪]]8ܴ|_4?jS! 2Y%D!BQr G^_"M/bOi+4Fi+m)lu?.*XEVuJHAjKĂT 9ٝywTjHNSLE֣Q#٢mj_zUY'XkU)D•(\\DL<bn[pzZBqVvnAQ޶CKBS )):@\T=F^  Ø5eiJ9ӹ5;t=*3k3*x)I׻mN,60u?*{ v6DĕA^!EOP=0S6AG7jruF\5T?+Q@&7C !(_ c]^nrX*'$"3iXg*dMuLs̙xkK@vj/uҒ<Q <4d4TFDF)M^'O;WMoow|ض;R/A{ }⣳q1 d],srAV+EN~N8>ƣ_7୞/+kR9M֫I 72Nɗn<ғhFR.Y:5]eM._i /g( :)˻>&5C`cݤkh6'O/&/8|QX27! a#-]oXDjC7e"TeQ[p/^'AHɣ1xh v`_Ba6k,9telhb*mZ7ԷַYhؖE=4R\)Ea&|TAM2Bf#/TIʉuݷ΍ը@k34ZFL#6"4eCzdoJIgBÖkA!eSFĎ:Ԍ$2?U|wC}T-ZiF.B&!j*:疋>s#Ex/#peVK$5÷Q9OHKU@_]+/ݹcwL,W.+7!(;ukVo,yA^znSf zEnʠ$$y`Rh+ƺ2`Q!#*)€gwlmKs5_^W,`. Z娟ACpRA"#i̿qc+z OAK̩GLGZB" |sN!MW2]X=+@ Ң^x9븨vY#0LѸ|/zwr0n1-Ʋ}\//DYi<֗QdN #2BtL/ IŧS1Gpğɝ߫+i-n}/xЭ(fi`>+[ 9 HQUݰGNR('֬/b&Dɠ2r4u`xTx J$ӊ?;V.:?04,2v${>'noyl>zi^Nd59Fq]=#E4vSv8\9}34Ow"WmLdn㖳]IζĵɝohH8!Tlaʑz'XǼam+8skN]UUJ2n3L6?.k.jt?ah[PCmelPk}+.XXZ]hsD*',\Z'ަ"48(*2xKG }$> aٮDzHLa!iD;e%@MdljyU_5?@8[ ??jDgMX5s€V47QDCr᧦r"TNM55/b+K>T&*Tx|O@&Y$T`[H`!`OB2/2+.˷Zk =1_je~]A%9wZbZ.Bbk4XSfv8#CWD7=m Iq:4&<_1y hE}h"'6jXb{ w=+}q%]͟{n??!&Ӈ3vRaw2u{mLcφx#BuEyYL.=]CBlU[4%tKܸhz&v&xَBdV&Z!CRTְr bO+6\ <},Eؚ yxH_UDEMyY-G:$m7P }[7vܱ/w5H5A0c,|B 5v7,/@19Z%׋L~ZZ2L» 1ws)ޙǒsl5$Y:Y4\pf@sT5UJ{+prY1I{;1KOQ7f>F+9#\pQIɉk$|u%uCO'$SOiBzYuў JN`i8+VI8,IL'jnאlHn)k8v am(Dg,D}Z;\'-*)2<>֘YI~ sɽSF/"؋ 97bExmr75NXp|rڋ;%lNqoPP/v!6'4lA^vu2S6 g^mmkD̑t!UFۤ8m0|ܝķM4+cm~aϖnyG9<^ ǘ .^=ynn[um8g;wB ¨ A'*xCzC)R5fBS \پ.z F6nc'L~z㸁T'꣛o:hu[iM3Lf)I*Z ]../޴_NXNU&ze]z4):>+3C'%>/O,h!!DsK,BXuiB[/䈳!oHMVV5~qj%筄8z) ڨ֡Ym8 5*3U7~3iTP}:1}ly{9ѕ 6(iY@}!f5u!TUT%QQ,n79D{*@T~;CY_sޔ (-`Te/Lwmv H>o?v{łb×d0#1[CX@ m@ 6n]n>aa30oczq1@XO;AU]«A1g,{eO(=endstream endobj 153 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 5171 >> stream xX Tg֭D-}MtJ &AM(Db4׉Qc%D ?23_dS9{{_^L&c9.t6]M oZuZ- k~m~ Zg^Pa<>ؾs^k||[O:me7{μMġHƉŬbfϬc&0.Bfld3K)=YLgrf&|f|~f 3yL323f1V,cD3edu&*%Wɟ[X\\niHb{%V Vs:y̾wmlS?l@@E5׾|cȚ! bMC0TD&niA hÈ맡OLNPUp 4[4{a;gd^ڎA)j9I?z;m#xH%٧heeerߺ#9|Kb/gbϥ\WePM_o^,22H64͏Xfh7 yՋ'U sn?xIL%#[d@֒x,Caކ%Ho%Octew!azJLI|(EkAkX<1)Ff$ɐGp{'x2Vؤ,m<\dS`]_ #`ٮ6\n@wuΘΙ|_|tY%qd2MvwOƣE*LE@VK&if9޻P򯵞<YQŸ́@_"8(1~JGd"ok{[oAaK6q,w25bh{Ap8d"*Ui-ts{yc:¾p܍¦ծsQd_ ܆n0̤`XOPC_Ge8 ZJy| GU=*8!b5㌭ xM0nDa H΀y/׬?L0/a%WCzdb#di @{kUƄThm 7OS!ee!D .( ˆB|~ J;O@v=` )RJ["l8]x- H)Sڼ(\ MǡD4+4>@OSV,(7X y^>~ˋ_7)z J. hf_""o=<2QЎs7.uԲzum=!\,l^ic[R~ACfϓ;¢fH=~n x3Q\ۯL/_`*:|_ÎSumt*pAuhڈ~6تسz=Ri ޟ]zZaR/R:@ 'j+Dnĵm1[[ofm]Gt#_]*noMzHrtxQ3= -:huS7,Gr6v@6Jx7E}-2O֬ب`oGD-/5㼄2/Mn=ԵBTrr6YIz5<`!l)B;A@wyF'%mx/$PCt^w 9c'(kS;'.&STOew)Zŝ؛ωV(ć^682gt8$jZV C}n¦%KoXV\ۆHI ^vo{zcfadYhZllPgY"zȻ}Eze3ie-aƭ\74ULhsՅ\T^6 )L nJQ-_={XA)~ZrisʔmJu"}y0t='$鴰E`BSӉ}$]0/K76*ݚsWѯ9uh2 {>'/ #!!B XJ#Fk }`*Ly5X6p6{:1ZDH.WRyc^I"cb!VVYjoil^<ȷN@u} !puuPV{^ݑ`\ 8 @u|qϤR B++ aun*`#Ӆ#,f/exhNJ=s WwOܸ&0Gp-_3 :UZ.?;>iL=߼g*OW;w>iB>uf_u8(7QUy#6P{+^s8ЊÝD1$XIY+664LmiD̴)o<ۛ) ΍N5ZJT! $= }BUw='P% ,d-sE#/mT`\r8j~Qk5#lL5{Sa>Y b•R[tI^!ZUIsHoʼS^RS@]af~i}pmf#omsVэ&\@!\3oL9/yi"91iy?Evu8oݽó³(?#C4H'Ъ$kE=q?x$\涆 'EnγjO]OFd< H>n06:fmPF+ DR>#܂L?;}{=+ΒA7,+z*iدj5Yb 3Ӿ jɇGE89.vl䖵AFE^nz[@Iyh ;[M%=?> stream xYw|W0,&BlJ @'60lqqdwEETSDI a) $!Qr2y>gSs% #H=<&N0)Ӯ_p',O f̟sl]0݈(͋cn~{\W^0 q')'ǿ1eF[3~ 3y,e>`1c8ƃyYdV1f3Yg^c1 ]=fLfܘ7Ef13qgd03 b!zƉ1PƋa32vƞ~LfC,c3Fchi]&Dt6O_vpftP:8uȀ!Cv99: }qДuCqpx}΂ezdF7aΑ?iƟ2LULU`ـ[z-M=Ju C$yzg%D@jfbj@+b8m#:h*I+LS#Ageb'lϡxapoD0٧84o-\6.nT!rzRosĉ^zp}! DUڳ޼n|u 3٧_t4g9;ʀo0Ǜ _Vop}Y|!'wmmb+(V AP.w+Yٓ}Shq+) P`lv7Dzp?5Hhk@zk?;bKd}*ڠ?@6)|'&>{y f x7vj-Zٓ+ Q۷@R p(=qҏY'7fz. WY F{WB/z 7-9*߽6WUEV!!÷زZi8t-_v9n4~v,WHz87xȸ:}Ժ2$; Z.ł(褲na׺ *{6 dzaJ6"w^'\6 X9]qaCKuV^ \^E1=D٧,[ȅ+,e Hl{O7%8h`#>19FdgzY} ;O `4 =Gȳrs-?/ ԱYOr OWd ^z/9~+bOb*EٽW߶E7ÄP_AXSAXh9@a8!Lx}@ 8ـ =FZ|M547k5bvJf =z10Z1+VPk2=6G%)ߦ-e/ĕ,3ub$-NbN$04k ɴ3Mhji&+W|]uXAlGpD=̘z^ ற=*EOdwϏ3f\Qb &Ȣ¶sHO ƴ4:Ǐ~x6DBn ްo݊^X{~:ЃK%TCΞ8LjI)ִ|:1"1tj5丽M?/bF/JHBt9bWqv D@IM-@Z*U@p;8_! 2W/HE#\"m oJ)%Fmd76#>"Nlq/K{M7UP/C^z^`2~.d+ ůб8ڇDf>{vK{ h*fyt#5hMjY}8F QX1~YcwMڤ4HPbTZD )vyYmm+nNFkLEyL:.y/~[jLJMLҧT)εχu3ȯ9; T.6=>,'Sun>p1accB7:ψûlMP7Cj܎Ly~pSu~{8B!$jJe p5zmIfOFN&ߍA'wh#6$XaL|ORpj0-G&cqfGM([nW-bR`MjiцK#'>?;7E\R %P_5'9uw(+-^ .,L ݈zz^-+rON7HQSfIe%We@_T &GJ:(ZڛTI~ ߎ>+&s$V迹|"yGx|?(N;`}C#v=͚ծ:/w^j_ћˑqArڈ5ԯWB~$/#dñȣoj͙IΈN#WH 0XW<_zN0E #]},;qN莋q@6|~2%;p.%皋o hM*(^OOZ0?qEШI,!8b;1Sՠ>Ht14 [[u ߂fmxCX9[ɅV5V}2GŜ9gN Fó|2LK"*q>bӑgT:m!pEO#ʢg , E~h{r 죇Z>=4e5DVDFTE64TU5Oe,}ټy; nƥ3Co6էWU^K{n@dD.]|'n{=Qػo?zّE"bͭ+=)lgϜaéQݏ(1# .'&g>t|{< ;J`HRd&y\C6*"26aٍ=FuFt13cy9c +̵ItV3_󉥫 ]ͦ,ytD}k>%SɫrU w+Ako]uKnhSArÈf5=e z>gP$߱v]jۉ_IJyުXxE>('x>W=B`ݧ`0YoC&žsXC8_NFjM&lrqnnBrhz6{ >I1XN.H}zזHFJe].uRݢ$Ad'm"(vT'AHLȽxə?&B oۦTJ*ʴ j1LRd9A%[2x^V#ht)v sQY )"QD(YJ ) wI$3T .Is',hT}Yg4ïi(u oͥ+럒 s4Pc}ꯣ͙Ƿ;qI.X(Z[}!A$p4[ d4 "Um E ;zeWk6p_##& 䜢,V~%"(1l&O%_ \>?GW\Z=)tJ:LlMө V5HmCl-.;,0p[Sh˞gYr̈XՒ18qd8q#Kahvp8RDRqǗp:JƑHo<=_gijh*bIXQ k (P(֨p*O Qu*dd )SG0uHFfnhpj3y4-۩ԚiMq&oѩ iUљqLzvXEZY>͞B R+Xa3E l4~|OJNM%g~[)]KFzxt@sq`Ŏ×3 HӧnkHꫵ i%IyB#ͧ ~j\W8XZС鴅 4no) 8< s=sd2Jj[eZǠFJV|wQu%'Mbdev9:o~{.nBI)܏8,XпV3SZ-47_5OWx)|Ga>a}d [f ss D""@jؗw pu9&Mtpt}ir5/W%A!qJ%rlX"8b"M&Ohj+/B|JJuQʫ*mҌO'iİ='yV4 K>2=+Nܑiz;S6Tr#iO;@S.ZiD /dr}+es$0Ej^UF*1R[/Է8K{ou{ko,?B#G#QJ:hC~m/gH%mp:%kUϛ-_װ s'0B^W6zd dOJ~Eli> &Sr~F2T(]8oN7gy=fMmAڏR&&sb? VQ6s tYYPʙ#$#?7^Y@!m0e7/eu?qoYj\g w{M289sƲk*ώZtM!t7 3I ?͵h8{ۻg/Y|ZOG$f33K|xlVdG5>[֚?0T:ql'IZMkmM6&7+87[ܶBBz*AA:ܻ1Cگ#*.4VߜX% ϹO^XzܳËF&?9g/zF@&~;05\ݲ•8=B!g.{|7!KϙK\ev+ɩQU?BZ}BCBtM^: /5Ey%TuUG%eM$'C 'W۹4)[Etyequ%'jo۝=&[;>wRlHrNyB^KMOڨLNvZ<_l@@;xEmyQ^qi`825ɹ7S2l7%'H lk; K'+Rr3DF$ed vm#"1AA3 .Y#mč ]LC?pa,zendstream endobj 155 0 obj << /Filter /FlateDecode /Length 1502 >> stream xXM6!rf!J$PZ iQ(砵j,ّ$~"ek-6VCjF#H?g8=ٟM7a%yP flj6?zHwʮR ;ƛ9X lG0  ՀaǘnDgoc?Mi v̡J?9K&\M nQeA* HfM/'I 鵠2`IVmޯ2o|4AR$zznvm?.]S; S]x"t5g3R>5wˢwusUoB4ҡ///۪A>8+',]ז3uPGe@Ͳ5ʋ]yۖ*,T24@{cSb:`X}ȷeYTn7R@hpc;.;=(bzG=1;iͲ>ؖ=%Z},GL 1ΛbWj"؈oHsʇC,1v3ގ#tlz07_Su{]3üGk5nSǮ:tˋx8Tysqy@ qu?VMW[R^wmռ[oAjKЉm0Y5`g2uΧ9P)t>Φawp_ ?T!(0P~àtrחۘWO_q/m. LylkM{KEXWEԕE*w}xMޖׯV=R#jϪft ЉTݮX^hH{H x9/m* ݴy Q_)ڷ` h=QןK$:ɤq TQ^)_Mq&(Am~P32ܙ&47pޕ2VYPQrS INv[hjyXaVd$(zӉH.rVՙ\@_XU<%$= 6$Ax9P+Q$s݈@Ez}tpCj<6&VYlt$"<$;T𰩸G JN/JG?QS6&F$m@n L%Fbh8H S.9sI,sSsM7C(WW3e}cAp ((8RҔJ?%,zBL"BGi''e> stream x\Yo$~ Wt&6׶ cT:a4$3Gn<,& Eg7GGޮnVߞB0zurq?+oQrF 6_js,46C¯Ys)>q4MEnю~}7}g*'C0F":g]7(dX8ϝyXYCVⳀ`iXN SwX[#{Žv}[>Ǚ0n}q S6;l8$H:N؏iU&le |:Ӛ!2GHl޲G|ϞxuDg9QL37-P2enhcWVo"fn0 eO쯶VoS>YO7Q%Y؉ۨI(vԥ0|-t7/a'=*#{A)"A.e;'wd>aZ߲g”|ܞ<'qqL/}KH-Ӕ諞. 6QqF?9=Q-SV,sfrPRfqN1>Ec__Ϗg~eg KՆJוkN18-/Soê}I*"B$v~Z D qC`~+5,H׫W}v80h=(S<3o4EB$WLb2lUPˣ 㮧oBi .F FC3zNv *.p/A] =Bylڀ yY@Č!OQ?'h@DϕZK} EF_ObqF|@^mwl)-`֚ wo3( :Pn@IѽO&mehjmK JI`&;}>%Gy9p,,qEsØv8g-+jW-7XO͛BƐG)CV(=JᔟLp5 QT&xo)k;ZSi#A"G y}rATh4v^4aۺjӆA?ϫ Mq_%|I%^+|2UіZEeOR7 @0u&,@OX!f ؒg#\eƛEUgÿ%|OPq/'*3-[VˈCn48cjS8snn; ;)pζ9!i )j"c BӴ8j=h_$ ATTHi"{|"!PP?d3t޸^h&Վ+;("Όvp)X[2b+*Z9B&K]{#+2z`ߢj0WčZb8c$,-ʏ|.%,X#:ibi~tZj @w(r5i}11M9%Xn =yH-ZgdQ ESԱ/ujLAcEVs:q*πƮ((Af4b7i;dĵxo| kM--ȡ^ֽg hs}vv%6곓T}E["Ox/'%%f!Ze~!dhcīUVLk ̷s(TCU`1BW/0|7[U|ǭձ+e-h/Mm LA:JLw]*/X"1Iϗ̤E/,-C,csw.eWY)bUJR K:~p,gxLq/X{ Ae[.ǐS U1G!F` 7  9G׵aחW @4:]#HQwJmJ5_噒mAmwb"_c9\2 _MG AP2{z"i+ vzPME\ʧls5\*_\N,İP%'rU˰ ś8OzH%%M؟^Հh1 l=ҚRS͘" ~HDvN+tdQ-N ,K7υhU GGmprP ݏcM(5yԇbwԋSEkD+(x@mk<5C N.UdW`I:A^KU[h[<;/xRiA͡ۅ y{(OJqk$瑷N:[4՗ZjNm RX 3h _'ެ4=EV9\.,AMխf̎lu)u \OJVIke2_\ 3׌o͠Ak2A[OGlnl$aSx]}Ѹ7(YbFpZrus$;/vGZ )Q"  ,/ JKVgdku(K4hY6%1 Jf䫒4dx *ܑr#*}T[6 6>NV|o SG>mDdoi|SQ yCBuGA ~dp3!8@ .ʿ }Sz>jЏ!vu}v5\ɏb-~7Q1,);vv'E(b S1R?R-:Yendstream endobj 157 0 obj << /Filter /FlateDecode /Length 5272 >> stream x\sgط,=(}ιH!Ê7Zڥu40rEer5FןK^ݜwgߟ z;K\~wy+f5R=|{?3oV1sF46_/ڦ !+C* އ^uI5 A˗H c$RdoyD#]._ o: t8n[0Rs 5ʪ ~Tk9˦mϚS%/ide|/aWs//T̷&siEȷUbky=߳/5>mSX6y7s|'[-™qMSNΛ tH^&ķ74)_Ԑwjq|DK.%JH4^W:4ƣww fZ,,?Q [kZIXRX;!~!n Gڮ> pfi~[6zxćFi `h6͗;$j0~λDz8b+Wح ^phd$}8mCilc ˡ8q^@f.0YLh/JI:LeJLnqA[ s~ޱnחg:Xav`/*0{q}Y(Zov!A[4:40n;k1<7= $#'y,|B|L a2 _1Tx o%9)@36T0>lķ /d&Xױ2K荏oгI@:Ba$4XoYwvʧOC#fjI۽ߧ`D>0{"=@U!"SH:Ҍ.۲E̷˿_YpD=kٮ_P=Oz@-= H{@&5.?vU IUh],K?c ^9Wma&hdOf 4!~~R)JFf&oKS'=ɞx~_E>Xsr6oKF/٘&ȆȠK6ў䋖 -J*RmF=j$|M~9W!%llX!fMH5&ﴊ%&)ۺ|2$|R=5AWFldpp k$&Ȝ&Į0F#t@> ټ6R@Y1/7m^>Çңipnm}|L33d C\Q9˹?[7_l=pƓ>ru?Fy1Ԯ ) Wj35m|bdM9Z z j8 ]z.r+%F+`P[|:Ϳ?{A8~`;DwlmW'/0 @ns&LH.MM[L{ͮt3q2e v쑍&gh(r/سc>ב^DUawΎ2$QFߣ^G^Q'Du znT$.o Eu -fBṮe6mIX4:3F=M_EFBB@Ơ6ьl2)a8gчCgYDD*:{M)",|ς݀C-;ăa}`}Pb,0Em TJga~۾M1a`{m#']R^h\trƒu.ϖklzP 1tZ{,ZNz}9tfgŠs1LfQ2Q2֣cUL3a ĻJ^ϗo%fP&oZ,J^pdX>n<Ԃ\R*l!y;,H"NYP̹.#"-1ULYv J<5{b@JRSpDS^`mߍ.WS܂s&VwqԷ'|$L b1biSWkT!rZf-bud;2e7fTiC\&і6…iueJz|s4LÈIod;GG,UXVh׭o(7a$UqDh_6+Q% ow4 w)91|~q}2:#]G> ߞ,j/ab⇑Ւ7T4{1yWNMof|ު3s3( gZQ5 bNe|̖87eD &bXOkC&L#Z"**F%tdyJ~8-] USM!ވw)uIݡj 7Nu0 ц0b,9X- FTH^g,{LȔ44&UC5C9 o&2%X*gqOTLU@DCr~WaX| S)о>[ʁaFeJT@l6*3iұόǾ|aݪ\ J0̇PMθAT2or$M#Ky"U#aӧ,wX\:1c | ^p.Ic%7g|եN>ϒ\;naƍ- 졹ИZ663юfRLָnv}$ O 4/ AlSh^lS-pZ6ьS  Ђ%d76#% RucZޓL 1B#oS#)?*Y1>59MIn~sُs~>$PαRta'msK{3Ai,C(|R`?6llF$`1Y V?U/yws++:;0U8bOawk@1.Dà{ܱ I5 c$|7GHy\bQ)9 TQ&Ta tmQYZOE`# JJ0HFvwF*I ۀ }xx.D,NrWc$\@!tBb՗xLճT oKFt-pXS\$KNWc l}tSrPB!u(Mc\+*:p{kG`/%z|]C|!sJ0z$W4J2d؀I(sH~Ρ;!5rE)FuAڇ4&҄DŘW:7 Uؓ<̑o(T(9x45fwl ESQg&\eLR 6Rޔ׃UT%!FN}O9\"ʃ4:`-aC1E,tK:ANrq M'M̊{_MUW#@J>QnoQg[ıfǞ?]PK0;d+XR]$8w1=.F׻=%J~tF2JVl^\yz;WK8BMGK>Gm,դ T8b xGwvWSI,&8VzFw:w'ܠKYRee&R,ʹL]m?x8A"C (x,apۓῒd#B;+OFe~&iOJ6Rq>>/f%NxYyrd*Tt*POS[G:X;GIx @]h8`YaOg)pvendstream endobj 158 0 obj << /Filter /FlateDecode /Length 13464 >> stream x}[ɑ{?_ 6yjax4aΐxV_䥲N!9<ѫT/2p}_wopLFc 6>xgfy_o܄%zno?h K&%IZ(_dmOǔv1nml^|g]T3Z%ǞQ1.=M9eQ6 =^9һ"?ͧ2-A ^s .zÍBϑՋvxx]CN4$3h<ȭ71,+n^EbQs՟zΑl;i_?IcחhdqhzmxxY.͠lU^bs.Rכ Z-j’7d`#u%6Jd6yE=J}aj yDÜlIui iRzA9%R:iFV;z)=J}ajmk2%<3M_B4CDЬҞzs&+L:K82(]pާqtWJщ5C8om#v-,z[:ov:/iw5E*vж"ymR߽g7dʰ43^a%WI dzQ}n' o齤{{O %^ܜ^}_G&hQ_5y^;j&"Xȑ<򵙜j3E %BAŁ]=ByMY~ՋW+rM}szA)N澫pgBnj4Wd2n7ޒ+M";Z =G˵-CTOx7#ӨKc4T{]vZW Qk?P4Bk)y@n! o EDj y\DMCLwDawx(.q_&Qۍ})2eJ)j4 k)elpȼK}:1r\ZyX t^FJTrMq}[Vu'Hz[|]1%AqC&2$bW4xz!¡Sc=4HT{4P, 6!KFذ%^niv%;v9O ,9ǹKhϐmk bnJ=Gv!Z *Pe՟i\"ooZ8n7aa` ` oy&LU.ťQ.S2GyR&UޚؠxO; F23 TP25={08 GQS].Ukm]m,JWtmkkL)K"X̅@>7uFՃ2Gr5D{$FHDH~ѻ{ttk|xs<} JTrUy 9gLT1!ꆐ-FQ()*rT2v FQ7EaC) F-3 /7 Y^ъ岎(>ct rC^޹*ukUT6""Li0**Lm5bWoo: 8QM^F ct!2B 64Fٖ\#0B#dӟpilFÛ-8Rpf%:&{~f5`Ճ fP0A`U#%m,rh{xsUлu[v&Fr؀#7i쀊wC\%JX{3ABq!Gg4Վ'o0un"ѵT/ƌc乽b.>"rk1>Ξ tY "Ljy{qJ[\v%8ă9PC !*ō%;邎r3&+D`*5ZyC1BDrK3V &Ѥ0c@o1"dgB{ ۅѺ +rU{@5vWwu鷙`!Rt 4[E3F*_ƫ2 dr*p-,lHd1P[<ʇ9i}woPywґ2mDnc &vtyCCju$Uue %C D0. 2AE-'+OB-%rgM J ۄ݈jюdt)c8 >UM#HlU~&UM;W7-o1m[1,h\Q&foN#1w쩨~OI*grh֑|tcQ#axTZ)X?V i,3S$;2)RRNL];ՙ>TH{AnAFQ6Yn'"GoIf.&,LŅR"# P竔&&@h*e ~e0FBD];S\Q)^[eU30,C!Ɗl#b@.~q _M-l^v2I.j7FN俢ZJk'!p$Hpo_bc'2cHi; NKJkO;"m/^{@Hٟ^}3>Ӈ~|!;.3L߾/߽zû G(皙XV֕jCh((2Z7Bi$۟ڔPkq.rp5ZJ )/םP8*)ǒ9E Px 6FLkL(FJ p\[F 5t@ҬUiNc \w4JPm"J\UDI r5Z 4(B56')R'SȶS WŚ8SNq!pV)iX! Td˙v+;puZB`.Q*W W(L>.LduAjWJa4^,".]_S+}uN$gWJFTb7Qb^UzR-Ժ!ʦSkj!JjX36FTLa 2hd[/ZiZ1!;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 tBygT߯A*XWlz޹Ƥqe OL:W\}eÅ] +aQƳ防HZK끫R6\8o*eURF@yͥ\eLu<mY$}E6=a+u@1r" (MŬ7?lgǨY;2TPjl.h{BP;CG*3<YG\wdFr(o]ryD4莲/3:/ VwZ}򎍢Ւtl=6Vczɸ6rl=6nFFch:6EFcQ(zl=6E(zl=6nacQ(zl=6EFcQQ7n E*ϰE DZg,W\/s482TRxee2*iCW}؜-d8}=[&g 1,>3 ,əwuxW:eÕ0}U)#T(.K&iC窔 y0†'\3UFrry%HxE ؿSQ=b=}8ѕԟҊ2TzOoi!M~ >ʉ2N9-s[J6?]g;L3aĭel?_CNL?wSʸB?cMn6|}d3[>hh \BwJC%y.:6SQsN%2FЇ i+ t y~qBpkI qlSɧiD1̺,af->dii?dI%S)S2PFT"y7=Nparq7Q.NK Z܅T9e+$}' gĐzP)$ ;.^Ow=[0r$ޒ㓯zĴ,*=<@^ӳWk$Z|I9>daXHelkaYV z]8dLA ]D]CvHл iao;㔨 K Y54BCn C$`6kq {'Yv(=o )c$""l+/H9ѶJgRx)?^>\]S"T_?(~! /WmWZY|)(zdՒDz(=zʲ,`JP\)Ku{eansNd!/ %5IKdM|-Y&%d(f1 7({MD |l܈DwFEK5+!J"`,q,Dr"RaƗ=D Nt]+[RY;0U,G O˰$sGŕ")pO7zDl)n I0,B'3ٴ֢hI ,s&W#tӯQ?a%'X"w}S_O,S?6QG;^A>q#x*<ճx7<,xg<@O`G)CZ/Vtw_s&nW{;ƥ"_r8k)rPAb5.=(?r%FP"_|S$xn >$#?(#_b,s %KfI|[t>(/CI/')_1_򷿻`%`fG6v tC|dqkk_oqI[ 77Ggߞcwx|` SIcVeSDN+WDQ"%#hj_aY_R`2IA82e!v=ةHS#q~ ZRmR4l'_$6d,*/h5.QQ< 5oېXiVe=y  g2-I& h4 kbbPJ`(`f -{%Gv8*k hG;P]8 $PF#rxux՚|VYւFQiB=C,qb>ˎq)5bj0 )^iY%[/wz wM# 5IKYdLr0.D)L %6}=yJmF,j/Nv%H5$q2O:HL y[ḨꀁiyLю F`/$û1oѓfIԒӎfI"%i,hd+>Lht\f%@T'K|ٌI;ڳ6 F'nyȥ٘:|8G2ė[\Z@jq@"]PQ',|"u5',#5y=g"%b e'-j" pE IJS<]f* 2҈%O\.N"/`ᙒȢ`ts˱la""|H ]DA%PsfA׊)QXT1⬌ G,P3eiB]|UA4S C#j!cp5I8 z>Qǚ"0iU8HRF<>Д.%qіSYD_T*y8b^}8ɵ6bvM#5 wFr x+epJx~M2%d=uA6!\=Z)(`L|ؽYAa!Jbx\b!CE["{5ZRnJ `D!jk9j %-$CB1i& Y0cf${^q2[b% "T~C*1W%WUi"''rlUDx9ZtM %V'{] q"Cƥp*ݳ(cEc䦝vaycHZpTUխz `=d YMuYӊx_r%/`-- XM)D)L8r#emN%b7e 6EDI _ĭ o .  2> UVK&]f3tA)d\ }HR $ ݬwp֪'q߭S$P] 9׍WE|,S(ŝA\n簂N cIZӋ5Nr);SUT lyӀ25\Z"c,vd $B[˩I|eǰH,caL$.|kHm;9Ǥ\jȇTyӈ*"~$ߒˁBu(?uUPZjV*9aZp3m.>J~Je,o"[E`I [G/@NvԐ%ԃ`[\E>rVCVHo2: w"?VT4=[:#z/#_$-T`w_ )pkxor*V8%H0Xi4r|[QI$h.QnD`V C -R2 !^,g8&ȁJ1 "arXd) Z*AQ'!8lF(h3\΂˩!p8)3}(IX"Y{ݝh H~)Q(, 'im9LX5'Ⱘc #K* Qdd"4N)Z. ag%j~^`8M$^)C7#r[uv@*aq-H}~A9+(|Էd,lNJ$;Y _h#yJO^;%GxQ &)2Rb'_Y]4U=UkX2+0Fl:17g cpOxR >s80ϭ Mt[gflS͝[R>8W/><+Lwq / ߒL8o޿zxJ.kr\;1?3ϻ5mǩQ7^A/.֏|%s|飚qܼE!]o-rW#-rWqK-rENbqܵ#>nv&] ]knn3qQ]qC>n(L[-rW6x"w}|"wu)v"w9n[M [EEqEqEw"w}[-rWy9 >nN%-r6x"w[$ʧw]帎[䮯t[/[䮏w-rnY9n\]?nz]kUr"wmz}"75&` w=2 MD3}}2F;6h/G?j)e˚f|}G_}+rZ/?Xys59,)M|s嫻{}=>S6ނs}zywoҚf|p)ČGU; #}zCPV*^?=l{opP@Crwhʧg?z>55{Ӆ_HoJ_Uw0?<ןaqѭ? 9xlUuBr{, 5JiF)+*?άy<ԛʍxk?G:>gǥ*yTJ* YIx1"4dZ~UmZ(eNߒmq^_Bvߡnj ,8!Lmlmi1拳 /jORL|DzqxjR_㬁ȳG9@~0}DyeЁʦ3dh.rD,^dRMn:'٧[\9Yi44𫦟"ϛ><5β3"W?wf@m 4]Py6f+]TfYm Y6OueqvkEh+! (,zLAu8ƇB <_eM;w_]~/4%`ߚ ,#׫1\juWƖjSyʱ}{vN`Yk9ԕIDz3=ڋ ,'A#Ьn=ߊw%mߗV̥}ш<*4ћ_6Z?c> z)<̛&8àg׳7Ll|SlO~}j/g,ִR0UϧOQ3bZ<%t^eJQ Al3OW~NsnPŋSއبGM`j\> /Ŗݞ eUd⧴C.~V\rBKn4qPBpQ mi"d3}t mʠѦ(F} ;4NV\s\`T$Y~+4U}q?px m1ߗ`gʨKlt?C0s29’/ք+QdžhA$ܯy`it!Q~nUWG`KՊ=ܷamcGF ?wkCq(EvPs-_Mg&RJo>yqbaФ6ڵo?#:H6!zF/% bdL&(wAMK8.B{*=G9]ҚGƾu<qAưufߗɵ[_| SE#uG#"vj )QG)mAFwhXFxs$XKl?o39Nvɩ3wIJsF}tlx1joL*1Lw,Tv$Pd)uӇ%(OxMUFhE兩s'5}uv7?B0[vi).Kh"u) G>m.iciP]xbʳQ|4\p0$*_xo]0;мWB/%E.3|iv7 Nv͟5KV핆_6u5^Bۭ=﫾5XR1r3J^R'iEJ 9izҹ %Gޅ>|_F \p&c ]20ʺK GVo Qe ".*>)<:%Q/]0Y 3 )|5)7m%2OLg9;}K >s3CЗhG-endstream endobj 159 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 6482 >> stream xY tSu!4\E⽸P@Aqd)PvZJZHMw4kniSڦNKU\g='ΜOSc9}#!x<ް+–Nq3ۧ `>-KQC(hTo'/Y0iQ%KӖGH#gZrwصq'lػ%?My~/x '*b5,G% D1XOL"6sD81D'b!XLL#KeK b91XAL$^'#D1xM}iQ{XyLO>'  tƶ Oe?uޫxxh9*Ll *d ;J6j0Up$l*VC' B[GHn+3JVDJMt4z(u!gR;|ܐ lkԹ$E7͠o}8G,+G l\ L+tJH#S&lJY:J',]騳誏;䱔óWlپw'4oHTFT36˺TѩS@V\.UMu`(ך[궗\\^ |s[l 4g44d!eFDib]'0$o鿗ns'#y da1`GJ%ki2 Вr@^iU *Ȥ7 2sT =0X'9o,k."CSGNIW( Ѩ j";K'͂$2XUTZ]ܻ"޶;uc4u铲$d˒@{ Mހf|-}k;̾dSUU4dY2]^0ƃaqlO%Τ_i ܿHLM )7m:bhm841or#R QaͶ4ܦ":*c^{x|_+5g,'+AKB4Ѱ㯖Jk9\ΙA.VR?Ț 4/@6Xt5߸F̊Ar(xXLdQ-GJº3T0ZQzDt6 +tBpɭq4J?&fm f.ڨA  MǨ :ѿ7sѺ9@vWj`].s6¼ŽxgSrh1>4[kH5c]%Duy=[!t)LU:+^Eh*Dŏ͊N[%Hmk,ՅGiKmGVy XU'a)?;Z<,UaF: (AW QJ;Vv+uBM⪙L }j^L?E"*:~>'Ld@ط)!RE69a'JiCv˶(vhmj%ZH j,۞*ՕQ_YAYc|݋Do )BsZ_p6W;,5eW]WCi6y(G,^-l.M 2H,#ThAKDP4TK&۳w9+@ٍSԘ㏕8ka2o#[5h*?a([3~a`M%CI.,6Q&6ՀFwG~q /yCfz}F]vR ⸱ܫOcXGJ/{ Or}x{;G`;`n.8҂qjԩ(qKڢܑ%qƩ4ǹ>%X](e+Eܭ1$6bOdjIуFuT`uNB4EBߠ.=;;'GyKI۞U)h~ǖx^-v~KtL2FLHn7#k=}bG "9Afs,T'en].*ՂC(ޏq܅:CltSCcS(ǖ[Rc)<ɛX= 'ܖV{ ni؎=} Bqlb#Hf=> BzɆh*NDhk8tl`-l=@3Z1S p¹Ȧ8Zoɳ"ʀ<-*8EKu7`g@+[-,,RGФJ4FtjURQn{6ᰱ/cPr ce,8j4U:޿;w_ZFMf [Z*K·f dF&: L3˷Y=.w{OsW{Al69iUI5*i;6l-IWeHlQ{xh=4%a5{#hs?Mxf͊a2qqƄb8}0fu *c7#0T~j_d˜M1a1-6'l=_[\hoE+h%RDHn͹]$y-?Lom@&s  S3,8_PS5@Uث{͍j"͗'N_ g8?\O![Tj*lQ\:lݮE#`B9dMk ,=!~]Y*R%n8   3gm_mW.~W\I_F`4B/'e"'J2j 365}NAH^XTLGy#ࣣ80e`܇[+HF#M+䣘w)Lq$!8~A=y `nj5rsaWEA7D/BsK w&4~ >pn>sȍAX}8p)ss9]oR y7w1j"քmz[MgOT)s@k;t1= VG͠>Å։J5 vq(OYYRYOW/L&XPtj*W)tj&OKY,Wq,7dT_\Gh ݵLyenM&M;Ohe/zzҫ5M@"AZ`\dhYxĊXcmHĜ&T?^/}A%D{b{s\swN0SkbRZsf|jZ:f(^6ey0#ID|ziѲzDIoOPE2RQgԃƟrpot ~U-ќO9ۖ$ۓ8B|smb$,}-Wu{YX1{ LГh';.ZCxr~ױs<4G߳BJ.B+ZɈTVȷlCotYRAj OXa7G̍ݖ[U͖ 9~RJ!3JܵsVH]EGFؒK)Do!ayViRxXZ^P]WMݺa1Ā9㣯?3&._/Q(DHw$@#г#:%^UUlV dz0̋ 5qw r,;Nn ,Xu7nAۼE%V84%؏w_cPEN2N:(Vm-> stream x}ێ\ّ{y>"160Ixb_уǰ74جjRlXd̪a1Шu i7WzϘ!I},%@y*|):u6RScϬ#h;/`L5f%XŢ. _cZSOLT.c3ȬC\003yf"ş+'wZE}Wibeפ.)ۻo>?yͭs&?~znw <`3:eί|t{KQ.&^VuF0~|sGU6 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 r5"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 Ws4pmwEv>:Be*98zCoOB!JV3$pl2Yd&V&< V8a!-qQ2N VE-$j:Rw(=)kLR0D"pf,LiF񠙾-NNKBr gU/y+ E|‰!AUҚ/837i NaF׉+k9d H!G+4 ;#p)tc[R<\]`.4~(=l`Q",ѹ8u3Z=13'?Xaz N (nOuT}NmX$w4PQ0Ywhwps%Aʕb"G&>g $Ҭ/Z//0Hl5+\(kƻ;U1Cq7Sډ!V3,;YpJy6ER׽n&CJX@\Iɥb)82݄;:PNj~S`r,xK+R 21[X̚b995~xiG2}ZD̬HI>TGVmxRe\w=(\`Hȧf+ˮQRP(@$Q<IfZﰮ*p?#8jeW$X5G4,KW闽Q mJ7OZjI@=dz8-mשxWUVc0L4O%m=flq*p} hfG<԰IфJ(,P <ПAxU02Xә=Zz^VDݗsCX^fQ?sJ#]tq:zsc-,tSS1J({Q6ݟ#@lz6%HhMU(:!J-DgGauSQgg QRC 2zy!#Oc<2=O8Tw utS@Fu'XDASf.q'mA9ƈ"Qʁ1Prj`x sBu7UXf"[I(Ĩj981|iV~W9 (b){Z,rIJPf$c/% ڊ4|pP0qZFnVgW7cD`Z8w{s?)O zS,"N@N4y֠Xj C%Gb)p:` [njXgPA]t^\J^.Q(ͺm.J9ȐճFbq(S6 8S8xe҃JR`ٞI}bUXA@pr\ J-r+e!Y6= })dDNZ*eSg 63l Fw=rrpVVXg'S"srTZ1 R^_q[v>Cɨλ7Ы+*U]@J7{e2@Fl,?]5,?+?_oEwt'h?w>;|R5ݻw~rw>:zdM C~sx] B>u,S )5ߪf)5+KTnG~1{h¯mZ?<z3ͯl*#CCۇ桰{rkT޶L2{F}|^6KxN07v!I[MgB_'ۇdgdPw>4?>4\`:gŬ^czmP*F_c>SWShbؔZ@)8UG߭'p}6"%P&Hm]xruUK;L(d~nOwQ[{,FlIz߿|!zƞ?]P rq@ ͧO?oruG5Kχ77_} 2_uY!0=r`e$1*e ; Tdҫ ]B'4NQ.03Zϛ #Ƨ߭Kddac}&)V5u&22J’(W԰bcaXed^)0i2l;@1XoZjWm3(āڤeÐ^7[!X׬xFcF)+(2k Vr i5V+46OC1ڠz%ɡ.- 4],*J<42i;)FʽlGrɳ-kdF :%2s&77ash@  3ň:3Ob)Y~7# 6XFn+(BǾ%so5*zLZGl85ц]HO)J>qNT##/'P:ʓ;4 Ϲ-̼_d~a8«xM^3l(aKD~ݐg#Kto`PeI9Zs6rc3@ CBq Py4:u(Joy<ȉf/+Ǚ4=w_ZS_=^CbO-(#Pj`+ɸHac{"GMZ R#"Fu7ik! '&n CveKH$<K:)@.p8.iNxJ VxͬH҉s0D5FqdNʌiRG5ylM)qd"Js-Kv9axX5QzX($O$H;E]a:Q' lVBjS(j 0EȜ.A3rp-W @u(BK2)vNr9lA, :P4I !%^Kh0!-+y8 y%y ;a6Γ:S17ٲO'Fje2 w <ܷXXtpKBD(w^u""0!]ByeX߇v׭?1qOQ6ᆔA<ˡMe3әr[CCJZky:;%; W4QH}91%Op8ZIyѽBI % F PɔSh"<$_ 1ΐ71,nr*V#1 ] '9 **H^HbЍ/qT܌^:S3%I-ʁI}!>SIAw5ŏ1[J_͓a`$`P 99h?2Thoa]"6~\JFZSdJhLqZ'Vj4 UA9>>p(_&73 1bHg Em൶ %gb;d3 Vw(<{ĄUg~&0;=gF*dWL"/0}Yp pmq%@|V;+U37tyJ1N8R`~{ȼh ݶ&e)XMI+ `>4n-`x&+?%#z$;ԍⴞP$?-k?T})@*EҭHL3Qֈ>)wU) WhQ7~ l1Ċg&ʮU\/*\]tFm=5kl{GԸ8A(cnB$ϋh"МV"֤MӧVdNIeF36::mé Nߊbw^S ʌCn9Dfig3Z-:BSFX 0R|Pgx 7',c"s/ϖ.ZEad7 >ʕל#+>>lQJ,ƙC5f'nyttj,@eof 7U=e8y\g2EnKw`>0ڮX։cI3X]>XOH~T46^vmhE'e :z3S\C\J!v ~BiOFҮJMz@s9NnQ5Ď2 BXnwؽҿUn[ϟ7W*"Zǃ۫<z~OW|pw>: ,+$mt(H/<g)xk7ٕ\c/%,%5R[hJDVNQ2CE٩sM nzb":z&%H_~?Xfq8yPEFH 9T7}z.0gTiW:VdQ^=+gG# 3Pu䕋3~TY0"r,K_0!=fK Jr!\\u((!V"]:/R `skGDj8/6lk.Agמ Nrq61m Tu 5jnK$@,.)ԏFgWFBLQC"cv'+#k3_0yn>#<=_^rƑYe4YfdB-axK \^Q/4*Z"Q@nyRԈBuG)^kYd/rd a3x9@nF2=&u)gGj,hT@C}3z.M0 ҿWg%Q3 k|y<+h(]PN%EELgZwԋ#s% &Y=b1O- h9(~ !|q1cc|pP8g!uJiİf<{B{Ɉg24ׅ"-B1d\I/'A:8m- j5z= `x )`C<& pFԓhB)`y&G§YWp12Or^ p%D?2.>X-xqnpdWY ԋ9!}\+`Yg}%I(u (WD(=9^q^^r0!|.5u/>hm(eaN](ڵ&J8f4D)Ĝ;ÎN\s'ZXS$:7gtBf+`ΙXҘK9 iZZGsV& *_Ո2F`@b9Fi jBԻvTz臅5 }YuG-$/sժ99ZP#DSZL ҈9 1Yg*`B(Jj<65< .j 2m f2«`]"l êhXlFĨhi>3S 5S^Y;0)ʰvdtx&wndD&i Z[.=7^VD[֢1Z$SCnj.l+f xU@ ٩d |i7⼈PZ63PעGkX"d7ɰ6MR !ڦI([rΈw"&KQW lj KV/-"_]j7>`BNsq%$P'D>O(`GLƚZPvZPütW*`b$PY2,!(USMD b2,bZ(^Hn$K+`1luZ(kٵ(\u|,03rX%r؍8/a"̃B2ܖj*)nTIjBt-12ׁ'Plh1sW 5: G0R"o hוQ2l+#ūޕJ+ y+Chy_@ Xo 8RcnCՐ3ZQ(B9im2$+ !3ٸ  XXjgf2_W(m1s.X #\`BU#Pbrܽ%ҥ5AsG (`A dZTF޹Y'(Fʌ+b2CA*BAso<,V5W&#3%/*`^j? @ `,=+Uԫv\ (ˠ1E7T@c R`U-biY9) (!L7,|h[.%-) 71 4᠀u4bcf ,)~( GH)jK<GM7k@jE@XOvnwؽҿ3[ϟ7W%z/Tvo-T 8|pw#>I)UjdZa?~}jH1O6OI4OOn Wg&XB]kSeԄl:auV>/co}aKzb((tizB^?8zQx)clۧ'GOu}j~}.|j>6oeʔ':[jeyvtՈӅп3uʊ9'-Aa['ۃӚbzVn>)o{Noջ 9* f?~zno޽ۏ%61+&":겢lNowṠl If{{#yu:31FDŽ?%:+:+OGGOGGwzГԓԓp<؇6P/e.hL~q,"DNFјnO vSСxU"Jb6fb4ы Ǡp 5 +݌ՑH8 pT: #]RS s030(DUa.,To 'Zv, f9+) x'ZtD^).Y݃MUG^rOQ53J$Bfv9 ү.؏B"xIFºB܇zs{FJ}笲GyEP FBU`B#PfҢ8s1 Udv IQ#Us,t'\}7,دHVoL$DJőh4OL|D`P ).K\^k j h]HlqF ekކtT"MA!!)mQ$Lr,H(mpz)螮) JXRDht XǺMϢ8%Z-=-ŲY:WW >`nɉ4eF"'{ ScډrR (+^>w@A@R@8}h$/eLyzD @>0HKb^PնsEc Ν\z mQ-~u:â@)UOD~ oG'd`fǐXCj˰|^[l2gJejBF'$,!SZ*`2B%Z6'ot[!ۺ08UX Q҈zcz'PYy&G3H'

GVXPBd:H t) PA,Ź ,cyN}IH4aQ фIY8SWZf_$!~>Q rNⱭ#gǢa{"ӡ\3֤[\,2O0٩DHD 'RƧp ++@#75{(  @H38x5 ]i{7% ]r;oH̔P5U ]T@: EG6 06DDgdɨVfm-Fb, bDN*qMY!]hsˬ!64xĜ;1x4Y&N-( ǰ,(̓x""5"\ɮ[7FsnYȩZU@fwtJ GGSA p8U`䬉,)3k, V0 ``[2z PFՔHISq=(!(kp%!6=sJh'90Z&/*^](frK, ;Ca P,-5j@t(fbqIpp'o( @ͣd2[:tksQwPgp^y4fӀ4위5Tͨxٌ 8r"f`LR O'(q+^96 eǞɛ9gb-JcF.[DXă'Hb,^ 4aT[ ' 1$H(`HѯhpS.j^E6ڒBcdUԶuG )9'DWj$ TSb RfY0K%f+N?VuԂĶ|S1 P&K%8fXmJJ\xILM^Qei&4^G$9 i)xŪIlwoU9  `DQ\D4Ďo^j<vDo/@l\4tQN25x 0L5E21#SSnxIPxLwlh׼InW5deQ"rZP-1.#UauM`c}dfo颭5^ Usrׅ9>F$' 3T҈9 QE (Xؠ i&"2Fv+=ض`&a* Eћ8XcK"Jq `EDF.RB# `A1f+ 0)ʰvdtx&wndD&i Z[.=7^VD[֢1Z$SCnj.l+f xU@ ٩d |i7⼈PZ63PעGkX"d7ɰ6MR !ڦI([rΈw"&KQW lj KV/-"_]j7>`BNsq%$P'D>O(`GLƚZPvZPütW*`b$PY2,!(USMD b2,bZ(^Hn$K+`1luZ(kٵ(\u|,03rX%r؍8/a"̃B2ܖj*)nTIjBt-12ׁ'Plh1sW 5: G0R"o hוQ2l+#ūޕJ+ y+Chy_@ Xo 8RcnCՐ3ZQ(B9im2$+ !3ٸ  XXjgf2_W(m1s.X #\`BU#Pbrܽ%ҥ5AsG (`A dZTF޹Y'(Fʌ+b2CA*BAso<,V5W&#3%/*`^j? @ `,=+Uԫv\ (ˠ1E7T@c R`U-biY9) (!L7,|h[.%-) 71 4᠀u4bcf ,)~( GH)jK<GUؽ: [ԣ la4՜b~7ϮճfFD>hcQϮ>Bu_?=o?tL7ghwj)*#]^XLwKIO߭+`Ӌs%BRckBO_3ןؿ;?x6HNiOcy>K/æiЧ/֧b޿}i\K(ۏ3}bRDzo~z/߼9K}ؿ{OܚBu1wG|atD4t9JEm/mHN㍽-f!_œʰ4ϣitb~%W4hj`1H}wo9%PLSApɿ=SbG>=OnМJm+Coj_oeQn!)-X>-CvZEoBO9)x6YGY<7|N()Yʀ g;iD5e*hoM\z"W [~Ga_KVX{2*/RhñYGT5<$Cy-v?QKٮ}Fؖ#F:.v~<:c~RWo~u r,욄3U5zt$㲾AtX#L|8s&^c{s: ;壹[{*jTf=uIÃj#ugxk;I1 f"?z*"qtC#\'O_+/v:a3:_oƫӽtb-S+=o_ @LCohɩ\U-#/cxV·\Sqտn|)XA͗ϝ[=&|;vڬiiGl7c^ ]Dc;Y#Z#fS&x/ѹ(0I#4c28|F[}UygJN>s?p{Xֻ媗OzilAVQv,3o~ۮZInS 8_Kf+G|o<)P=>O%욻=S2$5Yg"<~R ~WI2r~0sk)Y :w/5B?[ū%\Go}oT3; |J1>}o͛4spx]9(|5` ېQUa;Vij݂FĹZsDyXuj_c}E/qVwRT^>'T{tLj7s7{\3(̞GR&xn^c.O|+kNN^)[=W4<+L\c+1N& 3!3~}t#\qHo{qys0rǝX^dp>Va!nUдw?:Ns`_oӳYNF?Rg,ԑޙ>p׃_Vaخ?؎p߬e\w Ɲl4w wgG2Pu>\OP-nzp˩XNS,YQo"7w\ }c{x%H}Sq|Q:F·o*w'`_O/OG&3N@:^o|֪f;'WOP<Wmk{Iz@íF)ۃ]x2NϾ8,]jsC6CH F ʦ[WbsXPxmIXw$Y>T|!y'`E(lv\1;BH4u$dv? N)c9,*68TgKg=]vppȯο{HT6zR?;-%L!?}s?/~#훛ub؏z>Ud9Չ`?SNi=6^@,%<>!d}Tl/ttfP绛@ 'a}sHJʛ'>1L<V#+~G}y*?-A$,B[Aj36B= @M< GGà5aۿl~qf @cszSϫ/GoNՏs˕hj3r?p`sxJ2x=KgR(6-u%,Ȝ dB{W_jߑ-i֍Z&?xm̓M=gmA@zL6m~d|3(zc Ơ&D^ SMۉ쎟f/z~XZ1k 3=V%=endstream endobj 161 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 282 >> stream xCMR8q-  12OpbcVs,jŦf,hjዸ⋴ #h,t`‹ ' <02ZYΤ<7#B? rGlwYx?{F 7  qZendstream endobj 162 0 obj << /Filter /FlateDecode /Length 267 >> stream x337U0P0U5S01QrR @c$r*[, S 539yr{*rr{Uq;8+)h\nn@n.P9?47ΎEAmcCrrX'>:\2/?BF?qW70ET󾱑>ᾡ=߿/v__1K5i~~N|2FuC7M,08pz*re%endstream endobj 163 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 278 >> stream x CMR7,  12Q͋oKL0bg͋§j~'eg #e'͋JiuP~>}L讧Ǻɋ !74/XWϡ=:4MFkgo0 7 Ipendstream endobj 164 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2613 >> stream xViTSg!{UJtMQ[+uV-֙EѺT"&@Q"YބU"&B@H*.m- SZk]:蜣Ne1_@s̟N'K= (OJ V44C½[ޞ5CO\D.Wdd*welOHLyT6g.Emޣ6R0j3NEP[ jBVQ5BjZG|iISh=&xs WktB9)f8il;=I[ҏ/3o? 73(jS6rI[LjL@w_(@k6~Et5;Q &>xRI} |~|H6G ^@57yov3p.FKן$pR,oҏ\WA?@,=Ğ[jeЎ=\>{ae ] @Y" n;tϳxGS rޜAy2Cc(&;LȂ|F~WcORXE1;s2}.! 3J h&Fe*cQTAJƝ[K21궻(eݾ–7|uYEQQNtr(t&ulZ %+#WrMu E$m=`zmMH ѮC7+88v8S9+vD} lv Jt&~I.>0Oh`qFܓY\~EQ6u h +tCܚ`+qېKQd Q/ZnJ"M!a}' 50P6D# 959?uEy/a?"RW%' u9*t@:rU)i+߅" R9K*,Pسj2w+seQOΝ#nasϖ*Oz6E߻zڸ8m ry&{Cm*DN3eĠ-Ȼr/h u\5yG"2ll ʿ7Ǖ0U ×Ej&*yLDOtP*'wF7DhB xh~Z{g4Kzʍtj{=gc*C![ ̞8&9mQ]sfǭ \{Q3aSfF-~d(Dl}vGxv ŢƼ:O6Dٷ +ut\B|sf @;>u-Ya ρ? ~'N-j.O &fwڑzD 鷤 Y ty\a;B0DoI`УgEs }320E|YQ-j16Z4mZ)픈,?f[42]n;lwG(CeuOçOi8C!N() M2G\k .6]bҜ̻È544%)¼uEpK{"v}>Ўι9Wn090:w'!!_>lC%fCnCwPM84wh  ZT݊^:zά5d2OPM⥢y?ap𐄷JLDz Pr/bl$o]Z uj+ r4Y\3;F%zHY\hvOTm.=nQ5ҍJ5nU޾}3ʐxU8 D!Ckgkk ztw]'uϯZP5O_ۧ{FY]T6{(gt'g5***e0U玲a J5]C4fsPp{P6 kjjFFj5Z/73{x GQ {Hendstream endobj 165 0 obj << /Filter /FlateDecode /Length 7374 >> stream x][sq~G#N99H=8vĥrS.ZOLwOϞ=HPăεv'?9?TtC˃|cƘ`7/%f4b6ɕ)yyyyGdز}sxdR\ +pzxdL;S)vaLVGgFUk.Bա mmߩ>fwx5Zwl|6s0a{zZ ѼEgӛ ݵ]+megn+xGL]6%.??S { .Cdvqpf9X]>曢5K?yZV2Z5Sv:+q_?/n|m5 ::dõ=S3NϩJgrbu}W.`E23"V;_)yOp]+6bO?kYY{~e+C+#~>U_)l͐S.&^M~^[%F>3czVlWs0O>Zr>_Z<+WbCz-&XsZݿ;k2rѺ1M&`f<5g՛8Zz8v__^0`tέ@Sjk};vk~ڪ?43/^Ҥj`̘vr01,wqsAY]3qܵi Y4woEAtsr6tv:j귫 kӌ !SCb!ԘYFȣ @nWH _٦ ! ,XHWu &}fJЮƇ5[N&8a\{2? 7uB^I9W#܄)Qk+%B8baTv(~Onf@$iz7kţéN㜚3{xBK{c'vI6:Lɇ|d~εt X%LDƕ{b' ̇=aX:e/V ]3c5^.ZF>q57-EhÁᴕN\|igW;D;4 gw}*#ꞓ+#h 6.s[kf[ ƃ=b8 \}xR/(~`6Ж_-m^,wc4;M-Y}6T0z2UUB ǘJ^lը1`ye`V lJcXiOJُ@LKs==BI3dc<&E'^Np)m`!& ʺX2DC_ΐ\yffl!4q]C2GlD^҇x:܆yTW;N ?rz&lݵn[؅7]qh)cz)1n 9s+Iq^ Cvԕ,J*ŵ%'+ԤGcsw/Ől5gGf(&-n ~jqT Pswi,6Ԉ zsWyδo9j{~qyuzwxw..w^\__~`(C4@,sy}BŁ?;nV1]ݼYjm n)o֎]9}¡&?yg L^!ܾ=9]qޜ=szfGx $>Afo#i뷑'~sPiOA]IOǕmHn 0+]|֡=|Z{%qq'z,D|ٽka}{U'y{OGb)笖L?__]\ZwǷ)UzO8zm5 @/0u6&_9:?X'\x}f6J?Nָ .C77m$ :bBZC<GKB.н&6&`"+ BD2DU)N"xCDE E ђ*,+Dhq J7ں0E:W؀8h ajHjVs=4ϖDD+|'gj`pf%.ü )Fb-s떝aӥL~Q(df禂ccZ"ژzvk#22=łͰ7dl>|}|˿y>F>=;{-DGJMql R- T"5!d+36F+-Zš @Arb\"ؔBeh*"m{Hj-3V 74't@ loe8 f#mq֠ R,3?4$Rw7X*V]3L 8jc Sk7׀6 [@ o+ _υ`۪`2Q*6!!-TQ -!hLGRP+G43АP'#@&6$5Zw!!x(ps5:uq gBBCu׀4:3XmKHi]]h6!7@]hH+!_ AOXLMkWVR3R/!MW4d "Л'p(m4> kw4\#ETdֵwhMGBnk H.)̀DZw=|d {qg"7A`suDu[0zu\kuDСTav@ X!wbPP Vň8bHqJPCP\{P\0zP\m:(Zz[mNXNEXnfہi/,73rt,'$,%"m#CQ,"s,',,HqQ"&jõh -p-&9$ЁHy 9 $`[$Hۀ A"mTLrI6N&9D3)H.@QP"9!&9!օIN!DrԤPHN!BEr ! XMr i$"9Dl$&9!b&9)HN!mS 33A̿ i ƍC_`̿@NeC!/+C_@2IC&p6L=ap6d噷3'ug>[6}٥| <Ǯ癁ϧ6u#Yc[JKwm)ӡyA2]BtH[yA1 ">@AR׼ r Cȼ(*އj}[x3PM`)'޷oPhJF8> > Ld>LL#ß6F[q:don@_1$jغzb^vb0OC9E^9غUNl=،݉5[RVnlÜA\&j?(K^1XwcM~lQ2͏mՁcNY39Eo9#ۈJlp&h36b{6u#Q9M)٦<)wz[|O`[Z l\iF+߮Xu 7FJ K"KuD"EHD"EHdȖzZsxF 4:XL#J FiBO9g+WYZgRh,<&Ϣɳh,<&Ϣɳh,<&Ϣɳh,<&hyMEgY4yMD9(#@f&X_qszp5,ְ'or3l'0 >\?ƣ°=="ø!z?,x\8>0o߽8-u[6A_/ŝ<0R|z;W.>60Ga4+NoI!|^L_޼ICi qO?ܞ0;sV=G*%@XXlH;` ~X^!p7]xNcXKq|Meӵ!mhC(63lI5 dmXgy O^< N~riTGn.6 P~OUfݫ<^1JM&lcbJ11y1YFCl+SAvTK뤔<\'u^Rps"Q>%S|P;+cc}LKdp6JNQ?~u_͟GݧжQ L7jd @d0lIƀĦŐd(뒱þ4c,WIL1,R$c|SJY2$@j,1 i!,R^^ I<i*3%lϐ`\&` )],W$h"9(U+"+"+"+"M&_,"A+ƀ#=u'}H.ܓ ";=u'MX ԝ4ឺ$RwUNJ 'wIxCJ{t _:qœI"4ݝI;;xw('YX;E߉{*Ta +Y;|&#+'X{G߉+w wM{7Q{{ӄ7MXzF/Fћqs "nFEqpWDvˡ8xG$^!+H"+x#r?W n,v`WLnv 񗌃nq+!ʯ(by+"/b$"+6"¯؈b#"+6"*HGFDWlDd_}F*ZMβкȾB"w՗iD]eZ/zW}ֻ˴./z}ջˬE_f.VV/zW|ջˬ./zW}ԻˤE_.vї|k]e/n|w˾5]e/o|}_v.vݷ ]ez/o{^߮v˽]%j/oW{^="{/'ܿ#rL#!oWJu?j*%H/ErjUUH=a1*i9-HO'5;|o޼Vmʌgi [m7?]MqzG"GP> hß"dxW֯et`Z2ga(;%]SӋ:𝷔o!ZP Io4{qGzakendstream endobj 166 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1203 >> stream xmLSgpAH;lnMZ0h -P-Zb 4BȖ,3cl~۲=|XL$'H"3 I27*)y*XO)@*iMֺw?Y# uFQKij[vbQBH$ÈLBGƌ'3$;27f&s 3BVo?M|MX+K J_yzKBCzmR\b[Aܦc0A|Yg xm8=f.MBB9A SX"~˰ ~V#=fT@ RܜXp[q,i6@MT+I8F \XU`sZ{j0h_׈ i& F+x'q&`lWg[-RqA$>߁GoBIj9p#WpL&zAhj繾8˼%ЅEK6+ռ0<9 # p!i+18;x9= :6.'y*4SY=jB~ǾvrVztkh%t\Ys`sa\=!ץE?&^0!f,`/ 9گ$([{ب+gZܠPNl3tF>VTU~cO8Hf6s\iR~JǴe3PϧeGB,e\ As9ME _wkvC#7)::pX]v@\V3Fshdտbp]轢'Q2@0eݱW+ijާsShb0l^B_d8;W0p2y\]Hڦ`>6O-^@_a6QPg[8Zbow 6kFF_c I\h0'߮NZSuBE|8ϧԋVh|Wʊge䗩;f̡ C%\GI\pK%JEԃǏ4nNYuj:qX{뷹'//W7< 9c]߮r75r=L.$ft Ht9A ! }endstream endobj 167 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1659 >> stream xUmPT]6MS8XGIP4X R؏.,,5] u݀211c25qJLgˏ^mLg{fy{>)"iYtܞ5o:[>#$&u9Sc:#`"s{[cD}Ã:3}`4$4WG'ɲ;FΗ'$;3#q; ® pXFCeヅ*O,ƒVQQ87ْU-葖_v|NгEt%HԎ4V\P+yZJ6Hw_W'|PָTJ2ٴQrLxm R`T}`Ʀ֮Fbػ~/h,iZ}2vAcd7ԛ 6ACXeރW%*T2݊5?ѱK2 Rd'.]/CiG"EEf<;[lo0y9K|{E܄kVkX-Pki&|6J C%Ip g8j`=L^4(T8f!W06BFW"xGuLO{{b] (^c @z="V;v0B#"ѷ % >8=qSE&O8g2f.7,Lvv> stream x\Yo$~#qv: ~q$eV CտO.3#i6 حvXbѿXg IXɯ'<\g_?\θmjvzu?3[&=Y[t}Sc ΅n5o9_V{k<_^aV֛lf߁y+2rIL+|6 o5y!/}(_&:1-lY8應Uq&a2rAnɘQz[.;|;H+1[H'\45CP\dȔhoĻ4g_۹0B7w=gQ%-"'&,PӲYfscҙ(][ #"M= D ީqO;:|tSx[Dh wG eg8iVΚzs_n}\o_i4^ YsޯX _`X ? lJO;3ḑOVa& dI@r4<./.7ˇvzVt)XX9Ku+[oOtmiOoIOM|8C:aJLr}3w7`+0Fή]J\.?!Ϸ.&|E0M M:lriQcҴvhDIӈMErE⽙ xzTvƧC9% %?I/p8" nf6Ң\mWHg ")B'_^W(r֌Z N;  h>QoV'O꘯hY$0؋X} #WU(\{+/}Ӓ, #CbŽOI\S!{l?t9Df)y(@g3 Be!`~A!T\ejTvdPAi~eqάvx${COZj_;`>NiU:ISXR] Cn)emE]R{+U/cG-5"pnܹcD91DN%J!>LhO\X4Փd*+-[/PaG~C;@^0Pz< 8IʑK_7%" C .) .~"B?ﵱEA ?rblHW2.724ӼiY_{ `Q]VR)~1tRtoEr/-δFQ3=6 ͸ 6WJd +;n/R2RRvFi@TܸZL]h1Ti9 r" $'{iۅر륚)B09f#OlNgpPRQIQ6O X VLRSs`yy'QTĤg Tm "aZ5bm)w7r]b/*.-;~tldc졥]FJCj <9"V[4\$ c>{k,ۺȖPB 5ntXʽC6qQMU A4;>6d1 K`F"dX8!n3DL cjqGzX;'ve40w9T' {xJbG9aͳ-H_h/s\oKswMa. OBMF[aHF@5F`O!D'3lE+uc^)~ADBwc!B8FP45$gt<ך~qo%9 T5'*ނD_1ps^TO5pՍL<x.Bo{P5}L8$^?'ތR nF82)XU(Tukz"Q G,F1uX>L]Q#dzoYjX3+ƷZwp\]Mo2ӊ8ѱS=U xe@$=/zjwo2=[ez@۸ צNĬEKoܰ!*;S`ˌZEZxu1!8x #!T.A%>cX\ՋGoʙ/C wR ,k^ FjgA,Gm]S K'M*BRqeh tvWP^ DKjℐtP5P;Q2ߎX1oT㊑ήC* H1Σ\ 5G 70Q <~*^vt"m-m_ wzn'3OmeHcSJE<MwA)P[) &b^tU7x0gМbe ]]tn ? ҳ15%:IG}r[j i{y((x5:HGgͥz*+cGGX xwN 2/,ԍ;/q=Jendstream endobj 169 0 obj << /Filter /FlateDecode /Length 73391 >> stream x̽_%Ǖև1~pA?qH +[D< nnNzgw[UF usVeܙ3->__ӫHdOի?-Z+ħQo!?_|c_/ :]s;L_|{NWbѯ;BLKz_hi~;!2^|s;:>&|[\omw/zRa.#YfFqji<` ucOC_k_ lmi|[ls*!Ƿs^߯m?R^Ź^kO=tkO߿Jo9oӭy[ׇ{v}O)b,ß ͬ ۹4BZ=ճʇIbiI1a7e̷\~ȼ 7\dX U>~³{,Jˣ];/z5bUBtv~e8멌.ߌ mޜ_h%jWƣ%,ve̓zԓ۾8,)uObIKcS߽7b'߾o_o޿z+<?ڟN~_7?men__>_|ݾ}o_|CW?P7euo}|?|xxo}7w&n}:߾~u&o~7ooo~~ś¼D*?|~mw?ỷ?:_= w~|ooJ?~a]o]uW .WW_VA?-?4OTwiۻ/7G^;{u#\GЧcr]4u}x|GbGiA1z{yd/ן{\)jw_.)@^PE(ΐƲD|H@^+{=P6+5!ՎC=ƣN>zq,a_]{\Er6Wz~R{)]q8t)[O`xEcx۟Z8c@ ̗y\˩zo g˷9m/ xQtlgQNsya6ckK? xYnC{sXm~DOTP+L_ Nwڗci?33\8+bj\ƳSw w[tXṇn>u[t||LCs$w̯>97vOZRǪ{=op##p.ؓ<]w8hh=I}QcA7.ݥHϢb?/2*F7QlڋwM\j./zRo,a=GsoNß\?/~S*;B2A( \*/e"1B}7I7_áȠeP|Xz}~ԢxQ̟,e/:-ʉY٣aJ豻q71XoE-8tgh77~n4R` {IquZL} x}c:/IG/z3p3_ʋbp-԰+՛,j{h?hQ~9Zķ_Y8 Fqfrc]~\ =?>{p'~ׇD_w*;scx\^s@bXJ<ٝgr2+_-z(S+`~wI ͯCn?;Zvqÿ7.|\OBmRJPb>nj"__RCZU78mPawxKTNDuF]RVph쟻nwk?v0 oB0Rwg"rDuGfj\̗wÐK b'sGRm}qo|R?ݺt?wTx{=WB?{왿מDZ\TWE2Vq9&|_w)og_MLW `^C>G+NWߺʑXC?k/}uN.G-GIյuWL>[x4ի?PJ aؘ#(0/Ed5gr⸕Z iο|b!srWE| 1Iw4޺:6/ L";O^r9MǞqgy1~#?0m'9>gî[w^ u)z<ܻZoyIc|H?\Azߺrt#~bo#%-]GLϝ}Tڈ=( Q#שuo %Gc_r bkh Eq):?ψJZp|;Qo@ sg?a?ܮ"㝊m`ݝg_o5ɡSQH]\q96?BŁ˄c5/ڤٱ2ן+t"-'E~is󭝳.OE.z_tdz <"O8v羥ǯ=[[n4Е/|Y]_yj ?5ʏf?FNqD_v|F|=14Q>|y;Օۏ|\E&#kZW&hUDsDmˇKP*8(?%k>*u_%jK>pG /|Ϥ4t`BSrSҌ;Υ?I՝uZ}{4UX}̜^)%lm0*uc?5?V%r;ꦹ"7Ayzy&u՗Ue9VW99^Uarrj+.rr*gpl7 s8\)ӊjTvfBG!bj51‘>U}*S8}WXau|>*ߖHZ?p0'Z1*pUw:\etU]&UFNWx*竎Yo oȋꭕԱЬ_PYoj`wc9;9c=sRZaZd? r⯔$_vW|W$a}ٶIӇ?<}n ]ɷ3z~H?㻷OÇ~k>hed6ثl󳚟=Z4vzPE&{!D\L#Vf`+! LHCNgNiaF]c"t8!g(tͮTmDcfHĶ^F٫j8 k%O%ɔ-yބ;TH#v@:)ZU&cFvk!4A '4Hde/lFF[pJd*xyk7/GeCqF%oKS$3B?JZ&eޫZWSr@sRi}$MI ͪSENI7mHs O]Ur|b׳;ܫZO䚃Yj^(@hS(6*YqBTn߄j~ 4]"Em!л.4Fbu{UL0b/hϽZS-}hm}dsq #I5gDX*Ḑ(VHՓQ8"b섒É4P*۟)897 FR@xWB∾UP}\O1PpOP1kY@ŃNDT<kt@":,EUS ac ޽pʡ8$ۄQLZ`tGWAz`X޳u D}jid[!"49MMsha]viսvc/9ijHqZ5H[.qpB[ٽtSyVlNd7FxI778J;_ `Q)Qc7[}MI|Fv%I:1sE#v4j.*(9V='|b@<ĿM4I^CJ^}F78F G'h`F ˴5^` @+nQpM "V޻,q{yw.J=i- _ Vن0Yhׇ12 _~!KO:%<6x)N(| \{% VyZPZy/Ø]1O8-w Q(BshjPA̛"w :޺[ź ui]粟K#1n"ciAey *EЭ=E9$bNF$(`yL HN(|r( fFJ*ݑV \'/NH{GJ`C#N(i>-ChȪ 1mwDix{E(:"h&Kw"ѭVFh_jb!9 t%<\ta_S( PҪywBSqDCe ѣ&g]1OZuW,++Jڬ/bo鎁c#U!be(Vx!)*~.oRoqB働IdU Ą?^WM჻ =욨V?TX{"):k_D ¯6HxGULZ%7J#" BCo"qz, $NN zfNnZdʇg0'V\HEF2|TfDm*#'IL@̪S0l)'t.2IAthy)Q>]j&bVQ/"Aښ]Xa&R7CPMҤp[v֝!"S@(e)eu?`b*VAQ4QsXǶj|_ }d˥/>|fZ=yVS'ݓij&{toO+7=X# "݃~}z-')CwwH}xjVAXHcK۠5fé{}ADBHQ^K$UzET|ы(U~섺떦NaX*7-Ccs9$;!b~F= *߶n_Xת($PVl;Wt)-Y4!b%JJb5晒XkՔ߾5S>ZG+RsYBp&|"֘imJ: u۝cVò@{Aړtڳt[2☕ٽ(}g!3IԽȈ"WjϔPyU\ҽu;n*m #uDS>Y 2S ԑMyִV(a27)Rxn平".5+6rJbn )_)K߂YZ|PUrF5'BK"ƣ)D91rNALtNALQxLIG'u췔w bNA1 NANk\g9L4iG΃"6!"jAYI)2H5dңy-X㚽hH<-fJ٧H=n Ϟ(A }GT0>ЂRPCnV A(|nen‘dFCPHbQ9 ꧵cfbEE$lOTTS0V=[Ai\ .7jJ֤E%bPNJvC5)@%Yt3R0' =M/)IdS)mu\'|jHb"jq@uJSwIS3,[bfMR)8vIɨ!(4UO5NJF #T}hK&EsȽ0N[[g5z vSeO4t h dO^Wa,]ĪJ0rObFdO6IB$nG]dC{dӰ =(9!jd IТTsE)!zU^RRAZvBr\ =v/>Dsji6ڊRA4n{ b٣9#lMTeJǭ2-5Do՚ bq+RC6ÐXYY[CļGeZjj1ՓZMu }B<+Ꞽ*lB61X%ݧK*&kM V ýESf*Hs0)ڒZ|+3Dc2f|μ5eڀ(.$ytYa]yqHP\ΦTjFKݘuhIlUM^@6غrRV '{l؞z5w[5H@bŵ+H\mb`d:SĹH*2 ޳LcMV@CF!qmG(R概D+ &b&T~z $ZaM @U'Nz&دdʼ*Mk'ʍHX%gh(7i0<^:#o@uy@ln_Cdv HI'H,]b܄b-?z9'S՟JK.G}@}@k)B'YŶzD J 2@7d Q$=0$M 8X2Y9ͿW'-$)^FONc2$M.O5ʍGI];Z!Rٝ ®)^ @2P'珓."g4BXɐDǜW)=$W V @B6Ҡzm1yZf8j>RrL`)X ap@f L&`'H4Rl\" @t/ #rM}]7 ~+&bi2Y (] FR췘)RuP02%y%"~␘y bc(1E43H yA.&,YVnB1a}1Hʛ YyI]*8ڍ l0jh&Pq̰Qy&SV^2$9(lF.%kZbdȚr4-`*P}`²* k2S<9f+9ZRHytd垥0 u‰(L)q)+/(/x(jBϤy4 @N <:W$@L3a~Iz>]ɐQUh6*NAw^vѩI#+;'K}PR".:1 ^tjK U+& yt'MV)RpB.MH$$;kLHq|n>Ϗ ȓM'T\d V0Z Fk=BJ&m0o֘w ңfǀxQi;qӘEUN ˴6IPF2JNA:әwz"LXG780v0j$iiln0tbJSg*+YɐUF_옉-~| ._ZjD XU lBho/M#KEE{"Ui2H H&SV!퇧4O6) @vC$tfi;%yiɣ $y1$_mdU,ȚE]p&we3բrpCgt@4(..8sHsmeML߮@8p@&f4YYq[3L^d ĆF8HSsyش-޳(4u be#ea)@(9b3 Pj eF#~L8ӕylVHgIRօ2D&+%HW/3W+sF.K׻?*+԰*>˩)ŋZ$19 LGVI[=}@!.nXs ^tB17YqH(1&ᖾ ^:j8ج gMTXaG$#1eД7\V :a!+5lzB6sIV:7k`PJ`NJXxL{bhr0} 1!;#bjN 9jB:9*u. I&*$=ZOJ,2J:\cBcMg${ $$gfw!#wne$ǜH=f*D4m 7kVx%MVA*1c)~]W!5h^dʦwSV9Hj$Լ{YyQ]!0(:dF#چx L/a LQ:?{u:SۄgkW+yW̭Y<[6Ioib7aE6KBՓM',CH({D~ ܫʫLɒ=t eO6%ez/Xa*MGKF!i*S֔.56x)LAd>\3ϟu"E!JS3ܟq:jTy W$|JS1SM>'Ԭ$F G3@"UV2ZArD a5vRB~t[Duq4Q`D S< OjEȅīHh;at.WɑcDMaܫLk*NC$ Һ$o!\V%'ަ$&=Hj94$MV^tfՀ1tX]j{RfH(p? /4T{7/U/3xtԛd/6iN( 9Vg PMN =r݇dϻ\x=A .ĬOrapkG 5ˑxEvd)~ EȄUܥxT)4(GIDDV ^hC!"r=$CH"%X(.3I>: O=RJr \rH4M&H}y!JU@ܤjl'e˝ī V]"$J(!ҴB@)%<))jTǸ{% [%.P^k@vLjIF:I܎IF& iJ&H<8 F2I(i[I)mi1?IfI []QjI$ԺzEY9(Cd* 6*LĮ^u@6_@=dMpp~wX!Q ɔU\4&س;+i2:6fi5䎖{E2'ȑyU IJ6A,4x7"qTv8D연z$iτHzβ5].d-:VZ'OANnEWS0W6js4Wɐ -'Q΄atYy$7{ p?UvsvD;$P[\vF70Yu;q2@ 0e37X@^ n^qB"P.#Q.P) ]$ꏓw8-%MVJjKI'25'Իy^ɔ5ۉgwuƒ.$]ݵx Yo9_ɔyQ SH{Gڙ4^-` YF$g,s68mw6 kpd2U/lH\~"SV~p>JCP RIk.sHb'<UϖEIGʞ=i2'CEI )YFJk&`5Q̌71r}Di. ]טw:*="ٓeaK˯LAsMHܥ ci)ɏ<CX)AGKN8وK"RRwS%KrT" sNA)&vAa{7tBW?l[@lcNkH%*MO'@#+Ix,&Y)T5Ѡ4G2D ra&UV^+w^ v&Ly)#L7qp9)WoB pdYWzս%-Y8Mz0GQ]B+Rmx4Dž YhM7\pU?*+e%tY)38Y+i܁̕tNl QFە$K@d _-dHIv '(gΣe^%|(|َs+xw _k]—e{nA16p2e?(ѳ{yޞ`(?o2euzdi-}/0Cj-U |@较 EOppb{%zڞ`t'6We`Lv ^2+ -=V 5#QGDM8LGK&q%|ܵx*E-Y|صXsFROWd,]ʇ]St )v Sʇ]Crd0؟ ra]&pp4¼ RbUeUFYYqRvCmhM<6W{sJ<ɔUڬ]v42tMޝpD*4TS`# BdqPgxed M OKśF H6Le 1Hk#H8&O$CVvL8U9+Lop-ݢHx%5 CVVcy%A`{$J;E:`*YMJ;Z.y&J;M} do_FZÕ|Z B';|3Dr'2*R/AVZAde,'YY Beq3.V=YRN|9AV-n/ɔmR&"[7iLOZDBS~;UO6L8iGKM8iH%$+Ge넣)yܮ*(Ƀ Y{_%]iwncP7䶹YhUiZL dv J9%bM_d3QVКN#\\S)R&\1.s)+K:!Ē`q2tmޤʝUN qbMtƝH.tpqwDMIXV)t9ʣ16oʃKʔ92v&+%$+w)]yѷK8{7K 'Sgq2oہts;Ţ?s:|+~W(T(3Pilt f@iab4֑PP)uY@f<,v"CLeބO,F֩A DFeV5y 0Sby8m9ƂXa$w{5{J;EvdT"#oBSigBv{5hɌgRz_Lճ-^"ir0T϶R=o]dc*I$8s'w >3)qRpNsn2ƙpQ}B*+KI.:m03g.+AT>y~ѱqtȜbѝ dM#J< Fq":Ȑ%2 "+KdƹT>390ĹGSd3R@eI99ee?87$Swh8 q"I‰FxRʛ`CO 6@1C[L'de UV6aq\t9dY̐=Oð|Tt'IؤNb&鲲dӢH/R20f8uD;Xde1#uL=0,+sO RP(W /Y{m;V5$wL89ɪ٫AŢ\syJ `m;|$ u|? tp&smq&JCE943ird3 +JQj(e!vEygeeqeNJ܉gK#58JeU T@/`#$YJEE27 2#8#E y;ڥ0VQ1fիN ?Z{q']@5eI=QSBjHQC 'wMM٨vcOEǤA'lT% 2ؔzS&Q<eb]vNuھs辬+c&v;n?xg(GL89]RgnMOaFVbMQC>WJG="4tTx&ܲ}]W>*rD׍ D !i(!HTC(i8y~!y@楂ܲB:s. W0Ak6ӂ @lIbNJ5&A܉M概<ɩ &SAAMn@6}GB\eۉ&ٻ/9AVDD 0[O0O0Sn. 0gjefJn ~YGS/W[}C&#[Ɖӗ)ws22-̔2$wX '0~%-Hd uAz?xcFGO<N_Ϩs-q(p2/@VGb=3Rr Żo8y9]A/g2%&LB/5I0I-O<].d0"+ss8z9^U(#{ V,#{ CXЇ+PΗ0HC8 $JuId>ag[cK7DOOA(ܟtYCŹ˺)&\C~<,Hg2$zr 2`J CF0.Ct :e{ANbKpr.#8t9+pqr8t9k@`pslm+Y@(tJ[NL[ۂK?ɏ-|"5H=uez*"7\ S@^2CϭܘD `a!z]r3ܓ@%BH܏?~ќoN ИJ`gLwߍOq퍞tTJA*WRed}pr">]F*'FO Bs"S2 p݃~3tM}v߾'ݷ2q?ݳOw\H'eF8P9+@e݊XAFr{k^b|n>)v˝3-$S niL>.+[qÒs?$\π ckRo ڤLw1'2$w>n~l;@oGЂ'xx8(m$IGQ|&̋^y>ϤHnSvX<τ.CmM_:Ӓ@`\Ȑ~2 b)ԙlكD?w P{e{Ԟ$P=jҽx,3ü&+w/5wJ  -LtϾ_Ռ I[ӹƆ>oqI'e&Y0 9 WTs傌lA5MP z3> l&SVִb{c0kHKV֐ .w%p霸X-#S7olPot> \U9d3^ VǕP+鲲ee-]뷬EVBqy9P HP h62$fMBdJm'?(᫯M& LcHz=%bDZɌgRΗOH"Fp 鲲+A.֮5&8ZG$+k]5@5LsZ Ľq&9Œ\uW=bZ<&D9ϛ4YY`U~}>n I[:lKXƙD)ǔr&Igo@~c,+[O7ee'nOuc* J? O1J>=!ٓ5T׺ELɵ ͓}DI~5e :sJ~ > x&J?=!+oZS ?[NTYy՘Ou)e.#oڔq7IMؽӚ$LYyԕjޞ[?;7vx+GؗT vѫ"Q)M ^E R'a{ _$snh ZW'|Z%PS"bUVsAֿ1c& pt3҂:[ `{fk#;V\ Ҍ0 tɪ\˧},D!F1u"Nvn_ >60\^K$s7r׵lFX i?(5Hd7i-NV>5Jh/Gь\5|_,b?T5AC%x(LjNV'zO9 Pg5\ǃLRqsGиb%x0ĥ|:<=XU 0`[eDݴBnL]̄ xs%x=bpe_ped8,#JȽ.uD%HULJMs\G\1 a!c6 ѫ53s%_Wצp!_dб DB'=Ta*vE)\{(^u:yPc_G/"'&0=9ԒLXCs}D^6̋䱟 e13oH!*ةa$q{lvb"&:Y~1"}.AjCDxxU`IAE+kbQ*u5b-9\dVkbeI 7Econ`D7":c6i%;B ?E.O54D .%a'*&tFgO@cD؉8Egp _Jnu^M^8B i"|ax ɋ&3t\$I|/3{SR$\S \0n7Ź׈ )f.`*bc.[F(^*%"vi4Er\<]"b&sʝk"J0>rD}Yr$\Dd D{13vųx'[0L"a0!b9%,ߋYɩ8۳e#q)R\_R3ɠxS݀`~)Lvc;W*= En(Z]ƤV&˝\Ă'ަU{$Ս/O|Y9JT$8 ?`$ٝ'UL!:2w{-Aߢбi}ϒdh.4U׌4= 7, |'l.^)v8ɸBtc{Sʝʝ7~QzM8S`I;ofG(\q|Vn$zoQS4Pzfq_j,}XC#0$w $;g/DIB R;'YLuUFt3I3$Bމy$$\q$&K4 8JTRU$y6rؖ0XA[sMo)iGGOJT+#)dMIy\i??Iy-PE%(c~R^v,Tv `(mᏁhZ&n 2^fL;~E&/#[CD"xnkuܖRbDxr _<lΕVo<7gW Kx3uơ L;1=D)_˪4$/tjؗ{o=S&0PW#&_St o`$ͯy.AW fDDU>/GK4Ӭky˙W>=u/RqeB)\"x.xy#~< Ζɴ7"x!dP)X@֕H%{kV-v _F < 9=[3bx--Rg}ld1|0~+)j݃.TU>nL*;N쁐tx)xe"H‡㓦L_ *w2x+Jd/ӋsL ,Nˉ=tzxL @86r<=?=ZZOǿ#I_CF0<:k3<u\28k8>MO£:(S~#$Ȩq/: ㈈o~=6H$9Ey!k]E8I9IK4Oy4"䗱+ի%dS&7-&[#iGZNZEG3$# )u‘&L4p|%CS>෴yp@Fcd _&cT.P@j1E¥JSD{I{UcYU犼h?%wX!̗ߪϸxЈh_~񼦘t/d &b_3"#F滅#-,k2J9=]<#8UԾNww49'q> ęgNUsޛw%d+ci}b>˱OG-ŧxm\㭊P{!O`hlX#8b~!{,#`SXlOٖomFze=o,L{Ȁ/Ӯ2U4R [=D\]GrqãiWqk+G)m>GY"CUm~E%d߈vNb@|!΀RG@{hi^F\4x NiQU/]_֔ ='5Mc=>ˁfd+ӧ4O嵊OGqpbJڳHUU2_ mk3<#Z[[|@riEޡ io Z^io3~Igc!nܴ_H!8 9o=(n~jjJhm}lZU[|✷9OUKt[Y,iR4u«i d<.EV]zٞ^D&ܚZȃj n{-{;Y{ ^5I;nEsʵH{]:QkӪę爆A71i'g:T09G%񧣣:c| bS0W UCFx<2i}V]:GfN $hW O ZdiW&Yylܴ7M.-n㝮6b4k!c[iHbVh3j%-ܛ~&K:k>S>XUǾ>OI{HzriXIa![L2k)Cd"r_ar-cʊ9^6{] @Wi&+JFY+Nt;L$mZy&ߋ?Ι}az,"FE8D-{:_}fz6yRVsd=g~9i`8 !̑Yɴ6,M1٭OwT&cBBeo_";/w&$p>i>UM-q ??ÜѨ^A%7b#qf ?m L"[X[vPe)wr2C"7Hʣ3)W7{\99\4F6ISs}[ Ş_)ɱ=ZRv&26r {ɴDy)͖([Rp$ZYlk}t6 d<;%㟾!㟾jU.N`룞4qiN;h^45W9]5Z`W48)OHTߩSd tmxR>Q^dd+2^diUho]g/afD=ULEDI;q)t_=#/=u ϫJHsS.K`?5Qz )l ByhƎ=j @hr l QwQ>97V,墩W%O>lM [Li/]2ΩEKsFVH@'b^*S-|_sr%9oސ4 fMǥC T9R7a [໴TB:bg_ ciH'd0n,e Kp!Ǘw*,ʤ42LɑZI GKr酝^$3=F{HQG͞rVq0o]St)`Ӑh\]ć8z}K"3eўr3YbrzPZ+%1I~VȌ612b"x-`H0vK#M!1^dƦ7;L-Xy&[ӫ!QǷh} |kt=O$5=m%V XMXy=N?hؐK1x.hchҘؤ1yehq)H0O>f-U%|KdzR~̋^y͕&2\uIez!=d2ߥ2JVcd(]6ri"ƗK0YM#i-Qn Jf}y4gIog"3\4ؘIpδ\6vҾX~r=Wt5 YskhϚ= )s3sA䝡XЧT祙+^)F*ZckKj䀬tt\;_ <*GN[b$䣡0LzSܩ#P~Wyc~Ơ:eR<=gCgS~RcҚl+Ib5=ʤ5=d4\$IK)I:~_B)#:C/~_K#W'镦']GC v2PFLe~U^& W1Ңo?''< i8&U##jsd+ $WEm u|o!B\87gQEyG\GLS58*ȶ&`ߛHpz:jҮ4:[ a{#M#i4[8$]d%Odђs,9 dAKs:Ł&[%9#^AoB$9RW:2k]!#k-H_U/?d=\u;)%< ՗[8rFQ(2f,&C1crnk-"`29_42W1C<.4gidƊ qHwzj1iN#AE""4N\8LiNOS>ƎYuJsz:09r͝=c&Dk(?Ђ\͑sAyQ+c&D'Vrvr > i<_) YNl xU\5X_JҒu)Fꘫ5uu|ͤ]tI9؅˜aҵh%o =[[r0Ԏ&]crB`]AF$]D*B't*A1,R^4 E2ql+JIEc/V>aa(fS)M#JEd{~1ud1ۤ4Rd:b"r0MJ+b]%KizGkS`JҔքqߓ X'2{iěiI\{-b. ?ɺV\V[ԪQqʢIs!y!nӅrU``WE/Qߊp$\A+-p ^^$9U,b2FL|\߈=; ܲ,7s+!pJv`+B.3)Fҋ#E<@O7+4[!++.;;m U D].o*٩bKW]nķV&ΉU`b+=U"FuEetU~WH튨]zT)O##$^+.x udi `Xy-&/ '",/(ZrQU}7"BV.jJ҇Jd٢߈L{L]_΍2/JS;3?i$?]gcD^ڹGAe4d-Wv%K~/K6'.PWCN { C΋MR^U\bQCrzCܷT^IyVN jMi8/ǔ4'YoM?~قltT;]>VӆrI|3.;3 OO\v% IÒp&U|I|z%s*i:ygI]ͰC̀ ˽<+ߒo%YvΏ$>}Ti_,O!ocq,Od<Ӝ-Ygrpݒs=- yo)POc@a+yϷ2wiS֟k-Q|2$?=c(١@l尩i+9e#]gW=/5ݟjFͤ?eQ1)=@֝ȷM KDH05miMLt=}.Қƌ;R+N[ϱHs43L@=,gxH3 [`Z1DȞۇ͞Y]B$5=ݪuw6pQ4s5;Y*+rз#mMqN5NcDiV}ɻƒx3Ta׫a$4=B95򛴦V%@|d_<Mo`7.Hc m)ĔV $7VQ[T*׃ӣ.)ΛH n{&3 T&\rɹU9?BtdRt ёx4af{$۹#`!BCֆȃR1Zh q2Gn?bClRګh_W^5ir%T i "8ro$HUtR 5=NY?IyR3_+8"' WLmĔ:B 8?%2Hc3֒))cY e#fE/ 'ӒRmޒB^)͏K^N$BB =Z >sAݒFJKҫ@%4/ Dpѻ-H[j3ְ-̅H[zp_6c-1{ǂM":go!|r`3-iU/W.9ZJtil^HIwVw0Z">k`lp&L6rrdm\i,=K\4[3d9y-\XN"@r2d? ߳,!$yu#>r|@Ol#b$%+`xk\%S. H29_ffO1ER2$o@H"J2i\%?X)CPOBzEb?RDI&\IJ4p!^-V/ ,b%**C \Ɲg@{B`hS!Z2x鹊fmKnʥZ iCMPS @|`ܙWd)^J rJ3mgBF'9!zrɵI#M41B do: v:JRsī}ɰ^#>=I|Ogt`թ'@_o>`/ \A3"G6-R~i짮&OJQ "s駜)OXm~-02z SqUhxʥj5irjgKUN4CD "<"CrX?X?E{rk쬒] Qgp*og N!b)sn]Ԕ>TE.B)k9>OgEE.iQ+ϫʵ"kOABTџrJIU{)z UUn*  K1"r)" d2eݞ\SkuBT6uȶ{ AXQT{byoR7!rUiMbiZnLڻNVL-r(2K>D{י-S :E|i:2l~ڢc=1YYLD{ў-nE{sqVEHix]Mn]w#r'iYj+yX+=A=*]ɾtJMrzCW&qu I|\92tW׀%LbKrqρ{$9L|u7 {d;?e!Yʥ6"od+ LM Q8~ru]\C'ԂwR~r-1Z/&~ra=hbחi_> rЮG۬jդ=G]M6AMkvӄ,TU.DX?iXON%+!BTV?nUU{:}> Ptz UxRTZ4pYbP\·Psz' PsNk KE)ͼFG WS9?µ@v}#Ó=..dl CܥUGpU@r5m5 |{M+~Al?{~G`{t*w~2m~u\Wk-5M &B$K-'D.uTK.cps8Hr1V_Op|hWOP>ÝS9"h*O{I_RgQ%ktpK›Qs-잕w um(S.sȜaWr YH~=Nu1/bYxqrJK1kM5T ,uj©@ T[0CyU ĐCxs ~IC(G>p?mw1yRCbbp2(zˆ`lq⬮'۔?#(#iiH>-[wVDuslUWYsㆱ'^5|;\n>Sb4 gLݥf(@q3JD /-{t3&W16 StoM:1J¤IAKenT7oAj[kAA`iPESpj( .kߠ:gƯP~9 @i0I1sY[ۄٵarРdw]G\8]N<fG q(h;3HkuAw ؚAM<IJ@*>< 7qʫdtʋxDUeesx? u<}Dk \_q?) \xOc'8,CRA; W.j{'wka-~zlոڲv z%4C30GFf8'3\Q4 n}Bx5 WJ"L%ʫic)T#Xq?S/vC\tijhZJ7ʛiH&+## .M(؉0}j oẜ@ܾQ ٞ%_[iꗿaKic(. T)&|(ҔO%8װ3Z9x4xѻ6)ǡHv cDakp *"&oѱZ@l@n~jy ,;e4m^Fyf_VU}ۨ\^F͢4Gh6Z:wcv {=N04z i}dž720Hpt@53"Z7Ҁh0^T YhfmD4O_dㅴWv_Y-_ȷjt i{iP[Qx4;B%)pI΋x$82E[Hl*x#3޵眯#vy4xZj2+'}i5"[2xL~2H‰H_q )+g}:BA|m:y d*H^: ٕʝ"]!酂$Ȏs}-u&I4ڀ8S7b o:3# |й9;i@ iK/o:3>lYa 83N(}sW3 lqޱ>cf8܂M}x<܅Dom }Чtާ6k 7"^8~MҮF.F>p5}t4WK) i}젧1A[/_ݴ;pNArv 4»iܱⴏfDZK2n8c=Kizr e o/.L "Uh"y|b=ぐ8͢Lzzܷ_Ux4nvI=מ !K\?Y\n7Ӏhv#v$md)ncXf&C3TR3y7 QS׽.N 4wźq xj=rvtU{NT‘tvZ-8+R3M< 9Lϥ02 5e^UE#{vڋLyѓfкL0!7~ڋ O#mrx979 fDhpqۊ'ҜcY|y9 &i>{[ N{1l^Ns#z/&a8H{뱊l^Nux3YD{\Rm58O0%&ec_ZK dV| rZo%b|G'B#t6E{vӦh?,~-Eԑ)*4x75x;jbb>bnM\}C̟4Dk֘dXiߜ|M1^|G֛k~@֛k~Z/ 3OT2_B{6xr񆚟ߐɠ@0=,ę/7bI |I%\3rJeb^R8$K"PH2;U^ /9 `$&ċk$l$O}]oߋW^y_+N/Bvh7pڌpus7ўD&y]ڼv==D{jѮO~ _7 I36>cZU kxC* 5 ܠ!نΪ\M8$=k 5 k.[6{!Q}%2B!KlԴ$U[^T`{2;P'80 q!U7MU籐ʐx9xFa%7? A|#0Hw d>BGaMdM\Yr)"j2Ca">[X\?5L-WzQ< 0@溇x֗ *r(8@<"@])^U @gSb?U꧵=_-4Ԓt2/fIw ;3Vkzf3>iQum.x@ 2D'Z'dREw b.ϸV @xv\xU[[aZfHzHwE+t"6鮲 ળ]*^HRpՄ/=/@&G'Ff.Myq#}d4=kTFf{iR,-&w 9|$ $ vسv R;;fN)Qc唢wv$\yvmO&Kݔ|<%fOrj1,3S3G=)<9{R.G igRG=r)9j@~Q[N;}Iz!%$1j@@k&s_\H9W!=_g)5Gɹްt (f'Q,'Ons32igVQ)M甶%D=J#[B=Ey=hW8YbqxvLWˉE3Rt8\"v02PO{%z߭RsjmC稱wTy%,1J5Dl'vRQ49~@ |@3 @HK[j3ʁg!w # k *\93KyZ8lZϙEwiS"iG@31_`=f |tgIIxzrU .:Hɍ0IKwz p\|UǸ@tQL^O#]3(f ?s06JFMyAfђyMCӫ. e0#=c&O4+;?~Ӱ$^_w@x:1Kl$^oɬI< GO-7$LOsqMϙG+W%4i#WOOQ{=WɉF`4k5 $X-ZKK3.2g.] 8PSK~k%QvN5)P\&oO̊ebʰ^m P%@=-yWwO=# --~[ YL{DK*siF,yxϒ˅ >"ޓ JSZҮMJ@{ei% k6dަaVM^s'3rL;l :K}HWsS@u>#qw1-}4$}n e$XDԜSĞ"HzYdeYW9{Ϣ`Eyw+EFw"L Ž.G#V"!b̜MY= ʵ95>H}z,&_nHX4 ?ך]Zv=rse PpBfN2s˛Fd5V՘f1sx k& H.o&K܁Xi֒xƭxi[1t}Opٞ5 HW$v0sږ@Fjg6K;W#KzO/9Ur/R P@U4-H#t~ PG35x&}%"Lkv)P/rk\v˯=+C Xz/Qp1ޡ;JŵQ܊\-<? `" $<76Fnխ!-o8ݒ[Kz #ZcinKիYD{5!lJzؙp!R^]m=yWg,H w&yojs;;M Pn[]/?|NLlIzU@jN4zV;GHعzo$3ͭKPk+KdIzJKrLLҺQ#f]4Jf5m|".r5~vvg2g2:n"}{K+޹iqۖڗPlEHH eҢ^uؕ cE>diF$F}.&1/Mb+oģ9>đ?$T)n; U#& E숽 itE& RL~HPyŁ/*bI{ Xg"ػSK?]XtI׷?&j_jCX?ˉC:wd+v|%}% :P6]Ϝ7B)TR2iCj#GbPd(Nâ&FbGY)4K(b8b!ϲ^% 50ZI5[Rs`-DMpOkLO7$62S kiBx}OPBzZlNe2 EKkZ&'M˭] hГ9 3gNWZzSpSbi _5N"2Pk{L]-Gu`>3Iy4fHhSO3Ht=%n:IVaI^a9h*_.R~krY̔>U_fҼ9ۿSLSOթOL3Mm2or/b>v &Ծi fȵoHUGr1طJꛦnё  !Ď4e9!N/+T3%kvDL3E|{͕&yG)Y;ֳC[.\5)WFđ^E#C)){$]͑ YyBs^އCz2ɁÕIR}yDk}y$IUg,Vzd5$VƏV 8C)+175GqGRU] ~a?z*fB4yM9dټ˦lԩq_mM\ht&b̃p*g1RX@i*-pmM\C.JS$Ktn#qa\)^I=é[SS4pY[V)kNY9CҒoU)Rd͠tL2h ^$3îԥߒ\Bu'I+I`ܲ{ 5 SOsqt׭ߧ )jN㟪j@bxحRvIv9q΂m+*?lwi$ ^oq%9-3_^Ix>> + ƭo)T:%z00G3FKFK D4WGpŠbDkv>FFcIu -j`VNf)j`B_S*ԫOSx`]=Y#a:A}o0(sH;e/O/Ϋ,Ɏb%9򸐥lOLr>=sƖ4rkwǖÅ-.{$Qħga+H"sex vvB r泆+d\YI"yLk$⧽1,a :OV d=sj5 )RŨ"i@bG EZRF A5a-=V[?糲 2r:+'u {$NK֒LZRi)%2ۋHS&d:B"$r+I#qF%. j1+6X-X+d0iҖ^Q pUB嘰".r#0JL]%- _rL!"ͤ]K{[l;ibkX33I 3"rעKUVoiFJD%*ҌL ۲; !ffꅬ ڡ~UD)ɶ79>z[8Zr=~G3Fx_cC=qƒw i_ʥ)ڿ<*B$(=c|~c|NP8#LI7fAn>+##/ E1*"#e=WYcFzҫdYJ4\R:2~꒧Y?Lkpҙip7ٞ iIPzJ^V[%jjI{ \KPzI|4y&I՜ iEdK#w"LrQ.YeI&@ʣ0`"N򼽠VI&72USQғQ'. pKOq'Ȫ/" U$_pU\}b%+$( f*GSIBك#=};G{ ]*XµsEV߂^ivǤ' ӎSmZn,s=!Z2Y/s7AMbσB ђڑ9r@v}IIyґPɣTUk{,%ix^i!42 .Ë9" K- %,{)Ik-%% 1KEHWMײ@rq-G6rv<aN&M392/\6ܔf nb6WII4SW倡*UE@)^j2^DJ+N!~r ڗ㶿"OMVkm1!JтZ4 Vb"]K(z0MNڑ$XshR^ud=rY~/Ipa4TKFKP1pj^ծP%"MJH č:m!]gX}JYI;O.~Z'yݒs=!5\(ɹ^!iR{b*pX v޻J]gzg_RľoX-am5a$ (Vd%K&;ZdQ_>'W^ތxw\egLOu+CCs Gjn-L/Q0XoWQ;eN!GnǙ]>܊%u?5Cz6b8 +\Ò1\ ˜1vd8ybxIGH'yYzT3|kP8NT9F\r{JVaHk:4[": A})rFa9&G>:J缜x>Id*ϗ#¯/I0H̿''Iv8N{w2^ω``wub"X>9Az|%1kdZ騘}$:haoQ1l clEzQ=uסG:J{DtA[z{$ӂ|w^9y"k޷` wc98y>|uL.3Mc$ph< dwʮ6JV^dQMoq7+;c(' ]>jM^ςe>np{egޢmZ] <ڊ3y=} B+w`50o9D^yB %5ׯ-80m?%wri~ [o݈Osðqm`x:A||SyidbύQ5]`8HGpݷ*Y5D2\XׂG{'QZM 9 aIJnr@_1e{g*, G酋P*U.0eU2<?cALYn%>n>FeV!gYO_ \=G_8"UFt70ad E}){`/LX.5ZknQ* -ȩu?Z=řV[QoOq"jm?Cz=+UPWPwVm<;\+ Ff(K)np{PkTL0TkL;URQv+f*SSсxЎv#u`zpBM;e#< SQd 2 ޞSp9FA] u;- Ă;ƙ48zC5*1I|n &){jOk˜an^0hr|ނ2ߢzcQLJgZ]AҼ!(^1dB1ɡqAtz1YꙊG3en1%w5%2K^zz{NOzjĩwwW^Tg˴ у8EӨ՚O1)Z JzfpNE29O>Zsi*.I5|zNoO / $%CwUᒢv -J'@$E%A?F%n[D{jGj~ΐJ/2޾Qק>/0ܯ3ܯ3V% 弄)I.ޞ 7-7*/Ae{ V~1rSo1}-œ^36%|'pƼd~'Q~+\hQ4j%د|| n9<4 Lw28[/<s;/\tMolq묔=gbyB[>MQ,u=8zⴘ|g_hۇ阜,]ɒc_׹9&TGsMu>HqZ̷̃(7`QIBݻzxGF'S4 }?0չ_=mfuNL? dWN6Bui?Z =ʌ0@9dx܂FlzΉd[N^HyM{Tar(Ek6waޫTO:dn5OZ i)V)|]?rsNukz}c~z͹'J~ =15YIO =A{`2mDWe`rscA${ 65{׃ Gٛsܖgޝmz#ǹBj'  ҽzf)AlzbtQq鍸=C~\ xӸ9Coaӣb81LcqibI0O[tskә4}dEyQyʽ?6ssN6$#7we68lz)R N6~R4YN6y3\g*qk*R<-te$iĉ~#7xT>zMG=J?@|$cr.̘|:lڻ;H>c;ٴw>deɘkۣz NdLVwgǪzV"Z? <`rґD=>3xDɍ8ʞ##Õy+qw51YKd'551ZY/ Gm񥼤) QͯLS6ʼӝz=2l1]d'qӜN5>_a=ssqԒ7ZRxQknV:p#=WR=O*3uv9+u:uNݭi;RwG5wjgޢܬFqڧ1T9tʸ)^^ܬ[->->3No5Swmz79oSy~AT3T޿Nq)T :>NYHwq鵖tO%czN߸=Nݭ8RwG ^yx׃XUkN<'^Anp{_m{Or#?}ϙۻDk?WC2r摪u5dXIz#3e)ef1a9dx8| ˥?_9npl'avܮIf=pWWTK[oz}=R__mk$"LE@x Exs~?}u7_`1 n CQoa}"mu^2+G90kz5)d79|~-45 rX_0N8<o9E]uuŻBDV{ X-ؔ7 ҙ9Z%dA[gљ9rZ?;$-6B?EN9k*@1ˮ {꬀qx?vgOv^^d)^bw,ĕ_$ףl8E;>q)iܨk&>ykwZ(yIS3AJ~ yQk됴09uxFg{ N߼}m6.:X{(#QRsר;|¶1Qr7sq8uv$%9=& L|y&@/09zQ9$&ϼAQˎ&JԲ྆m`r@xd'nToeWySAV%9߉u9wo-^9}X@^c|[DR?tw q.iCܤ>[<ĭ}b1Q;d|K>A%U>p3.^' ba:hGN`_pg3p2@5j#qnYےx'Glr[sK>Az,8l|fk|%,J?;|ܽy rxy7@oty="iw6^TYNZުn<: Ⅽr)P|4~Q.j&~ pYq/Uy_UU 0[J~ƺN{_yS#4垓īc>&+hD\H1I 9{ I^Qf͸FbYUE>`~NA*WGUyof8|[}USo6Le;%Z$Z $MPՑxQap1y %ϖ -3ɚ$[5 lKU-&3dL%Ǎ`Vir }&~ W'c%vfS#¥/r$%/Yq[[#R&&C4&4}F{/ۿ봖d)*%W.bS\zF~SlUʚ:l0U_B!$u`*d6r#m0A$ e㾑*l|INn!KJOhU.ZdQ/t~Ixr$odH*Y|jlIuN!g8% ׄGTT`Y%Fti ]Q+Aa2`%qNjJC?d-?Fx:>@ o+(xFyzy|bYϨuIη\oRSUE_]tk<~#o?^Բ?65B$|#Ů߈5O߷}/l>z7!{| Xz`„6 @dJ;{KhQ~hkK_쇥 nORӽ$Ux-IZ,:^@~.s KAg$,-{ܜ>/ _I x ?yd'9%gqZXmV2^ڬ&$RT-1$^I֐2tXɘ\/ud-QׇV,aBl;-Y+?@+ 'ŲsFAb]z\$6H.%-~;XַMQ%; ek4=;"UQ^@y^Gۦ(/ v{w%n%_?5|/ UXD; w{wqg tNp(a‘#{ hx{( HOŠf(Iu=p;|K!*jmN淇 Az9D[j3$F{ZW$5iK{xV pDSQ`U+N K o#.5qф'&UƪM֤HiM֥|ECQ*mH[@>PEQe'YҘk Ѷ[hO)?1:@A1z+)ʣkيrvED7ܳo E?t?!WCg)(HC_R~?%>Rnзߑ\EQM SQN@v3 @F;ad'f8n:v0_@Rh۔o0&hUozˍdQu"XI4a%-]q: ZXLECL^t`ǑgZ6y6o 1ozK$䨒=!Kd!(HLS4${3.e/isK[^& fada,0V5 cU^ciQs@BV5 cu _#=s_?hKq* oik)sa%q m|K YZT# ج اoiHg=7iaRt7 ]ԭ{6:E!{ZȞRl-Of|$nW.a!{+clD6瞊qRMsl" Hѻr@+&vl" CeAܢ(x`Gnҥ [Æ]Ym,/PPC!r-0rhC\ԣE sPBhKWx RBWx :枊{ZV9d9NGݮäK2ln-ɀPL#D]f0C 6Ed3PMd(&E)N<ֈ6UQNCيɠ.Ǽä8d'ʩɠk9 ѭ ǀ,=>G){(hZ2P*3J5~D#]棞a: %2t҅XSRϰ([ :瞊ŀyAE/ݪsU<յLX *VtUB&CʴTuRtIS `[{IiLAզNK%(1QfMA69C!ް@S`3I*$)&JKt\;Lg{ 35a (H=󞷌VUQa(mKҙIWb*.($]o~ҙ$`>HYMҥ7M*#m jDuIyOCg 7TTIg w ֳ㧉2SDaIѕdy+d*jT"$Y 5EU %$}1 2#eCY6V;"b=ApΦ&OE]a,>S1Vٮ0üg>6ő[i T:JKJNEL8e [aS٩WR0vK{dZy)w𓙩(Tf*c[?tA܋HXq$U1^ y$y8&J K!g/={)95K5[T;Rj*MF$T{?^MD5TTK,"0Qm;2>IN Z#~C. T4ͥ% o&ƃUiQX;Q<$Q"I&/JqA\eqj@ le{,%oϢnQKAB)hDd+{-Z^\Ha$>z~<^*Z'@c?XSrg:R(QnQPtivQSlmue'2'`1.pCܢz. ]skQЉVPtA"TwP hxX"?3*es qzClD{\ +vNhM\ۏ${"~6-} sNxo Z/E 5hKw ȤAW=@d蝼an! r KSO><ڣYn$g4!ﭜdл/Nb_LYQ4aB*c9A켕 OGܢ2 K`6d+hL,SCřgÍy4}3p|P *I(O"B>菏rM=]| u]bn]j܅gHv]sn츰Xe(w֑2OTA#DؒF 9 bnCrZI[ĝ@b/Erg+bUrXa0&L!p.al>w8`F%OisKgf(*vھy#eW>\ϻ* N"v>r?A췣Ih}~Xuf@71$:.h$fcRs췃 U꼃C;}A3ɤؓgYKԥ^,Wv9LEäITυcž>O1$i@W8ڢ*%w8>ʾ~uH?x% uJ:׀ľlr%Xǐ6>Tj*z1e$vT3#4+$l)&LA]B`I$ ƭzRE@gU 8;d ; N {;IJQ d)jŇR|=lEٞgg٥ dvk7RN. KQ͂V(!y{(ʎ]Qv,vQ- dرІp,¢мT ]_@\&8'\6$.ҏ+nҏ!wQ;N?j֛~ԊtGH~ԘskxîAr}zvE NWRN Iw“;1)5t0[Pc)>½Ty@b\<d+*\3{rPg5v^ $vSpʶ u& u&.1HPg)MX܅ۀ[qH;Ax8wI/9ȿ令 &ƀ*KzΨR La0-g*dH39h5VTx`ṋeR3i15-f2m )[ դH3o1J3Ւ d' י]ʷt42$1Hl31sJlEQYr UELƀǬC \F Y>¦UHGYUʏtUgtr :r P\{2p5HY̍ YKtLOY[2+*ϨFA(oJyi}#bc>ӲR6t!WZʞ|)WT`QG@\=UZ @А0; d{} @@l hHw㼏&wTr샹1 DflS[7>m bي 8`h9: E.N d*d7hI;.6N&]װ (.Cװ ^] xkiʖgAT?ve)zHһE-ήeصJ2eؕ% >.?j=v?=N?%C9Th }-&;n0vfOCiTi(# >PZ# Gφ$[Q.حIE^u ?h4Ʊ# a(mHl6y$ E1APڒ3 H|D;$釔i1xe KQ.؝M8dMTb4'6ޤ#͢{B]ޥJCʯVtDӗ_QXYwV.OxąWo$a1H# 3϶W$X3N b4DE{hQ -4a0Ȑ$e@$#$> z0+&Zn9'MN, .~{Ԃf $&LN {dőI:;if"6Ѯzp?$zx3E{jAO a-I8aI1!k::zM`'I86dI:صC M& `޽53okJ g# XKM[:bp|)ߢjd6^mGb3$akiI|O`Ώc3VRc0߅$*rrf`QͼSʏ Og0́DQÞAAsH/Rn{3HȋT)?"$T~Ezݿ (7 ⍆d02X}x)B"KO[ȋlI>m!$|B & R  %_.xS/PH˦B%Sy˦R0TLd(J!/%,ET^dHmS!ۅ/2%v!ŋ,]HA2UZI"S!Y=Q<v5ՄG vJ$SQ*x&^I,<0DB2%GyfQH ;rOk9ho(1sie@Id+JR0~+J"M; :P^Y a<' C—F`HSj$^dIfQ9\ҽY-٫}<"{C0 i(nد7&-Z$E$o IzPo{741 ohSږVBИK_bK rp _xd)*@xS`%=WIxAoxEx Nf^*H 4$@U@ 4-}K  ?ECQ3`R~:yE!+P ^J"p/XrILo̭Aah *3ӌ!gZN8]Aƒ+' '$^dK*2C/I E7L,L2)}["W p?;c2 c)-z(>tN 0K֕d(*FXwbmr\ V7WT)$fIQ-RJEv#s€X( l[RT"KŽ`*HuvM:kBړ(3t(fڋ$SQP5X HVr*;iK4t})bK`|rJOIp\K[2az*{:OzHd:"ɲ%I_ 5&G5L<[G!)똽FћkDH(zsȋ,NC٩d# ;σU腇RRS95 ohTvKdI(5ut[ܩ4&tRdf*S[נL5;ElyNNflf"ul@igaf*%#,,ʭc.O#.– KT~XchnG2RےP^v{J=NT\\_lYPba&zrV"]x 0{K`/`36ΪTd[k ';a\dΪT\eI-0TH} ƼJI2eklG*ښri@r$%VƔTZښRi' 'kLIe|~EMk쇪CIǚRRq(L 0v$KAcP+!I^8 am]hhck @%7/tTd$rwDEJ7tT$CQe&K%^5 ne؅;RqttN֙$ <>h4ߓP⺜9x #lΓ@ɨa|8&mY˰||x5+u.)S6CErIB^D3>,Eqq%I<0lId $a[$lk* Nd&*8v}TT-N+}^Fz/LT$ lj*lMm (Gd̀إ[ Lj) kSw2PQsL4."ZMtŖ LIJQ-̀$}Q-r~ Pk04Tܭn3Ŏ !" >6AV*Z$} Lh+(6tȩImg䮠0ݥtQPV *j[V(O #S4͖ aD[93s-їӓ,>zxrMW_9'w>VQd" C19 "%b+dʽÊ@6s)'CA([&Ez@}`k(@u`j2pt&Cld(փEQ({&WE{@l> =|(2dHX<,]^df9+&P)R ; ' Ӏh07$zsNed^i08p^\xT09$SQ.Kx V5|(@ CQN.vN >Lk ^qWfԽԨ`x(l0>(f2 'kӓ){ dk@({`x {MUj5uJ*#Nn RQCQ8Ukhe.|**4eخ$=-HxNS)$]Q>eӅOWxxbiC0X;nmOM[{4TnӔ!#RTMW)/i'RaQSQ*,"ӕEÓLJ;M4 4I.|**,+G&ʐa$}urBTZLC.8b2e_.-"?C)™d)(g(z?C2(Uk0NTqokN¥RNэ65iSr~{4eaZ3G/ < Vaz(tEQMeXs% jƀܕd)*jG?HT):$6v ld*JGCNp)?f*H"؊^J<ո-+Y!6]¸V%kk)G+IWTxR)' SQr.5d@]qK^]޵Ց][YwR$yM7:meJ#,nuʓ$[Qf[MРnud%]aRRlZG*_Ͷ2ņuʛI p$=T ӕ| GiWx(;V KLOEd(JL|= |يar/OST$CQv4X-$KQv4XaRE%IW f,Sj'*?0e928,IlieK#, q 5/Dyf([&-- d)ʖQXV HMB}1QtUEZ3, ϰ4Z.,Ey,EOoarWLh7]r(TH ( ÜeJ\E⨂9MQ5ZI8I( àed_Keä(V- Ö)KôeA%qZ4 ;_U)Jt|nd+JuSli|(ʖ\d7ZժSYT- C_'( Kl֘tyC4PTm@TIEJ/ATI$|@d@NQ8*E`6 aiImlE5&5 #uaU'@TmE2)C)KZZg) j*_z%-W)_Ґ\ޤ|IK]K_>,eY$Q5-/)_5-o)_sOIv(o5 lҽ Xؚ-d≂MT>7g_-=l0$\U0~+J]E-SuJv$ig9 agJvt ?p).gR>;lE5kJ\0rPTb)HR~-6l+)?p.vO)v+l)v1d*J_CTEv_ig{H Sʯ4=NK48]t0CQ68*mp|*Hb$SA*+\1({07E0t#LZAq Av({0Cx$|N ۼ/dq<eSQ+csU;ٵa~ij<f|/ ̓ː/ޒ,0}x|(ʎ[>1`rAT%7%w يbP=ӗOEA^{;=㗫 KQ@ `nI$]QvELb>e1/`3$T>bn,)_ALk"T] |-h [QIbObj XϘ|[0[*#?u1+Ήa̧ 2e8($ZO| C B{8'f2P3 PΉEQ#0=Vߢ5)L[=ʹu)Lqڠ0¶ amIږiI$;TTk?H3LB}ST[(d-z#W ?^{#K|Dgmgd}Jڧ8Q kKRDڂ!UA.kx{%WaWPN;t鴣H畾:t~iG+vti4n?Aiǔ"L`rI&0rIUtyHN;O~#fg;mvVɾfq@.̣Nwg;]vve /w1~TAF{fAz9w'{5Nb\T .梒w{5.&>/jL0a>Tjq=!|c@\`z ]wSÃ0$|xSH>>3' 6SI˜wgf> cM4${̨-\;يr"0wEpSEp ,^ҩ7k6'՚o0%{`֍tnx(d;H;+8Jjލ˝]C!G{'C1.eJnIV%crd+ʎ]eGCQvtq>ɼd*xHAdL*nCAvx ]1U(]=.˵=\]`LIA>; c2 Tcr$w[>e{crd*qUQ.يUJ1`ܲlFԓ@a},=^a˝Vʇl c1l ;9-SK \qMA.ļCAm>÷1om>ø1oYOKl4-7٥1\8PmOE٦A]Ӗ)zL&Y r(-C\0Z` v0l Q7l-F-$][xklC mCpW豮P\0e_viR{Cjf eLJ 8 Ur^%Nx1vfӀh|e1 6WG wΔ'cbg pŮĶp aI4 a؉#!f v_ ."p )f*Wd9RT.`LF n1$Li}dg@Ɩ%v1~d9.,LeJV{"KTHxݬMfπTluKV77b}sJ7i~fiSA.3< C(<ي yAxb Zԅ"[N/JiRxȃ( )pSY r*&)u]ɇ\ L`'= rRAS]xOEf@5w=]sH撉:3z#Ckx3)yw*F(SqP&̖u-=˕0+Pv{>PaO{*&'} {*z&G,e18BǸ:-Pa ]AJ|IY㡍{}3Da+ [1OR( o ctrWxm&7Sv,Ib18)e {< & [ ٜ170gUR|clEٱ17+ʎ|';<c)1`lrd+[M> lCA6qM.,{8&7AR}@u\?MjD1L?@t.q.&C3I~cSіd\egIy bCQv({;&N^(_fɸa3 dGa^  6V$^z]W,brr]oeCQ{dJ ^[cp2E/6|j~Ŵ+@?x%SzTF "cuL6eGٕd(5л侑!k.hD+@WN ~Kj?PT ]'Ib~X-*0$ "oD1-mLE3){u`h00x$1{˅`xK\2c]K"-0hYןd')=xP]07 Abil@LE0t6L%ɔ=׆{aj-Ejew2:$|a~N CwgP.r3TT,1{[A:p :IVNb+^ ֔2R^ ,$KQ,~'cby[-LEhzl1d'aX cPDVtErn$S Vb N_3p?1 Lk[X L[L9/\k5Di-FL>~ ]Qy(s+ LeDiޒPv?>T S.ҏ 3 Sm{rjyz-\cL$Ja{ciS<$1+R~rJ.1OPKA\=9LE#(uuTFR ڦI ;Se Z$CQYjd).TFj2ɉ0$XSQr8*N|2r VqmeV"{%銲Ox'SQqV.,mÕl {?RMQZLj5. qJ51}2{2Qi$8EaTS$<Al㘰e$ZQrT"H2 m)I#7evOB[te,wLS\ioIߛVT$?ɖ-+~Hޙ&F߻d4Pޕj$wVIZO{wdJk gnMdKk 꽼h4,WuO|StIpiƯ&5l$.GP$]]8Xr= ;5pL2^^k(>ś;r*$A\k h'RaT$^}8FJQ^kolcJ?ed*)(pCiNKk&AErMBo4hTL2^ 堂x%~X[rPQ൅fIb%Q#Q*2%YzxalBzdmPCOXE;W ';WlkTYIzuh߹,"˫:5c1]d,>VP,K93{hju'`ѿ& l%X c)u^rPs0Q*N3[X4N&6po]/g<p^4qV LW6lNuIΏ|:#> x߾NBgAwTM0^|ɤˈeBw^"LVx\Q՟P~_꫿ۺ?p&[6ª_|y׿F{i_~H__kկWzyS}_~;O7{՗~_>/?_k z}ӟ]a8nuaƅFe>eů |ָi2K|<^z՗/z~q[ץ_?k?(Vx@lק'}^fk_/??7{/?ps#/j /C>?}O>?}O>? xaOE_|E;o<_>?}O>?}O>?}/*/xyUO>?}O>?}O> Ksb{ѿ[CA ^[*珽^3^)m8/ſq5ߜ_~X~{7֗MVo:-ݏ_}z[?^֋r>Jʏ?}>k/}÷|oC =S#^G˿קEݾǗ_~k]|?E0 txwq4G;+>g|{ORoNt`J?GTn|+Y_8zIͩoy88sCEV1}lΎ?Z@&@Ss}Mlۉ864q,woko_~oC*4lfΥ_aӨOK^\_~~հa__~O{n/n!_fsw {E-n_ˈg_~׿÷þHFōN*~ӓ^0W?ws͉N=)Ma? ?}? !~mЮ._~ޡs[+u~o'Zجmxsw?|{Xׇ׻kV|t  fnendstream endobj 170 0 obj << /Filter /FlateDecode /Length 3858 >> stream xn]- [ Bg E c}@+ )2$G)o9sٝ%0`/wgΜ9454؜5ψ};,6/ ajJ\^-dE0C&Zi=ܜ}[*jA/hcmwsO1EFWh))^Ïmkd[Ku$ZW|wwR!(ҀZ(m&.mui @W;k=qģj ®vEj8r T4LKw :F~}\՚p`”)a x&P VY]Rmxc &L"|Ē +Ah˔ sީeq&׌LÙw:b=\+^Vh5:$55tv&*p}ml͢C^@XB;7 T 7:¤y|ɵ61QC(x'rV xZ{5!0`,N;",ə ԩh̲te1]J=Nl @H΀vo| m#I"ZTZj 7nUy난,GlN/f\l- =_D٥@h̓T#'j=^Kډgh!a!?st9 BIrX}b,ITW[tSɱqy5M6n׌Of<8.Gar-&\11XNm afT,cYH{1kp,c&%$O9VL$y֔=^S:AfqYpD}5@3g% ”p&8i (;dx$Wfs2[Wۻjvqc7g[j=/X5Y ίϪL?;؆!y@&ޮ{;W/_^+m=nZׇIW?z׫]Z 2+|׿Z~W@;@g^wE^\Ml.'``y[p-~i١Ma'Gpv.xY!·P'P|uwEG'Y.OO瑈na- ǒX\Uڮ7mٴ{YΏ^."ڷ@@JUݺyk;̈́ߛ]w(:Wz}ߣuѣ9En #`isޜbbHCψ^t"A9拶yxMN 9bёT% u8E&Yv JOV+u*Q᜼ ' Qoد!&y9e73t53DWwKy;dyDo>b2}z_޸ :aGȮE=UG:ָj_G1:W7`ƴx,aoCƊ'$D*(lΌsFۮKհVsB YKN+jppD*vAEaܖ.f;k+v&P2 i ;f)*Yff~$M P&ISӈMFDkvo2Oyd!2C!ۏ@RRti1Sb^kBCUItÚZCy,D\xbWM(D;j!@ v#A 4X- ^)vS\X5_\R pcE?.|Ts,vƄd)Ne 甏e1 g4*^S.'rUDML=K"|#ZDE5.LEb{6 m-%1 dL=^@BkeQ𴔉XAFu_ت``c Z5;VuYrL'A"Mtwrܶ~ -a>qlfaCϑ#muhhԳ$ `_VJzAt}C]bS^:k#龜|t.DEfOQxwEN5zIDcyCl0kػdr?26wx"" qCKG̸PS^x뼋Գ\KvD'~ӫi0h,er=tdH9I{]oq-:yC\`m\?xcQ6'N.MʳCF tONF"䃴LXm_-ADuZX9F\)- U &?B#m|du"0n,+Tjxۭ* xK/21("i* nꦤH_r62Lf#8 }p }Sf)භc|&ݍ!V--)!p0GH#5lXԕEuQĦ*&erV@FU C'.RLlv?yPY.!~]|a#} -"st>t:(Wk1^cх~[לaGL0<4YԄ)췽Q*`% `=LOcIl P9yR=/i_/֥u7y>xY"$ ė}bwޗZ <6rr9C +ȟ !Rul&u{px cCN*q?P2_lL+S nm}wm\02o 'JA:d:T?n}LS\!NG(o&<8CB'icg`4qMv ːI83ܠDP]; IȜx;d$[V$uOFeU[wtq@dOSݩ"wxjY"bA=Gyel*`l 8Eyp~+<:9_%N+v> ]0q5HrVO 5˫=cR|/rl9SFt,*γ3KRr-!p Hk9?_8endstream endobj 171 0 obj << /Filter /FlateDecode /Length 704 >> stream xTMO1+3FP!MBHP}ΆDjHYxyZ걂vUt8TW@%P DtJ"8P>E1XT7n@BhRIc^֍M4M zA~#Lrӆ0Ϗ6 Rԁ{1}I%|YrL1!EPBByJXCu#U'{:&bL`L-I((?REc6E~SҲsi5u@@ы֦j1:c@#2 =j4m̖S%rlG!d;>5A|D9Z5;Fcl=[U0P-QD>!/-q'NL=-iP]Vև1F2^"Δfl,0B'l@We7dl/d?=d]gx@5imllJS( ^9[  т+^Fu7)jendstream endobj 172 0 obj << /Filter /FlateDecode /Length 10945 >> stream x}[%Ǒ{?{Pk`X CsIn w㋈*RsIY Ds;q*oqϨ?=zsWŤImbOzdC0TON*_j>~<*\ӛJ,bx ٟb*.dBXR;%YBqZ`kzJ#]4]B<%kgF<1ihP@j<9/qKΥK5 !M93O/ò?rL䍹T~'R-}}t74K}7h/;`H:6r ̏1]ghҏ-#$9jh 2G `5$$^*7MŤ@S&t@N^q@4Zui =*ܟBNsxPZhy֒E\L y4/ω8E㑻DL{D,#b6* ,Ď >$anPm'j1rEA;/hOzB448qYyT {k~NuX%k+J UBL x$QoEGjA*?7QۙCSͿȠ5] , /~O+B:,i|̡ј[}f՘9H}ׁH}YZba#DePl UG*[YI-T 2PEb&F TDXeB|D*sfֲ8?ޜI -z{*`P+tzgs}L{}c3R'7~C񒖶$"$MGH'y*ӗ;jƩ 0ҐU!mcЫHѠgkP xxd>rn9XԵ1VE3:zuetHٵH c-Z>$_ājnb]VD@Ӯ(?O'm?Oi%~>,]?OU&~>6wGpFc>syhNjp%^h硍GDxun%}GHԸQ9aAMe?WKѤ [6s$!؏.^D a(~4O #Ĉ/ԥM#A+J\N*MHSM(n>C?G4I`7l" e ȅʾT wQ&GQFE((PD6+Ecޙ$C˹$IdIN?In.Ď"]gH2dwr] 2(.4q%ĨbWrNzcQ_c]S"V\ 2l]I(MA"M}e)GOB\lqbO+,4!l81_ 12sqaO6!nB d-Ğ~4(ÞG(Nja qa&"uǑ ~a'gy Ez"%c̏K˽4G[ W"Olz"Ѭ(h" 4<$]&7_Pe>~^UUuML]haz#\^ICk<ѽf}T`1?ÈmOH*_ƒ]GkH+3`-ȑ)92a0Hؕ?ΐ)B}PTb:?&ȎH4#tW #;& wM&Z:& -옼dcGx4o]c$F"Gzd>#A#kn@Kƌi]%05fbd!!V3Y3#י;ݟl"6FÑ0+_OApDr0Iqe8t_smHp/b-ٜE [.;0h8TZʣUtZlQn6JY#,*sXEY,!A2ΣǫT'=:J5‡[FQJ3֝hug1Xm;uokhxAHoW6{pR넋'B-uo_[toYTtwQz% wo*cgW 8%cE%.F(#-Ծ#5#/55{~g[ov⊅jA 2bBJ)b@UGVJP-B)~9PS;SKBQ(` x}C|;cR^ l[\Rue="H( ȨM8H2Z҆x~78qLH2(%<~!NFM\ 2/5|4p#j)|zk좘zt-bq$ot^mi㚩"Z#{OUYc[vQʯdwR޸HE" A!R(siL^ l)l20փa!L0OP%dT+T8/LLŹ%b"69ME^ PfrSI-=~JGD1?YfQ*H_5DFND R)jW%(P5,N* Ur"D #-g\Ê(bY k a*&XjKGa) :"T E4L?յb3*4D6 ,%8Y0UǢ t "T C= +P5 Y7mj)9ֱnmR Hϱ *("T s)?{ "AI^8/%+!VD#aI@0.P5T rWEa#:fEJ1vg6{HVEx)1m)WJ9iPd?wXv_IQ* Aɒ}`xf*o Bհ3@"%K̸`4_Baj8|R5@r "'wDj -rP5 O*ozT wǞ\H_NjP5 Lބ"L1B ޡh ꘂ-5,q KI*OXD?D2KhEa=^S:cfbMnؽtv74{6 MNl_7u'46 M^h `Bmnؽtv74{6 M^h `Bmnםtv/4{6 M^h `wbM<:}v/4;&~ M^h `BmM7nh `BmnؽtĦu'4{&~ M^h `BmnؽtnbMnؽtv/4{6DϢםtv'6į{6 M^h `Bmntng^h `Bmnؽtv/6į{6݉M7^h `Bmntv/4;&~ M^h `wBmnؽtĦu/4{6 MNh `wCmnؽtv>^Bmn!4u۬몃{ƝbN4ﶅTCd_G#iviD|7aU6 h/:*SY̢!#9,FX"Ȋ şvEȊ \}_+ @H},tP6׭24hR(VZH"a=!˧w9-g4yuy' KY}d߿PgY?{p26 T8?{hYQƆ:2,FcCroYY;*"H:*"H:*"H:*"HZӣ"H:*"H:*U{T$IGEQtT$zER4f,0WZ͆-UGRI͟8;ځ##U|@ՐXL_ u@Lj@'8`7TM7>G>> G۸~=n pȖ*' _jȊ*DUlW<[3g2'eRhi7>xkTqC8!W}dY14oY}vNCɸ./OttY>Yh6֊~ ? Ck<{ 4!WPKSDL@ 3SW>O|^ Gy d)Bn5/_@gp֐0,fA'wL'G{50$(_Ut?yx܄:eĸzgIY5yEn(%^(0bls_ k7 2T0e<PH)\X4d }CXN뜡ȗC26/ 1>̰'wp8gxIl>F)0'0 q8xfI>:1 7vCf ^nB`k- юNSv0Ox /)^RÞuq r0N8фfԑw8' B/=LąfJy fwli< !a_߈$BUIapG1`OfwaTPcW#PӸ(Јq&=w*v7L#x8rMz]za[X❻)1ydpKr3GdF` V(ha:rЂ|Y$.|Ɍ5AVXY^+S選E $p+Ԕ(B\2#2MJuR3)\||8ab WIJQ$=(S$bTc%R 3]U3'מaKjfR eȈ)s32*ΐeR$oq`9LSu$O鄫xx!\$6 ɋ=[dpsM\E;e' /i z)Lfn_k5 :`k2V{>kˏ}rJHGF n)$\g\qo{8R],7{HNzkXo1M.UJZ倂$rg#l d8.Ɉz3|ϊȽ(Nyr}gNbKRDFʴ-*z +?=z\d Yۂ z4h$Cop^FQ[7},Vm2F7;c{1Qur%qK!1 ".bUbk-vuR ؕ/eD.&_[Jz%)ady. C 3޿z0rT4;4xm:g~h9Hg ҸJ텫h\cuahEgIi-x0>oLM2@5|ŵp:T+԰daPy,mi S<9dk +|,E \LPj,p.!|)#\Gӫq|(HF3} iUY9vx)jv<^F=y.e[hi>L2!IsϑK]a8%ޢYH0qܝwœGHtAq:R(.MZTI/Ž r#73"?EzGKDYAVJ&6B\&vM)~ OY !Ì 4UaNYdlErE-^݄d :9ᷛBf oN{!#.qግi5<;(Eenji $abwqʊcgΩ7'(ۜQ\pg<EtRGL<3vxؒJUH L' #-NL>NqP;},L(A K0%@&6طN8u@7`u>GLPgp Bf1 2'Ik⧬^\FLKʼ3Q]yOGH/%4 \Ka{ƮTN y_HՐ U/Ș.T 2}nj@QwdDzʎT=V湎ieI|codqF\}ug9<2-H0TIdYQ@kG*EFjlf3'mIQsJ)6ł,lې.`<]\ X '#;|7LoIeKypk8=MIT}tpȓL'{c;n3N0Co*';[o(:bX(8(:>IHbX(:bX(:>mbX8(:bxQ,uKRGQ,uKRGQ,uKZ,%[x /gX/T"P-9>8[>y!S{F+s{xO矿7??]SkMYv1L I?_w78+ d8.Bls!DjZl76,=H-OJoPUߐHK0|~#ux~;w^PeC֛wס@ǝ_QS+՝xxtwt=?=^zӍ=Z ?ѭjI]~w?߾7t>qS֟{[^h,EoPtGU3Oiv"Z6۷4nQRA]#KvK&wW//q5&YJcԯ>KWvoXǬR?L:_O+^}<>*4fӻ^a΀? =y ,z|/"P>҄2| bM>c_'ܟT]Jdwuw޼/ooЈ#'BΏצP{:?޵B}UW+=ꥶڸ=cI‰4wi=ʒ6թ/L]3&?L҃>d^uw~;wQn?SbM[;v.}xjCOf?޽e*"}bu;$yǩ:IOG"0ysoʗ.Azakҍ=T'oX~>khgm.$khO784[e/4lendstream endobj 173 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1847 >> stream xkL[Ə16o M:K#ˎaUfj]*[nMZA\/㿯866l( vDI|Y6KikMI+r=?y9Tj pЮ7r{H\M284u8#*yHdM%e**kQ[TK|0EPRר77'LST*5DrSr_I]/MIDDɗ9WXpZh $hQWtվsBzQa IWMJPPx}i2ּTdq{}H{Hp}T>fQVTlPפ5WkAGGvtA@6Age ¤8'WiK#kH:Dۖ\?lDpDN9,v(&$uGrRǿxWM򂠒$ >!@,*>lk._,L}|^"ڵPMB9-Q lfKk@W/(2.1:^s~_XH~M[|}VKm.W-`rt~`v`-h2 P{bs˻c; 7־#ZOU(!Fb6Fx_؉ FK A7Z(}l^";Qi#ӹV(F\TZjA y ;Q@W>?oƢbtd4Lg]ފv탱PxУFz_%W!a ?;`GVگ5JmtprTG8^MiU覂"@&w vgWx{qdR,glLHYFƟSFE.t+Ə<{d$xڻ\t_;FfT+QW˧YW3<3i }*Yoc"6-Du>Kz.]oY);_JړXt5Qɭnd[Rfˎ7,cew%Yӏ]H mx%^<4=OTUhD|!8ĩ'sW$e#E? H҆cgH&)ˆ驲QQPb4YZIH E9_FWt|S WK14/'ϭ2?2&xb$98 ~gW}s+0fK;iGQ }|u!z\4閣`wDC ^UmS]m+^ҁigJ¿MV,9nS5JO7K#> stream x}M\9r~E^֢~yl<`hx!3nZ=9佼Y)YmFCYd0<]OrCq'ٟc:ݟ]!Ο;/YN9zIl14/7ۻop)hLK3F٘k^L(;Sh_NLeg/u8 \y6tlL'Nũӻp7T/97O?۝͓?GtǧKû?s?pi&z~x~Χ.$T8RB*lrrImF9p.!\rjSfыk *#%]*F*ۨ>b| %Uᚦ;KJ \\EX-8gKՊ$q7><>w󫷿=`8T/׿znr^~zj ɺ;Lŵjۈ?AXmR > >?vї7ө8.i/פ^ goX 4mh0%= =y Bʱ*EVL2`rɗ w_"(37.,KX(Iue zwT܏ +;n=yAƨۑ[w8/@4b8K d&8h.t _;ؑ0+4W4Y2xal5h]!+^8baR, ތ6(P[` dإZZ14={ ,iĂiyѠ@|V4 Өz)j}FpS 4a[KQ?ag…kU.:֍Rc_aRk U;LjQ-5Ʈu/5+;`ᖏY#¾.X4<3R+ixGaLIܦ9c]2 "J$ۣ.JT(l :P"5آ+OJT0yAh|gӅE$XI)oE] J3U`),F`Oɚ/U2 6ZV103 ۣEw/Fs)꺺ؐO7S :rI%V>C9ᆱ@hӬufpp]W!8-ݵB%DI'G$a`7@Wr00D?&׈!vD  dUU#Zrh0+Tu TMDSbJF .$d5g`BkЮfyh/xiCH[uZݥÁWx3z0o|9d%XFjpklguPz;ec~/3FY(L<egHCZ!D񑑀ȫY#,Wa;E#-,)uО06D/SfZtb&NFvO_x6ű>f/xp.(_2Vxc,i/}@qßyOޞ޼}ԣ} ux^o{PkQΏѳq6gy3ޠ O;~<_xWqx%}# 0d!2<DWMA @OP? !|(dȏ H1(3d(K ,5(׀LOcG&A =21u#Ӡ\Wo=|D =:Dx(I Z9@&W N\2s%< (W5뙀/l=6¡i0>COv8A$O)󂹹L_>4a%Q XɓCIDM"͠w$xF%C~5.!n#|/DI&OwptH m6QZP$A\eq -mefAZ^ܯA:Ea؛8"J+ꙆM9h#p&ez8wydPf)2 +4?nPf&^~fꔙ43y$]Lјw>r':G> n=IMg'xc&6ѱ#];amwEX`,Pܕ.KO-f&l ?=c+h&]*>=gFOq3,j)<, h0>UU`,G!O)^B 5jċ>1:ԪRq6Ft0cT`:{ʣ=Ea -{8U;3BF"W QMF %fk3 "2&{L԰o$eW mnрD0~)hl$'=];vp]?}4> zIJԠYa0OqZ f 3v&DfI1})O)UG?W8b&u4,fhDe׋LѽqY&u cKl'W`OT2FǐBw9sySlƭOٗ`ATi>6G(N'{5%(؀(FԊ )̕H "ÅmX#1 L-ԣsRPBUڶf0 [ ΂բQP2AH=kLrb $ 1[P&`#@%+j$U.Y(C#VCkF<Z*f6&]5R@WX0+Oӌ[]9*6)GQ:+GYzt#:!nv(4LuQX"QҰrw#u(Ge]9 ʺrm+GPRߔL94+Gؼd+GMWg=mR'u(j;iGPr_V]; 7'¥QOaRT;WWu(+Ga$d\03ʗ Et<4/fP?׽o~'++zη==zTmݭ}^uGDk6kdefVވ:Nϙ:~<h5O2}"1,~Dfc"3Mt, }a\)d !izpopy?x.sVe<%Q5[5[wP,Oknb3O x(;W`T;č2qj3?smK̵Q&.$svuH\TrLϩJJXkZRIOT%>0nBib,@Sf5(.UyW5SES &Qڷ^s,[_kWoHޜڵJdz%losM̶HYwRj;<4*ꚖV%cŞGˮEZEVJ;>4`:*LDZ0F;J}AҵmS0  1}dF(-9qE[Q#4R\A\IAf;״7na8^ڠ abvfHޗk'r6HGM/ޯ8eVCҬipڜW`=<1K/l<6nP6+Đ'P*i7E'9% uYb=+fb%L^!zA0ْ zEqE{%4ab?qw+!Z q_1Ї6 ^ 2B{ KojUA,XxAOQ9'ۯm?ڝnTŒzi=2.F-_:#`Ja*2ݬjiegz68 fBp()V8z<0Ik$)brZ(OC¤*:Nu܂}^+A;#7Ȓ-,+e5:΍/m0)6~_Ҡ5+DWN+6foze7S =+5٥ NK3P5e6{[0{@N|FfFM+Fa+\ Y^h ItmKt(6V>ͦNL狧שׁ3.oդJuZ4aNqhK}ڏ_35@y#HN̯-=o7G9o7GS+V g ~T`;j|zNFO>BT{&iͨ )W7ʁ+^aӄZ:{1qMz&̇cz2ǩp}nV 聿j퍞P%uK@ݎ?!ռ?KE{3D$l. DžCy_OWR C\ ׳q׻o4 uSĢ/L^BffmniS>'`dZVA..fMn"ŷ%\gl>“%k2L ][fCP0(WL 3uob֊ :y&I.IC}0% 90w \7Dd=A+kHdWR]XV5֗|=1^*$%4a\ EXWƿK`,X#%s.CkiՑtPJH|,KLju9gWuP  fkP˼!0mmu_ x3+@(gp$f23qY"i_ 3-C䙂U0VѢm\P^^4YAKJ5y (ZͳkD{b#nOXA!%5 Uu`YX [/Hk:oi&qUm"˩]fhM*O~S!ESP \B#yqVk Z7UٛQ$ ?hil+nZ½l28_{+{rR _JNX4me#~(&M.q<τd3gBXQ^N4Q8B{³@3yaiXY~ =mG,<aa?L0_cz"?ʃIʃ]7W%؍.~ceQ CN801:ż? N9p1LF8𰄢F6N9p~Wk/V|x> <gxW#Xv+o36FM6ǴT̟_ߊ)K|7^j^Z <)(;B%njX>|<v5_{"۔2x2d >7} ӎ`P~Ys!9+Z,Yn~ԃe" Ml4ya,j.YQ¸MժNqEE,6'#6B*Vf.FEOe>XUj2/UG5',e\ZB3rf*m|d-J.40)4k|sLf#^/‚,T+KςVK,{ooaenPnKi{ôwZ 1 r2O;knz uP3m:]t9yAq+=AlkI}ì~M2B2Kgɀ7zA.Q B%r]2D+>$#~QRK0LLx: FCFfh.&,̋59`4 U3^Ztd: ҩ64>{4פiXq>:M_6}aڼ+}*/heuVO]g>{qV ^pn6$O%}x?ae!zukvM4}λ.L}0}jjjL0·ct/Ig1{j{NGee3<:5Gʨ|T+czxww1"Ŕc%:噮=WŞ6k#|7J^|S\TUfN9px 3Wz/n|}*=z—³A #}?h!u")Ѡr$*g>qq Md29Z[U.WMf @^Pg%Ӹ?Ǫ^/WSu/FݸqFa pк7 F0 [d`ܹ’Fv.6FMx:)eޠ9Y Z2`2+f,Z 6~Au+Ugy驨!NT+Xʅ؃b? kŀ8DN;KB,(H}M XkW;^kh^Pg-ȋ Z,wF3uG(_lݱsG ,L]p4/qfz8+֟N/17WͤaI*}QQ#7YO7H֓ޖ-oZ:^y~Wcݻ4Kc7o7{.P^%E¸z"l.zdlbhĥ83Vx29=7f񵠷M\'zjȘN> stream xW[c5 ~G"N򀐐@xԷv[rع:e$XU급|?;)LuծYo/Ӂz-ftIe"tc|18 ʠşv(("Ht**PQgbp$rA-36FkImć=HQ܀diT!4Tn ^Ccpe+~Al Ŋ{cwc:FFYzoK([jh5V!6]0]A7Д|`Gbtq.1hi7礭0 .\%A)8+ljTH րZFlGgx}!ք <̵':EJ#fc;#s9IguRڹ'\g(*ayKgx%n tD se֗kع"?2ymv:kŊ0Y^)>`{(k@(&_1cgK7*1&"`oHoDd* H͐/otisq:ƛ:Cj%k^ [+a PH4Vjei-> /W [ 1 3 1 ] /Info 3 0 R /Root 2 0 R /Size 177 /ID [<12a05f43350e6ba4ef7c0f681f845a53>] >> stream xcb&F~0 $8J? 7(_P#3(0b+w R4@$*?AZ  b3T"&HY 6tbǀHfN"9&d",kZ] endstream endobj startxref 207564 %%EOF plotmo/inst/doc/index.html0000644000176200001440000000107513300570625015307 0ustar liggesusers plotmo

Documents for the plotmo package

plotmo

Plotting regression surfaces with plotmo

plotres

Plotting model residuals with plotres

Guidelines for S3 Regression Models

Guidelines for S3 Regression Models    How to build S3 regression models that are compatible with plotmo and similar functions. plotmo/inst/slowtests/0000755000176200001440000000000014664455533014627 5ustar liggesusersplotmo/inst/slowtests/test.non.earth.bat0000755000176200001440000000162014655214117020162 0ustar liggesusers@rem test.non.earth.bat: test plotmo on non-earth models @rem Stephen Milborrow, Basley KwaZulu-Natal Mar 2011 @echo test.non.earth.bat @"C:\PROGRA~1\R\R-4.4.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/modguide.model1.R0000644000176200001440000000447613725307662017736 0ustar liggesusers# modguide.model1.R: # # linmod code from Friedrich Leisch "Creating R Packages: A Tutorial" linmodEst <- function(x, y) { ## compute QR-decomposition of x qx <- qr(x) ## compute (x'x)^(-1) x'y coef <- solve.qr(qx, y) ## degrees of freedom and standard deviation of residuals df <- nrow(x)-ncol(x) sigma2 <- sum((y - x%*%coef)^2)/df ## compute sigma^2 * (x'x)^-1 vcov <- sigma2 * chol2inv(qx$qr) colnames(vcov) <- rownames(vcov) <- colnames(x) list(coefficients = coef, vcov = vcov, sigma = sqrt(sigma2), df = df) } print.linmod <- function(x, ...) { cat("Call:\n") print(x$call) cat("\nCoefficients:\n") print(x$coefficients) } summary.linmod <- function(object, ...) { se <- sqrt(diag(object$vcov)) tval <- coef(object) / se TAB <- cbind(Estimate = coef(object), StdErr = se, t.value = tval, p.value = 2*pt(-abs(tval), df=object$df)) res <- list(call=object$call, coefficients=TAB) class(res) <- "summary.linmod" res } print.summary.linmod <- function(x, ...) { cat("Call:\n") print(x$call) cat("\n") printCoefmat(x$coefficients, P.value=TRUE, has.Pvalue=TRUE) } linmod <- function(x, ...) UseMethod("linmod") linmod.default <- function(x, y, ...) { x <- as.matrix(x) y <- as.numeric(y) est <- linmodEst(x, y) est$fitted.values <- as.vector(x %*% est$coefficients) est$residuals <- y - est$fitted.values est$call <- match.call() class(est) <- "linmod" est } linmod.formula <- function(formula, data=list(), ...) { mf <- model.frame(formula=formula, data=data) x <- model.matrix(attr(mf, "terms"), data=mf) y <- model.response(mf) est <- linmod.default(x, y, ...) est$call <- match.call() est$formula <- formula est } predict.linmod <- function(object, newdata=NULL, ...) { if(is.null(newdata)) y <- fitted(object) else{ if(!is.null(object$formula)){ ## model has been fitted using formula interface x <- model.matrix(object$formula, newdata) } else{ x <- newdata } y <- as.vector(x %*% coef(object)) } y } plotmo/inst/slowtests/test.partdep.Rout.save0000644000176200001440000002437514663412604021056 0ustar liggesusers> # partdep.test.R: partdep tests for plotmo and plotres > > source("test.prolog.R") > library(plotmo) Loading required package: Formula Loading required package: plotrix > library(earth) > data(etitanic) > > mod <- earth(survived~., data=etitanic, degree=2) > > plotmo(mod, caption="plotmo classical") plotmo grid: pclass sex age sibsp parch 3rd male 28 0 0 > > plotmo(mod, pmethod="partdep", caption="plotmo partdep age") calculating partdep for pclass calculating partdep for sex calculating partdep for age calculating partdep for pclass:sex 01234567890 calculating partdep for pclass:sibsp 01234567890 calculating partdep for sex:age 0123456790 > > set.seed(2016) > plotmo(mod, pmethod="apartdep", caption="plotmo apartdep age", do.par=2) calculating apartdep for pclass calculating apartdep for sex calculating apartdep for age calculating apartdep for pclass:sex 01234567890 calculating apartdep for pclass:sibsp 01234567890 calculating apartdep for sex:age 0123456790 > > set.seed(2016) > plotmo(mod, pmethod="apartdep", ylim=c(0,1), do.par=0, + type2="image", pt.col=ifelse(etitanic$survived, "green", "red"), + degree1=0, degree2=1:3) calculating apartdep for pclass:sex 01234567890 calculating apartdep for pclass:sibsp 01234567890 calculating apartdep for sex:age 0123456790 > par(org.par) > > # compare to gbm with an artifical function of variables with a very strong interaction > library(gbm) Loaded gbm 2.2.2 This version of gbm is no longer under development. Consider transitioning to gbm3, https://github.com/gbm-developers/gbm3 > n <- 250 > set.seed(2016) > x1 <- runif(n) > x2 <- runif(n) > x3 <- runif(n) > y <- ifelse(x2 > .6, x1-.2, ifelse(x2 > .4, 1 - 1.5 * x1, .3)) + .1 * sin(4 * x3) > data <- data.frame(x1=x1, x2=x2, x3=x3, y=y) > n.trees <- 20 > set.seed(2016) > mod <- gbm(y~., data=data, n.trees=n.trees, shrinkage=.1, + distribution="gaussian", interact=5) > plotmo(mod, degree1=0, persp.ticktype="detailed", + caption="variables with a strong interaction") > par(mfrow=c(4,4), mar=c(2,3,2,1), mgp=c(1.5, 0.5, 0), oma=c(0,0,6,0)) > library(viridis); Loading required package: viridisLite > image.col <- viridis(100) > ngrid1 <- 50 > ngrid2 <- 30 > plotmo(mod, pmethod="plot", do.par=0, degree2=2, type2="im", ylim=NULL, + clip=FALSE, image.col=image.col, ngrid1=ngrid1, ngrid=ngrid2) plotmo grid: x1 x2 x3 0.5048516 0.4915547 0.5632489 > title("row1: plotmo classic\nrow2: plotmo apartdep\nrow3: plotmo partdep\nrow4: plot.gbm\n\n\n\n\n\n\n", xpd=NA) > ylim <- c(.21, .40) > set.seed(2016) # for consistent selection of rows for partdep.x > plotmo(mod, pmethod="apartdep", do.par=0, degree2=2, type2="im", ylim=ylim, + clip=FALSE, image.col=image.col, ngrid1=ngrid1, ngrid=ngrid2) calculating apartdep for x1 calculating apartdep for x2 calculating apartdep for x3 calculating apartdep for x1:x3 01234567890 > plotmo(mod, pmethod="partdep", do.par=0, degree2=2, type2="im", ylim=ylim, + clip=FALSE, image.col=image.col, ngrid1=ngrid1, ngrid=ngrid2, + trace=-1) # check that the pacifier messages are suppressed > plot(mod, i.var=1, n.trees=n.trees, ylim=ylim, continuous.resolution=ngrid1) > plot(mod, i.var=2, n.trees=n.trees, ylim=ylim, continuous.resolution=ngrid1) > plot(mod, i.var=3, n.trees=n.trees, ylim=ylim, continuous.resolution=ngrid1) > # following ignores par(mfrow=c(2,2)) > plot(mod, i.var=c(1,3), n.trees=n.trees, continuous.resolution=ngrid2, + col.regions=image.col, colorkey=FALSE, + main="gbm plot x1:x3\ncompare to plotmo partdep on previous page") > par(org.par) > > #--- compare to gbm and randomForest with a simple regression function > > data(scor, package="bootstrap") # some correlated data > n <- 50 > x1 <- scale(scor$mec[1:n]) > x2 <- scale(scor$vec[1:n]) > data <- data.frame(x1=x1, x2=x2) > > ngrid1 <- 100 > > # randomForest, simple regression function > library(randomForest) randomForest 4.7-1.1 Type rfNews() to see new features/changes/bug fixes. > data$y <- x1 > -.1 # y depends only on x1 (-.1 hand-tuned to create interesting model surface) > set.seed(2016) > # Expect Warning: The response has five or fewer unique values. Are you sure you want to do regression? > mod <- randomForest(y~., data=data, ntree=3) Warning in randomForest.default(m, y, ...) : The response has five or fewer unique values. Are you sure you want to do regression? > par(mfrow=c(4,2), mar=c(2.5,3,2,1), mgp=c(1.3,0.4,0), oma=c(0,0,7,0)) > set.seed(2016) # for consistent jitter of response sites > plotmo(mod, degree1=0, ngrid2=100, do.par=0, clip=FALSE, + type2="image", main="regression surface", + pt.col=ifelse(data$y, "green", "red")) > title("RANDOM FOREST SIMPLE REGRESSION MODEL + row1: regression surface + row2: plotmo classic type=response + row3: plotmo partdep type=response + row4: randomForest plot\n\n\n\n\n\n\n", + xpd=NA, adj=0) > plotmo(mod, degree1=0, ngrid2=100, do.par=0, clip=FALSE, + persp.border=NA, main="regression surface") > plotmo(mod, pmethod="plotmo", do.par=0, degree2=0, ngrid1=ngrid1, + type="response") plotmo grid: x1 x2 -0.03826182 0.05194756 > plotmo(mod, pmethod="partdep", do.par=0, degree2=0, ngrid1=ngrid1, + type="response") calculating partdep for x1 calculating partdep for x2 > partialPlot(mod, pred.data=data, x.var="x1", n.pt=ngrid1, + which.class="True") > partialPlot(mod, pred.data=data, x.var="x2", n.pt=ngrid1, + which.class="True") > par(org.par) > > # gbm, simple regression function > library(gbm) > n.trees <- 20 > data$y <- x1 > -.6 # y depends only on x1 (-.1 hand-tuned to create interesting model surface) > set.seed(2016) > mod <- gbm(y~., data=data, n.trees=n.trees, + shrinkage=.1, interaction.depth=4, + distribution="gaussian") > par(mfrow=c(4,2), mar=c(2.5,3,2,1), mgp=c(1.3,0.4,0), oma=c(0,0,7,0)) > set.seed(2016) # for consistent jitter of response sites > plotmo(mod, degree1=0, ngrid2=100, do.par=0, clip=FALSE, + type2="image", main="regression surface", + pt.col=ifelse(data$y, "green", "red")) > title("GBM SIMPLE REGRESSION MODEL + row1: regression surface + row2: plotmo classic type=response + row3: plotmo partdep type=response + row4: gbm plot\n\n\n\n\n\n\n", + xpd=NA, adj=0) > plotmo(mod, degree1=0, ngrid2=100, do.par=0, clip=FALSE, + persp.border=NA, main="regression surface") > plotmo(mod, pmethod="plotmo", do.par=0, all1=TRUE, degree2=0, + ngrid1=ngrid1, type="response") plotmo grid: x1 x2 -0.03826182 0.05194756 > plotmo(mod, pmethod="partdep", do.par=0, all1=TRUE, degree2=0, + ngrid1=ngrid1, type="response") calculating partdep for x1 calculating partdep for x2 > plot(mod, i.var=1, n.trees=n.trees, continuous.resolution=ngrid1) > plot(mod, i.var=2, n.trees=n.trees, continuous.resolution=ngrid1) > par(org.par) > > #--- compare to gbm and randomForest with simple binomial (two class) data > > data(scor, package="bootstrap") # some correlated data > n <- 50 > x1 <- scale(scor$mec[1:n]) > x2 <- scale(scor$vec[1:n]) > data <- data.frame(x1=x1, x2=x2) > > ngrid1 <- 100 > > # randomForest, simple binomial (two-class) data > library(randomForest) > # y depends only on x1 > # random forest requires a factor for classification (not a logical) > data$y <- factor(as.character(x1 > .4), + levels=c("FALSE", "TRUE"), + labels=c("False", "True")) > set.seed(2016) > mod <- randomForest(y~., data=data, ntree=3) > par(mfrow=c(4,2), mar=c(2.5,3,2,1), mgp=c(1.3,0.4,0), oma=c(0,0,7,0)) > set.seed(2016) # for consistent jitter of response sites > plotmo(mod, degree1=0, ngrid2=100, do.par=0, clip=FALSE, + type2="image", main="regression surface", + pt.col=ifelse(data$y=="True", "green", "red")) > title("RANDOM FOREST SIMPLE TWO-CLASS MODEL + row1: regression surface + row2: plotmo partdep type=response (FALSE or TRUE) + row3: plotmo partdep type=prob + row4: randomForest partialPlot (clipped log odds)\n\n\n\n\n\n\n", + xpd=NA, adj=0) > plotmo(mod, degree1=0, ngrid2=100, do.par=0, clip=FALSE, + persp.border=NA, main="regression surface") > > plotmo(mod, pmethod="partdep", do.par=0, degree2=0, ngrid1=ngrid1, + type="response") calculating partdep for x1 calculating partdep for x2 > plotmo(mod, pmethod="partdep", do.par=0, degree2=0, ngrid1=ngrid1, + type="prob", nresponse="True", ylim=c(0,1)) calculating partdep for x1 calculating partdep for x2 > partialPlot(mod, pred.data=data, x.var="x1", n.pt=ngrid1, + which.class="True", ylim=c(-16,16)) > partialPlot(mod, pred.data=data, x.var="x2", n.pt=ngrid1, + which.class="True", ylim=c(-16,16)) > par(org.par) > > # gbm, simple binomial (two-class) data > library(gbm) > n.trees <- 10 > data$y <- as.numeric(x1 > .6) # y depends only on x1 > set.seed(2016) > mod <- gbm(y~., data=data, n.trees=n.trees, shrinkage=.1, interact=4, + distribution="bernoulli") > par(mfrow=c(4,2), mar=c(2.5,3,2,1), mgp=c(1.3,0.4,0), oma=c(0,0,7,0)) > set.seed(2016) # for consistent jitter of response sites > plotmo(mod, degree1=0, ngrid2=100, do.par=0, clip=FALSE, + type2="image", main="regression surface", + pt.col=ifelse(data$y, "green", "red")) > title("GBM SIMPLE TWO-CLASS MODEL + row1: regression surface + row2: plotmo partdep type=response (probability) + row4: plotmo partdep type=link (log odds) + row3: gbm plot (log odds)\n\n\n\n\n\n\n", + xpd=NA, adj=0) > plotmo(mod, degree1=0, ngrid2=100, do.par=0, clip=FALSE, + persp.border=NA, main="regression surface") > plotmo(mod, pmethod="partdep", do.par=0, all1=TRUE, degree2=0, + ngrid1=ngrid1, type="response") calculating partdep for x1 calculating partdep for x2 > plotmo(mod, pmethod="partdep", do.par=0, all1=TRUE, degree2=0, + ngrid1=ngrid1, type="link") calculating partdep for x1 calculating partdep for x2 > plot(mod, i.var=1, n.trees=n.trees, continuous.resolution=ngrid1) > plot(mod, i.var=2, n.trees=n.trees, continuous.resolution=ngrid1) > par(org.par) > > source("test.epilog.R") plotmo/inst/slowtests/test.printcall.bat0000755000176200001440000000077014655214117020263 0ustar liggesusers@rem test.printcall.R: test printcall @echo test.printcall.bat @"C:\PROGRA~1\R\R-4.4.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.linmod.R0000644000176200001440000017737314242001333017205 0ustar liggesusers# test.linmod.R: test example S3 model at http://www.milbo.org/doc/linmod.R source("test.prolog.R") source("linmod.R") # linear model code (http://www.milbo.org/doc/linmod.R) source("linmod.methods.R") # additional method functions for linmod options(warn=1) # print warnings as they occur almost.equal <- function(x, y, max=1e-8) { stopifnot(max >= 0 && max < .01) length(x) == length(y) && max(abs(x - y)) < max } # check that linmod model matches reference lm model in all essential details check.lm <- function(fit, ref, newdata=trees[3:5,], check.coef.names=TRUE, check.casenames=TRUE, check.newdata=TRUE, check.sigma=TRUE) { check.names <- function(fit.names, ref.names) { if(check.casenames && # lm always adds rownames even if "1", "2", "3": this seems # wasteful and not particulary helpful, so linmod doesn't do # this, hence the first !isTRUE(all.equal) below !isTRUE(all.equal(ref.names, paste(1:length(ref.names)))) && !isTRUE(all.equal(fit.names, ref.names))) { print(fit.names) print(ref.names) stop(deparse(substitute(fit.names)), " != ", deparse(substitute(ref.names))) } } cat0("check ", deparse(substitute(fit)), " vs ", deparse(substitute(ref)), "\n") stopifnot(coef(fit) == coef(ref)) if(check.coef.names) stopifnot(identical(names(coef(fit)), names(coef(ref)))) stopifnot(identical(dim(fit$coefficients), dim(ref$coefficients))) stopifnot(length(fit$coefficients) == length(ref$coefficients)) stopifnot(almost.equal(fit$coefficients, ref$coefficients)) stopifnot(identical(dim(fit$residuals), dim(ref$residuals))) stopifnot(length(fit$residuals) == length(ref$residuals)) stopifnot(almost.equal(fit$residuals, ref$residuals)) stopifnot(identical(dim(fit$fitted.values), dim(ref$fitted.values))) stopifnot(length(fit$fitted.values) == length(ref$fitted.values)) stopifnot(almost.equal(fit$fitted.values, ref$fitted.values)) stopifnot(identical(fit$rank, ref$rank)) if(!is.null(fit$vcov) && !is.null(ref$vcov)) { stopifnot(identical(dim(fit$vcov), dim(ref$vcov))) stopifnot(length(fit$vcov) == length(ref$vcov)) stopifnot(almost.equal(fit$vcov, ref$vcov)) } if(check.sigma) { ref.sigma <- ref$sigma if(is.null(ref.sigma)) # in lm models, sigma is only available from summary() ref.sigma <- summary(ref)$sigma stopifnot(almost.equal(fit$sigma, ref.sigma)) } stopifnot(almost.equal(fit$df.residual, ref$df.residual)) stopifnot(almost.equal(fitted(fit), fitted(ref))) check.names(names(fitted(fit)), names(fitted(ref))) stopifnot(almost.equal(residuals(fit), residuals(ref))) check.names(names(residuals(fit)), names(residuals(ref))) stopifnot(almost.equal(predict(fit), predict(ref))) check.names(names(predict(fit)), names(predict(ref))) if(check.newdata) { stopifnot(almost.equal(predict(fit, newdata=newdata), predict(ref, newdata=newdata))) check.names(names(predict(fit, newdata=newdata)), names(predict(ref, newdata=newdata))) } } tr <- trees # trees data but with rownames rownames(tr) <- paste("tree", 1:nrow(trees), sep="") linmod.form.Volume.tr <- linmod(Volume~., data=tr) cat0("==print(summary(linmod.form.Volume.tr))\n") print(summary(linmod.form.Volume.tr)) lm.Volume.tr <- lm(Volume~., data=tr) check.lm(linmod.form.Volume.tr, lm.Volume.tr) stopifnot(almost.equal(predict(linmod.form.Volume.tr, newdata=data.frame(Girth=10, Height=80)), 16.234045, max=1e-5)) stopifnot(almost.equal(predict(linmod.form.Volume.tr, newdata=as.matrix(tr[1:3,])), c(4.8376597, 4.5538516, 4.8169813), max=1e-5)) # character new data (instead of numeric) newdata.allchar <- as.data.frame(matrix("blank", ncol=3, nrow=3)) colnames(newdata.allchar) <- colnames(trees) expect.err(try(predict(lm.Volume.tr, newdata=newdata.allchar)), "variables 'Girth', 'Height' were specified with different types from the fit") expect.err(try(predict(linmod.form.Volume.tr, newdata=newdata.allchar)), "variables 'Girth', 'Height' were specified with different types from the fit") linmod.xy.Volume.tr <- linmod(tr[,1:2], tr[,3,drop=FALSE]) # x=data.frame y=data.frame cat0("==print(summary(linmod.xy.Volume.tr))\n") print(summary(linmod.xy.Volume.tr)) newdata.2col <- trees[3:5,1:2] check.lm(linmod.xy.Volume.tr, lm.Volume.tr, newdata=newdata.2col) stopifnot(almost.equal(predict(linmod.xy.Volume.tr, newdata=data.frame(Girth=10, Height=80)), 16.234045, max=1e-5)) stopifnot(almost.equal(predict(linmod.xy.Volume.tr, newdata=tr[1:3,1:2]), c(4.8376597, 4.5538516, 4.8169813), max=1e-5)) linmod50.xy.Volume.tr <- linmod(as.matrix(tr[,1:2]), as.matrix(tr[,3,drop=FALSE])) # x=matrix y=matrix check.lm(linmod50.xy.Volume.tr, lm.Volume.tr, newdata=newdata.2col) linmod51.xy.Volume.tr <- linmod(tr[,1:2], tr[,3]) # x=data.frame y=vector check.lm(linmod51.xy.Volume.tr, lm.Volume.tr, newdata=newdata.2col) linmod52.xy.Volume.tr <- linmod(as.matrix(tr[,1:2]), tr[,3]) # x=matrix y=vector check.lm(linmod52.xy.Volume.tr, lm.Volume.tr, newdata=newdata.2col) # newdata can be a vector stopifnot(almost.equal(predict(linmod.xy.Volume.tr, newdata=c(8.3, 70)), 4.8376597, max=1e-5)) stopifnot(almost.equal(predict(linmod.xy.Volume.tr, newdata=c(8.3, 8.6, 70, 65)), # 4 element vector, byrow=FALSE c(4.8376597, 4.5538516), max=1e-5)) options(warn=1) # print warnings as they occur # expect Warning: data length [3] is not a sub-multiple or multiple of the number of rows [2] stopifnot(almost.equal(predict(linmod.xy.Volume.tr, newdata=c(8.3, 9, 70)), # 3 element vector c(4.8376597, -12.7984291), max=1e-5)) options(warn=2) # treat warnings as errors stopifnot(almost.equal(predict(linmod.xy.Volume.tr, newdata=as.matrix(data.frame(Girth=10, Height=80))), 16.234045, max=1e-5)) # column names in newdata are ignored for linmod.default models stopifnot(almost.equal(predict(linmod.xy.Volume.tr, newdata=data.frame(name1.not.in.orig.data=10, name2.not.in.orig.datax2=80)), 16.234045, max=1e-5)) # note name reversed below but names still ignored, same predict result as c(Girth=10, Height=80) stopifnot(almost.equal(predict(linmod.xy.Volume.tr, newdata=data.frame(Height=10, Girth=80)), 16.234045, max=1e-5)) cat0("==print.default(linmod.form.Volume.tr)\n") print.default(linmod.form.Volume.tr) cat0("==check single x variable\n") linmod1a.form <- linmod(Volume~Height, data=tr) cat0("==print(summary(linmod1a.form))\n") print(summary(linmod1a.form)) lma.tr <- lm(Volume~Height, data=tr) check.lm(linmod1a.form, lma.tr) stopifnot(almost.equal(predict(linmod1a.form, newdata=data.frame(Height=80)), 36.34437, max=1e-5)) stopifnot(almost.equal(predict(linmod1a.form, newdata=data.frame(Girth=99, Height=80)), 36.34437, max=1e-5)) stopifnot(almost.equal(predict(linmod1a.form, newdata=as.matrix(tr[1:3,])), c(20.91087, 13.19412, 10.10742), max=1e-5)) linmod1a.xy <- linmod(tr[,2,drop=FALSE], tr[,3]) cat0("==print(summary(linmod1a.xy))\n") print(summary(linmod1a.xy)) check.lm(linmod1a.xy, lma.tr, newdata=trees[3:5,2,drop=FALSE]) check.lm(linmod1a.xy, lma.tr, newdata=trees[3:5,2,drop=TRUE], check.newdata=FALSE) # needed because predict.lm gives 'data' must be a data.frame, environment, or list stopifnot(almost.equal(predict(linmod1a.xy, newdata=trees[3:5,2,drop=FALSE]), predict(linmod1a.xy, newdata=trees[3:5,2,drop=TRUE]))) stopifnot(almost.equal(predict(linmod1a.xy, newdata=data.frame(Height=80)), 36.34437, max=1e-5)) stopifnot(almost.equal(predict(linmod1a.xy, newdata=tr[1:3,2]), c(20.91087, 13.19412, 10.10742), max=1e-5)) stopifnot(almost.equal(predict(linmod1a.xy, newdata=as.matrix(data.frame(Height=80))), 36.34437, max=1e-5)) # check that extra fields in predict newdata are ok with formula models stopifnot(almost.equal(predict(linmod.form.Volume.tr, newdata=data.frame(Girth=10, Height=80, extra=99)), predict(lm.Volume.tr, newdata=data.frame(Girth=10, Height=80)))) stopifnot(almost.equal(predict(linmod.form.Volume.tr, newdata=data.frame(Girth=10, Height=80, extra=99)), predict(lm.Volume.tr, newdata=data.frame(Girth=10, Height=80, extra=99)))) # check that extra fields in predict newdata are not ok with x,y models expect.err(try(predict(linmod.xy.Volume.tr, newdata=data.frame(Girth=10, Height=80, extra=99))), "ncol(newdata) is 3 but should be 2") # missing variables in newdata expect.err(try(predict(linmod.form.Volume.tr, newdata=data.frame(Girth=10))), "object 'Height' not found") expect.err(try(predict(linmod.form.Volume.tr, newdata=c(8.3, 70))), "object 'Girth' not found") expect.err(try(predict(lm.Volume.tr, newdata=data.frame(Girth=10))), "object 'Height' not found") expect.err(try(predict(linmod.xy.Volume.tr, newdata=data.frame(Girth=10))), "ncol(newdata) is 1 but should be 2") # check that rownames got propagated stopifnot(names(linmod.form.Volume.tr$residuals)[1] == "tree1") stopifnot(names(linmod.form.Volume.tr$fitted.values)[3] == "tree3") stopifnot(names(linmod.xy.Volume.tr$residuals)[1] == "tree1") stopifnot(names(linmod.xy.Volume.tr$fitted.values)[3] == "tree3") stopifnot(!is.null(names(linmod.xy.Volume.tr$residuals))) stopifnot(!is.null(names(linmod.xy.Volume.tr$fitted.values))) cat0("==print.default(linmod.xy.Volume.tr)\n") print.default(linmod.xy.Volume.tr) # check that we don't artificially add rownames when no original rownames linmod1a.xy <- linmod(trees[,1:2], trees[,3]) stopifnot(is.null(names(linmod1a.xy$residuals))) stopifnot(is.null(names(linmod1a.xy$fitted.values))) cat0("==example plots\n") library(plotmo) data(trees) linmod.form.Volume.trees <- linmod(Volume~., data=trees) print(linmod.form.Volume.trees) print(summary(linmod.form.Volume.trees)) linmod1.xy <- linmod(trees[,1:2], trees[,3]) print(linmod1.xy) print(summary(linmod1.xy)) plotmo(linmod.form.Volume.trees) plotmo(linmod1.xy) plotres(linmod.form.Volume.trees) plotres(linmod1.xy) cat0("==test keep arg\n") trees1 <- trees linmod.form.Volume.trees.keep <- linmod(Volume~., data=trees1, keep=TRUE) print(summary(linmod.form.Volume.trees.keep)) print(head(linmod.form.Volume.trees.keep$data)) stopifnot(dim(linmod.form.Volume.trees.keep$data) == c(nrow(trees1), ncol(trees1))) trees1 <- NULL # destroy orginal data so plotmo has to use keep data plotmo(linmod.form.Volume.trees.keep, pt.col=3) plotres(linmod.form.Volume.trees.keep) linmod.xy.keep <- linmod(trees[,1:2], trees[,3], keep=TRUE) print(summary(linmod.xy.keep)) print(head(linmod.xy.keep$x)) stopifnot(dim(linmod.xy.keep$x) == c(nrow(trees), 2)) stopifnot(class(linmod.xy.keep$x)[1] == "matrix") print(head(linmod.xy.keep$y)) stopifnot(dim(linmod.xy.keep$y) == c(nrow(trees), 1)) stopifnot(class(linmod.xy.keep$y)[1] == "matrix") linmod.xy.keep$call <- NULL # trick to force use of x and y in plotmo plotmo(linmod.xy.keep, pt.col=3) plotres(linmod.xy.keep) check.lm(linmod.form.Volume.trees.keep, linmod.xy.keep, check.casenames=FALSE, check.newdata=FALSE) cat0("==test keep arg with vector x\n") n <- 20 linmod.vecx.form.keep <- linmod(Volume~Height, data=trees[1:n,], keep=TRUE) print(summary(linmod.vecx.form.keep)) print(head(linmod.vecx.form.keep$data)) stopifnot(dim(linmod.vecx.form.keep$data) == c(n, ncol(trees))) stopifnot(class(linmod.vecx.form.keep$data) == class(trees)) plotmo(linmod.vecx.form.keep, pt.col=3) plotres(linmod.vecx.form.keep) linmod.vecx.xy.keep <- linmod(trees[1:n,2], trees[1:n,3], keep=TRUE) print(summary(linmod.vecx.xy.keep)) print(head(linmod.vecx.xy.keep$x)) stopifnot(dim(linmod.vecx.xy.keep$x) == c(n, 1)) stopifnot(class(linmod.vecx.xy.keep$x)[1] == "matrix") print(head(linmod.vecx.xy.keep$y)) stopifnot(dim(linmod.vecx.xy.keep$y) == c(n, 1)) stopifnot(class(linmod.vecx.xy.keep$y)[1] == "matrix") linmod.vecx.xy.keep$call <- NULL # trick to force use of x and y in plotmo plotmo(linmod.vecx.xy.keep, pt.col=3) plotres(linmod.vecx.xy.keep) check.lm(linmod.vecx.form.keep, linmod.vecx.xy.keep, newdata=trees[3:5,2,drop=FALSE], check.coef.names=FALSE, check.casenames=FALSE) cat0("==test model building with assorted numeric args\n") x <- tr[,1:2] y <- tr[,3] cat0("class(x)=", class(x), " class(y)=", class(y), "\n") # class(x)=data.frame class(y)=numeric linmod2.xy <- linmod(x, y) check.lm(linmod2.xy, lm.Volume.tr, newdata=newdata.2col) # check consistency with lm expect.err(try(linmod(y~x)), "invalid type (list) for variable 'x'") expect.err(try(lm(y~x)), "invalid type (list) for variable 'x'") linmod3.xy <- linmod(as.matrix(x), as.matrix(y)) check.lm(linmod3.xy, lm.Volume.tr, newdata=newdata.2col) linmod4.form <- linmod(y ~ as.matrix(x)) lm4 <- lm(y ~ as.matrix(x)) check.lm(linmod4.form, lm4, check.newdata=FALSE) stopifnot(coef(linmod4.form) == coef(lm.Volume.tr), gsub("as.matrix(x)", "", names(coef(linmod4.form)), fixed=TRUE) == names(coef(lm.Volume.tr))) xm <- as.matrix(x) cat0("class(xm)=", class(xm), " class(y)=", class(y), "\n") # class(xm)=matrix class(y)=numeric linmod5.form <- linmod(y ~ xm) lm5 <- lm(y ~ xm) check.lm(linmod5.form, lm5, check.newdata=FALSE) stopifnot(coef(linmod5.form) == coef(lm.Volume.tr), gsub("xm", "", names(coef(linmod5.form)), fixed=TRUE) == names(coef(lm.Volume.tr))) cat0("==test correct use of global x1 and y1, and of predict error handling\n") x1 <- tr[,1] y1 <- tr[,3] cat0("class(x1)=", class(x1), " class(y1)=", class(y1), "\n") # class(x1)=numeric class(y1)=numeric linmod.y1.x1 <- linmod(y1~x1) lm1 <- lm(y1~x1) linmod6.xy <- linmod(x1, y1) newdata.x1 <- trees[3:5,1,drop=FALSE] colnames(newdata.x1) <- "x1" stopifnot(almost.equal(predict(linmod.y1.x1, newdata=newdata.x1), c(7.63607739644657, 16.24803331528098, 17.26120459984973))) check.lm(linmod6.xy, linmod.y1.x1, newdata=x1[3:5], check.newdata=FALSE, # TODO needed because linmod.y1.x1 ignores newdata(!) check.coef.names=FALSE, check.casenames=FALSE) print(predict(linmod6.xy, newdata=x1[3:5])) stopifnot(almost.equal(predict(linmod6.xy, newdata=x1[3]), 7.63607739644657)) stopifnot(coef(linmod6.xy) == coef(linmod.y1.x1)) # names(coef(linmod.y1.x1) are "(Intercept)" "x1" stopifnot(names(coef(linmod6.xy)) == c("(Intercept)", "V1")) # following checks some confusing behaviour of predict.lm options(warn=2) # treat warnings as errors expect.err(try(predict(lm1, newdata=trees[3:5,1,drop=FALSE])), "'newdata' had 3 rows but variables found have 31 rows") expect.err(try(predict(lm1, newdata=trees[3:5,1,drop=TRUE])), "'data' must be a data.frame, environment, or list") # following checks messages when missing variables in newdata options(warn=2) # treat warnings as errors to check that we get a warning in stats::model.frame expect.err(try(predict(linmod.y1.x1, newdata=trees[3:5,1,drop=FALSE])), "(converted from warning) 'newdata' had 3 rows but variables found have 31 rows") expect.err(try(predict(lm1, newdata=trees[3:5,1,drop=FALSE])), "(converted from warning) 'newdata' had 3 rows but variables found have 31 rows") expect.err(try(predict(linmod.y1.x1, newdata=trees[3:5,1,drop=TRUE])), "(converted from warning) 'newdata' had 3 rows but variables found have 31 rows") # following checks predict.linmod error messages when missing variables # (it tries to give better error messages than predict.lm) options(warn=1) # print warnings as they occur to test stop() in linmod.R::process.newdata.formula expect.err(try(predict(linmod.y1.x1, newdata=trees[3:5,1,drop=FALSE])), "newdata has 3 rows but model.frame returned 31 rows (variable 'x1' may be missing from newdata)") expect.err(try(predict(linmod.y1.x1, newdata=trees[3:5,1,drop=TRUE])), "newdata has 3 rows but model.frame returned 31 rows (variable 'x1' may be missing from newdata)") options(warn=2) # back to treating warnings as errors # test old version of linmod.R (pre Sep 2020) # # expect.err(try(predict(linmod.y1.x1, newdata=trees[3:5,1,drop=FALSE])), # "variable 'x1' is missing from newdata") # expect.err(try(predict(lm1, newdata=trees[3:5,1,drop=FALSE])), # "(converted from warning) 'newdata' had 3 rows but variables found have 31 rows") # expect.err(try(predict(linmod.y1.x1, newdata=trees[3:5,1,drop=TRUE])), # "variable 'x1' is missing from newdata") linmod6.form <- linmod(y1~x1) check.lm(linmod6.form, linmod.y1.x1, check.newdata=FALSE) newdata <- trees[5:6,] colnames(newdata) <- c("Girth", "Height", "Volume999") # doesn't matter what we call the response stopifnot(identical(predict(linmod.form.Volume.tr, newdata=newdata), predict(linmod.form.Volume.tr, newdata=trees[5:6,]))) newdata <- trees[5:6,3:1] # reverse columns and their colnames colnames(newdata) <- c("Volume", "Height", "Girth") stopifnot(identical(predict(linmod.form.Volume.tr, newdata=newdata), predict(linmod.form.Volume.tr, newdata=trees[5:6,]))) newdata <- trees[5:6,2:1] # reverse columns and their colnames, delete response column colnames(newdata) <- c("Height", "Girth") stopifnot(identical(predict(linmod.form.Volume.tr, newdata=newdata), predict(linmod.form.Volume.tr, newdata=trees[5:6,]))) stopifnot(identical(predict(linmod.form.Volume.tr, newdata=as.matrix(trees[5:6,])), # allow matrix newdata predict(linmod.form.Volume.tr, newdata=trees[5:6,]))) newdata <- trees[5:6,] colnames(newdata) <- c("Girth99", "Height", "Volume") expect.err(try(predict(linmod.form.Volume.tr, newdata=newdata)), "object 'Girth' not found") colnames(newdata) <- c("Girth", "Height99", "Volume") expect.err(try(predict(linmod.form.Volume.tr, newdata=newdata)), "object 'Height' not found") cat0("==check integer input (sibsp is an integer)\n") library(earth) # for etitanic data data(etitanic) tit <- etitanic[seq(1, nrow(etitanic), by=60), ] # small set of data for tests (18 cases) tit$survived <- tit$survived != 0 # convert to logical rownames(tit) <- paste("pas", 1:nrow(tit), sep="") cat0(paste(colnames(tit), "=", sapply(tit, class), sep="", collapse=", "), "\n") linmod7.xy <- linmod(tit$age, tit$sibsp) lm7 <- lm.fit(cbind(1, tit$age), tit$sibsp) stopifnot(coef(linmod7.xy) == coef(lm7)) # coef names will differ linmod7.form <- linmod(sibsp~age, data=tit) lm7.form <- lm(sibsp~age, data=tit) check.lm(linmod7.form, lm7.form, newdata=tit[3:5,]) linmod8.xy <- linmod(tit$sibsp, tit$age) lm8 <- lm.fit(cbind(1, tit$sibsp), tit$age) stopifnot(coef(linmod8.xy) == coef(lm8)) # coef names will differ linmod8.form <- linmod(age~sibsp, data=tit) lm8.form <- lm(age~sibsp, data=tit) check.lm(linmod8.form, lm8.form, newdata=tit[3:5,]) # drop=FALSE so response is a data frame linmod1a.xy <- linmod(trees[,1:2], trees[, 3, drop=FALSE]) print(linmod1a.xy) print(summary(linmod1a.xy)) plotres(linmod1a.xy) # plot caption shows response name "Volume" cat0("==test model building with assorted non-numeric args\n") library(earth) # for etitanic data data(etitanic) etit <- etitanic[seq(1, nrow(etitanic), by=60), ] # small set of data for tests (18 cases) etit$survived <- etit$survived != 0 # convert to logical rownames(etit) <- paste("pas", 1:nrow(etit), sep="") cat0(paste(colnames(etit), "=", sapply(etit, class), sep="", collapse=", "), "\n") lm9 <- lm(survived~., data=etit) linmod9.form <- linmod(survived~., data=etit) check.lm(linmod9.form, lm9, newdata=etit[3:5,]) # change class of pclass to numeric etit.pclass.numeric <- etit etit.pclass.numeric$pclass <- as.numeric(etit$pclass) expect.err(try(predict(lm9, newdata=etit.pclass.numeric)), "(converted from warning) variable 'pclass' is not a factor") expect.err(try(predict(linmod9.form, newdata=etit.pclass.numeric)), "(converted from warning) variable 'pclass' is not a factor") # change class of age to factor etit.age.factor <- etit etit.age.factor$age <- etit$pclass expect.err(try(predict(lm9, newdata=etit.age.factor)), "variable 'age' was fitted with type \"numeric\" but type \"factor\" was supplied") expect.err(try(predict(linmod9.form, newdata=etit.age.factor)), "variable 'age' was fitted with type \"numeric\" but type \"factor\" was supplied") # predict for formula model ignores extra column(s) in newdata etit.extra.col <- etit etit.extra.col$extra <- etit$sibsp stopifnot(identical(predict(lm9, newdata=etit), predict(lm9, newdata=etit.extra.col))) stopifnot(identical(predict(linmod9.form, newdata=etit), predict(linmod9.form, newdata=etit.extra.col))) etit.extra.col$extra2 <- etit$sibsp stopifnot(identical(predict(lm9, newdata=etit), predict(lm9, newdata=etit.extra.col))) stopifnot(identical(predict(linmod9.form, newdata=etit), predict(linmod9.form, newdata=etit.extra.col))) # predict for formula model doesn't care if columns in different order etit.different.col.order <- etit[,ncol(etit):1] # reverse order of columns stopifnot(identical(predict(lm9, newdata=etit), predict(lm9, newdata=etit.different.col.order))) stopifnot(identical(predict(linmod9.form, newdata=etit), predict(linmod9.form, newdata=etit.different.col.order))) # linmod.default, non numeric x (factors in x) expect.err(try(linmod(etit[c(1,3,4,5,6)], etit[,"survived"])), "non-numeric column in 'x'") expect.err(try(linmod.fit(etit[c(1,3,4,5,6)], etit[,"survived"])), "'x' is not a matrix or could not be converted to a matrix") # lousy error message from lm.fit expect.err(try(lm.fit(etit[,c(1,3,4,5,6)], etit[,"survived"])), "INTEGER() can only be applied to a 'integer', not a 'NULL'") expect.err(try(linmod(data.matrix(cbind("(Intercept)"=1, etit[,c(1,3,4,5,6)])), etit[,"survived"])), "column name \"(Intercept)\" in 'x' is duplicated") linmod9a.xy <- linmod(data.matrix(etit[,c(1,3,4,5,6)]), etit[,"survived"]) lm9.fit <- lm.fit(data.matrix(cbind("(Intercept)"=1, etit[,c(1,3,4,5,6)])), etit[,"survived"]) stopifnot(coef(linmod9a.xy) == coef(lm9.fit)) stopifnot(names(coef(linmod9a.xy)) == names(coef(lm9.fit))) expect.err(try(predict(linmod9a.xy, newdata=etit.age.factor[,c(1,3,4,5,6)])), "non-numeric column in 'newdata'") expect.err(try(predict(linmod9a.xy, newdata=etit[,c(1,3,4,5)])), "ncol(newdata) is 4 but should be 5") expect.err(try(predict(linmod9a.xy, newdata=etit[,c(1,3,4,5,6,6)])), "ncol(newdata) is 6 but should be 5") # linmod.formula, logical response data.logical.response <- data.frame(etit[1:6,c("age","sibsp","parch")], response=c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE)) linmod9b.form <- linmod(response~., data=data.logical.response) print(linmod9b.form) lm9b.form <- lm(response~., data=data.logical.response) check.lm(linmod9b.form, lm9b.form, newdata=data.logical.response[2,,drop=FALSE]) # linmod.formula, factor response (not allowed) data.fac.response <- data.frame(etit[1:6,c("age","sibsp","parch")], response=factor(c("a", "a", "b", "a", "b", "b"))) expect.err(try(linmod(response~., data=data.fac.response)), "'y' is not numeric or logical") # lm.formula expect.err(try(lm(response~., data=data.fac.response)), "(converted from warning) using type = \"numeric\" with a factor response will be ignored") # linmod.formula, string response (not allowed) data.string.response <- data.frame(etit[1:6,c("age","sibsp","parch")], response=c("a", "a", "b", "a", "b", "b")) expect.err(try(linmod(response~., data=data.string.response)), "'y' is not numeric or logical") # lm.formula expect.err(try(lm(response~., data=data.string.response)), "(converted from warning) NAs introduced by coercion") # linmod.default, logical response linmod9b.xy <- linmod(etit[1:6,c("age","sibsp","parch")], c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE)) print(linmod9b.xy) # lm.fit, logical response (lousy error message from lm.fit) expect.err(try(lm.fit(etit[1:6,c("age","sibsp","parch")], c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE))), "INTEGER() can only be applied to a 'integer', not a 'NULL'") # linmod.default, factor response expect.err(try(linmod(etit[1:6,c("age","sibsp","parch")], factor(c("a", "a", "b", "a", "b", "b")))), "'y' is not numeric or logical") # linmod.default, string response expect.err(try(linmod(etit[1:6,c("age","sibsp","parch")], c("a", "a", "b", "a", "b", "b"))), "'y' is not numeric or logical") # lm.fit, string and factor responses (lousy error messages from lm.fit) expect.err(try(lm.fit(etit[1:6,c("age","sibsp","parch")], factor(c("a", "a", "b", "a", "b", "b")))), "INTEGER() can only be applied to a 'integer', not a 'NULL'") expect.err(try(lm.fit(etit[1:6,c("age","sibsp","parch")], c("a", "a", "b", "a", "b", "b"))), "INTEGER() can only be applied to a 'integer', not a 'NULL'") options(warn=2) # treat warnings as errors expect.err(try(lm(pclass~., data=etit)), "using type = \"numeric\" with a factor response will be ignored") expect.err(try(linmod(pclass~., data=etit)), "'y' is not numeric or logical") options(warn=1) # print warnings as they occur lm10 <- lm(pclass~., data=etit) # will give warnings options(warn=2) # treat warnings as errors linmod10.form <- linmod(as.numeric(pclass)~., data=etit) stopifnot(coef(linmod10.form) == coef(lm10)) stopifnot(names(coef(linmod10.form)) == names(coef(lm10))) # check.lm(linmod10.form, lm10) # fails because lm10 fitted is all NA expect.err(try(linmod(pclass~., data=etit)), "'y' is not numeric or logical") expect.err(try(linmod(etit[,-1], etit[,1])), "non-numeric column in 'x'") expect.err(try(linmod(1:10, paste(1:10))), "'y' is not numeric or logical") linmod10a.form <- linmod(survived~pclass, data=etit) lm10a <- lm(survived~pclass, data=etit) check.lm(linmod10a.form, lm10a, newdata=etit[3:5,]) expect.err(try(linmod(etit[,"pclass"], etit[,"age"])), "non-numeric column in 'x'") expect.err(try(linmod(paste(1:10), 1:10)), "non-numeric column in 'x'") lm11 <- lm(as.numeric(pclass)~., data=etit) linmod11.form <- linmod(as.numeric(pclass)~., data=etit) check.lm(linmod11.form, lm11, newdata=etit[3:5,]) # logical data (not numeric) bool.data <- data.frame(x=rep(c(TRUE, FALSE, TRUE), length.out=10), y=rep(c(TRUE, FALSE, FALSE), length.out=10)) lm12 <- lm(y~x, data=bool.data) linmod12.form <- linmod(y~x, data=bool.data) check.lm(linmod12.form, lm12, newdata=bool.data[3:5,1], check.newdata=FALSE) # needed because predict.lm gives invalid type (list) for variable 'x' linmod12.xy <- linmod(bool.data$x, bool.data$y) # hack: delete mismatching names so check.lm() doesn't fail names(lm12$coefficients) <- NULL # were "(Intercept)" "xTRUE" names(linmod12.xy$coefficients) <- NULL # were "(Intercept)" "V1" check.lm(linmod12.xy, lm12, newdata=bool.data[3:5,1], check.newdata=FALSE, # needed because predict.lm gives invalid 'envir' argument of type 'logical' check.casenames=FALSE) cat0("==check use of functions in arguments to linmod\n") identfunc <- function(x) x lm10 <- lm( sqrt(survived) ~ I(age^2) + as.numeric(sex), data=identfunc(etit)) linmod10 <- linmod(sqrt(survived) ~ I(age^2) + as.numeric(sex), data=identfunc(etit)) print(summary(lm10)) print(summary(linmod10)) check.lm(linmod10, lm10, newdata=etit[3:5,]) set.seed(2020) plotmo(lm10, pt.col="green", do.par=2) set.seed(2020) plotmo(linmod10, pt.col="green", do.par=0) par(org.par) cat0("==data.frame with strings\n") df.with.string <- data.frame(1:5, c(1,2,-1,4,5), c("a", "b", "a", "a", "b"), stringsAsFactors=FALSE) colnames(df.with.string) <- c("num1", "num2", "string") linmod30.form <- linmod(num1~num2, df.with.string) lm30 <- lm(num1~num2, df.with.string) check.lm(linmod30.form, lm30, check.newdata=FALSE) linmod31.form <- linmod(num1~., df.with.string) lm31 <- lm(num1~., df.with.string) check.lm(linmod31.form, lm31, check.newdata=FALSE) expect.err(try(linmod(string~., df.with.string)), "'y' is not numeric or logical") vec <- c(1,2,3,4,3) expect.err(try(linmod(df.with.string, vec)), "non-numeric column in 'x'") expect.err(try(linmod(etit$pclass, etit$survived)), "non-numeric column in 'x'") cat0("==x is singular\n") set.seed(1) x2 <- matrix(rnorm(6), nrow=2) y2 <- c(1,2) expect.err(try(linmod(y2~x2)), "'x' is singular (it has 4 columns but its rank is 2)") x3 <- matrix(1:10, ncol=2) y3 <- c(1,2,9,4,5) expect.err(try(linmod(y3~x3)), "'x' is singular (it has 3 columns but its rank is 2)") expect.err(try(linmod(trees[1,1:2], trees[1,3])), "'x' is singular (it has 3 columns but its rank is 1)") x2a <- matrix(1:6, nrow=3) y2a <- c(1,2,3) expect.err(try(linmod(y2a~x2a)), "'x' is singular (it has 3 columns but its rank is 2)") cat0("==perfect fit (residuals are zero)\n") set.seed(1) x2b <- matrix(rnorm(6), nrow=3) y2b <- c(1,2,3) data.x2b <- data.frame(x2b, y2b) colnames(data.x2b) <- c("x1", "x2", "y") linmod.x2b <- linmod(y~., data=data.x2b) print(summary(linmod.x2b)) # will have "Residual degrees-of-freedom is zero" comment lm.x2b <- lm(y~., data=data.x2b) print(summary(lm.x2b)) # will have "ALL 3 residuals are 0" comment check.lm(linmod.x2b, lm.x2b, newdata=data.x2b[1:2,]+1, check.sigma=FALSE) x2c <- 1:10 y2c <- 11:20 data.x2c <- data.frame(x2c, y2c) colnames(data.x2c) <- c("x", "y") linmod.x2c <- linmod(y~., data=data.x2c) print(summary(linmod.x2c)) lm.x2c <- lm(y~., data=data.x2c) options(warn=1) # print warnings as they occur print(summary(lm.x2c)) # will have "essentially perfect fit: summary may be unreliable" comment options(warn=2) # treat warnings as errors check.lm(linmod.x2c, lm.x2c, newdata=data.x2c[1:2,]+1, check.sigma=FALSE) par(mfrow=c(2,2)) # all plots on same page so can compare plot(linmod.x2b, main="linmod.x2b\nall residuals are zero") plot(lm.x2b, which=1, main="lm.x2b") plot(linmod.x2c, main="linmod.x2c") plot(lm.x2c, which=1, main="lm.x2c") par(org.par) cat0("==nrow(x) does not match length(y)\n") x4 <- matrix(1:10, ncol=2) y4 <- c(1,2,9,4) expect.err(try(linmod(x4, y4)), "nrow(x) is 5 but length(y) is 4") x5 <- matrix(1:10, ncol=2) y5 <- c(1,2,9,4,5,9) expect.err(try(linmod(x5, y5)), "nrow(x) is 5 but length(y) is 6") cat0("==y has multiple columns\n") vec <- c(1,2,3,4,3) y2 <- cbind(c(1,2,3,4,9), vec^2) expect.err(try(linmod(vec, y2)), "nrow(x) is 5 but length(y) is 10") expect.err(try(linmod(y2~vec)), "nrow(x) is 5 but length(y) is 10") cat0("==NA in x\n") x <- tr[,1:2] y <- tr[,3] x[2,2] <- NA expect.err(try(linmod(x, y)), "NA in 'x'") x <- tr[,1:2] y <- tr[,3] y[9] <- NA expect.err(try(linmod(x, y)), "NA in 'y'") # Following added Sep 2020 (prior to this, predict.linmod gave an incorrect error message) cat0("==test formulas that use functions on rhs variables, like Volume~sqrt(Girth)\n") linmod.sqrt1 <- linmod(Volume~sqrt(as.numeric(Girth)), data=tr) cat0("==print(summary(linmod.sqrt1))\n") print(summary(linmod.sqrt1)) lm.sqrt1 <- lm(Volume~sqrt(as.numeric(Girth)), data=tr) check.lm(linmod.sqrt1, lm.sqrt1) stopifnot(almost.equal(predict(linmod.sqrt1, newdata=data.frame(Girth=10, Height=80)), predict(lm.sqrt1, newdata=data.frame(Girth=10, Height=80)))) stopifnot(almost.equal(predict(linmod.sqrt1, newdata=as.matrix(tr[1:3,])), predict(lm.sqrt1, newdata=tr[1:3,]))) par(mfrow=c(2,2)) # all plots on same page so can compare plotmo(linmod.sqrt1, do.par=FALSE) plotmo(lm.sqrt1, do.par=FALSE) par(org.par) linmod.sqrt2 <- linmod(Volume~sqrt(Girth)+Height+Girth, data=tr) cat0("==print(summary(linmod.sqrt2))\n") print(summary(linmod.sqrt2)) lm.sqrt2 <- lm(Volume~sqrt(Girth)+Height+Girth, data=tr) check.lm(linmod.sqrt2, lm.sqrt2) stopifnot(almost.equal(predict(linmod.sqrt2, newdata=data.frame(Girth=10, Height=80)), predict(lm.sqrt2, newdata=data.frame(Girth=10, Height=80)))) stopifnot(almost.equal(predict(linmod.sqrt2, newdata=as.matrix(tr[1:3,])), predict(lm.sqrt2, newdata=tr[1:3,]))) par(mfrow=c(2,2)) # all plots on same page so can compare plotmo(linmod.sqrt2, do.par=FALSE) plotmo(lm.sqrt2, do.par=FALSE) par(org.par) lm.sqrt.as.numeric <- lm(survived~sqrt(age)+as.numeric(pclass), data=etit) linmod.sqrt.as.numeric <- linmod(survived~sqrt(age)+as.numeric(pclass), data=etit) check.lm(linmod.sqrt.as.numeric, lm.sqrt.as.numeric, newdata=etit[3:5,]) expect.err(try(predict(linmod.sqrt.as.numeric, newdata=data.frame(age=30))), # pclass missing "object 'pclass' not found") par(mfrow=c(2,2)) # all plots on same page so can compare plotmo(linmod.sqrt.as.numeric, do.par=FALSE) plotmo(lm.sqrt.as.numeric, do.par=FALSE) par(org.par) y.age <- etit[,"age"] x.pclass <- etit[,"pclass"] x.sex <- etit[,"sex"] linmod.y.age.sex.pclass <- linmod(y.age ~ as.numeric(x.pclass) + x.sex) lm.y.age.sex.pclass <- lm( y.age ~ as.numeric(x.pclass) + x.sex) stopifnot(identical(linmod.y.age.sex.pclass$coef, lm.y.age.sex.pclass$coef)) options(warn=1) # print warnings as they occur to test stop() in linmod.R::process.newdata.formula # TODO following says variable 'as.numeric(x.pclass)' may be missing # it should say variable 'x.pclass' may be missing expect.err(try(predict(linmod.y.age.sex.pclass, newdata=etit[3:5,1,drop=FALSE])), "newdata has 3 rows but model.frame returned 18 rows (variable 'as.numeric(x.pclass)' may be missing from newdata)") options(warn=2) # back to treating warnings as errors cat0("==misc tests with different kinds of data\n") data3 <- data.frame(s=c("a", "b", "a", "c", "a"), num=c(1,5,1,9,2), y=c(1,3,2,5,3), stringsAsFactors=F) stopifnot(sapply(data3, class) == c("character", "numeric", "numeric")) a40 <- linmod(y~., data=data3) print(summary(a40)) stopifnot(almost.equal(a40$coefficients, c(0, -4.5, -8.5, 1.5), max=0.001)) stopifnot(almost.equal(predict(a40, newdata=data3[2:3,]), c(3.0, 1.5), max=0.001)) data4 <- data.frame(s=c("a", "b", "a", "c", "a"), num=c(1,5,1,9,2), y=c(1,3,2,5,3), stringsAsFactors=T) stopifnot(sapply(data4, class) == c("factor", "numeric", "numeric")) expect.err(try(linmod(data4[,1:2], data4[,3])), "non-numeric column in 'x'") # following gives no error (and matches lm) even though col 1 of data3 is character not factor a41 <- linmod(y~., data=data4) print(summary(a41)) stopifnot(almost.equal(predict(a41, newdata=data3[2:3,]), c(3.0, 1.5), max=0.001)) data5 <- data.frame(s=c("a", "b", "c", "a", "a"), num=c(1,9,4,2,6), y=c(1,2,3,5,3), stringsAsFactors=F) stopifnot(almost.equal(predict(a41, newdata=data5[1:3,1:2]), c(1.5, 9.0, -2.5), max=0.001)) data6 <- data.frame(s=c("a", "b", "c", "a9", "a"), num=c(1,9,4,2,6), num2=c(1,9,4,2,7), y=c(1,2,3,5,3), stringsAsFactors=T) expect.err(try(predict(a41, newdata=data6[1:3,1])), "object 's' not found") expect.err(try(predict(a41, newdata=data6[1:3,c(1,1)])), "object 'num' not found") expect.err(try(predict(a41, newdata=data.frame(s=1, num=2, y=3))), "variable 's' is not a factor") expect.err(try(predict(a41, newdata=1:9)), "object 's' not found") expect.err(try(predict(a41, newdata=data.frame())), "'newdata' is empty") # perfect fit (residuals are all zero) linmod.data6 <- linmod(y~s+num, data=data6) print(summary(linmod.data6)) lm.data6 <- lm(y~s+num, data=data6) print(summary(lm.data6)) check.lm(linmod.data6, lm.data6, newdata=data6[2,,drop=FALSE], check.sigma=FALSE) expect.err(try(linmod(y~., data=data6)), "'x' is singular (it has 6 columns but its rank is 5)") tr.na <- trees tr.na[9,3] <- NA expect.err(try(linmod(Volume~.,data=tr.na)), "NA in 'y'") expect.err(try(linmod(tr.na[,1:2], tr.na[,3])), "NA in 'y'") tr.na <- trees tr.na[10,1] <- NA expect.err(try(linmod(Volume~.,data=tr.na)), "NA in 'x'") expect.err(try(linmod(tr.na[,1:2], tr.na[,3])), "NA in 'x'") a42 <- linmod(trees[,1:2], trees[, 3]) newdata1 <- data.frame(Girth=20) expect.err(try(predict(a42, newdata=newdata1)), "ncol(newdata) is 1 but should be 2") newdata3 <- data.frame(Girth=20, extra1=21, extra2=22) expect.err(try(predict(a42, newdata=newdata3)), "ncol(newdata) is 3 but should be 2") expect.err(try(predict(a42, newdata=data.frame())), "'newdata' is empty") newdata.with.NA <- data.frame(Girth=20, Height=NA) expect.err(try(predict(a42, newdata=newdata.with.NA)), "NA in 'newdata'") a43 <- linmod(Volume~.,data=trees) expect.err(try(predict(a43, newdata=newdata.with.NA)), "NA in 'newdata'") lm43 <- lm(Volume~.,data=trees) # message from predict.lm could be better expect.err(try(predict(lm43, newdata=newdata.with.NA)), "variable 'Height' was fitted with type \"numeric\" but type \"logical\" was supplied") y6 <- 1:5 x6 <- data.frame() options(warn=1) # print warnings as they occur expect.err(try(linmod(x6, y6)), "'x' is empty") options(warn=2) # treat warnings as errors y7 <- data.frame() x7 <- 1:5 expect.err(try(linmod(x7, y7)), "'y' is empty") # duplicated column names data7 <- matrix(1:25, ncol=5) colnames(data7) <- c("y", "x1", "x1", "x3", "x4") expect.err(try(linmod(data7[,-1], data7[,1])), "column name \"x1\" in 'x' is duplicated") colnames(data7) <- c("y", "x1", "x2", "x2", "x4") expect.err(try(linmod(data7[,-1], data7[,1])), "column name \"x2\" in 'x' is duplicated") colnames(data7) <- c("y", "x1", "x2", "x2", "x2") expect.err(try(linmod(data7[,-1], data7[,1])), "column name \"x2\" in 'x' is duplicated") # column name V2 will be created but it clashes with the existing column name colnames(data7) <- c("y", "V2", "", "V3", "V4") expect.err(try(linmod(data7[,-1], data7[,1])), "column name \"V2\" in 'x' is duplicated") # missing column names trees1 <- trees colnames(trees1) <- NULL cat0("a52\n") a52 <- linmod(trees1[,1:2], trees1[,3]) print(summary(a52)) trees1 <- trees colnames(trees1) <- c("", "Height", "Volume") # was Girth Height Volume cat0("linmod.form.Volume.trees1\n") linmod.form.Volume.trees1 <- linmod(trees1[,1:2], trees1[,3]) print(summary(linmod.form.Volume.trees1)) cat0("linmod.form.Volume.trees1.formula\n") expect.err(try(linmod(Volume~., data=trees1)), "attempt to use zero-length variable name") # very long names to test formatting in summary.linmod trees1 <- trees colnames(trees1) <- c("Girth.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name", "Height.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name", "Volume.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name") cat0("a55\n") a55 <- linmod(Volume.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name~ Girth.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name+ Height.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name, data=trees1) print(summary(a55)) # intercept-only model intonly.form <- linmod(Volume~1, data=trees) print(summary(intonly.form)) stopifnot(length(coef(intonly.form)) == 1) try(plotmo(intonly.form)) # Error in plotmo(intonly.form) : x is empty plotres(intonly.form) expect.err(try(plotmo(intonly.form)), "x is empty") expect.err(try(linmod(rep(1, length.out=nrow(trees)), trees$Volume)), "'x' is singular (it has 2 columns but its rank is 1)") # various tests for bad args expect.err(try(linmod(trees[,1:2])), "no 'y' argument") # test stop.if.dot.arg.used expect.err(try(linmod(Volume~., data=trees, nonesuch=99)), "unused argument (nonesuch = 99)") expect.err(try(linmod(trees[,1:2], trees[,3], nonesuch=linmod)), "unused argument (nonesuch = function (...)") expect.err(try(summary(linmod(trees[,1:2], trees[,3]), nonesuch=linmod)), "unused argument (nonesuch = function (...)") expect.err(try(print(linmod(trees[,1:2], trees[,3]), nonesuch=linmod)), "unused argument (nonesuch = function (...)") expect.err(try(predict(linmod.form.Volume.tr, nonesuch=99)), "unused argument (nonesuch = 99)") # check partial matching on type argument stopifnot(identical(predict(linmod.form.Volume.tr, type="r"), predict(linmod.form.Volume.tr))) stopifnot(identical(predict(linmod.form.Volume.tr, type="resp"), predict(linmod.form.Volume.tr))) expect.err(try(predict(linmod.form.Volume.tr, type="nonesuch")), "'arg' should be \"response\"") # test additional method functions (see linmod.methods.R) check.lm(linmod.form.Volume.tr, lm.Volume.tr, newdata=trees[3,1:2]) stopifnot(almost.equal(coef(linmod.form.Volume.tr), coef(lm.Volume.tr))) stopifnot(identical(names(coef(linmod.form.Volume.tr)), names(coef(lm.Volume.tr)))) stopifnot(almost.equal(fitted(linmod.form.Volume.tr), fitted(lm.Volume.tr))) stopifnot(identical(names(fitted(linmod.form.Volume.tr)), names(fitted(lm.Volume.tr)))) stopifnot(identical(na.action(linmod.form.Volume.tr), na.action(lm.Volume.tr))) stopifnot(almost.equal(residuals(linmod.form.Volume.tr), residuals(lm.Volume.tr))) stopifnot(identical(names(residuals(linmod.form.Volume.tr)), names(residuals(lm.Volume.tr)))) stopifnot(identical(names(case.names(linmod.form.Volume.tr)), names(case.names(lm.Volume.tr)))) stopifnot(identical(variable.names(linmod.form.Volume.tr), variable.names(lm.Volume.tr))) stopifnot(identical(nobs(linmod.form.Volume.tr), nobs(lm.Volume.tr))) stopifnot(identical(weights(linmod.form.Volume.tr), weights(lm.Volume.tr))) stopifnot(almost.equal(df.residual(linmod.form.Volume.tr), df.residual(lm.Volume.tr))) stopifnot(identical(names(df.residual(linmod.form.Volume.tr)), names(df.residual(lm.Volume.tr)))) stopifnot(almost.equal(deviance(linmod.form.Volume.tr), deviance(lm.Volume.tr))) stopifnot(identical(names(deviance(linmod.form.Volume.tr)), names(deviance(lm.Volume.tr)))) stopifnot(identical(weights(linmod.form.Volume.tr), weights(lm.Volume.tr))) stopifnot(identical(model.frame(linmod.form.Volume.tr), model.frame(lm.Volume.tr))) stopifnot(identical(model.matrix(linmod.form.Volume.tr), model.matrix(lm.Volume.tr))) stopifnot(identical(model.matrix(linmod.form.Volume.tr, data=tr[1:2,]), model.matrix(lm.Volume.tr, data=tr[1:2,]))) stopifnot(almost.equal(logLik(linmod.form.Volume.tr), logLik(lm.Volume.tr))) expect.err(try(logLik(linmod.form.Volume.tr, REML=TRUE)), "!REML is not TRUE") library(sandwich) # for estfun.lm stopifnot(almost.equal(estfun(linmod.form.Volume.tr), estfun(lm.Volume.tr))) linmod.form.Volume.tr.update <- update(linmod.form.Volume.tr, formula.=Volume~Height) lm.Volume.tr.update <- update(lm.Volume.tr, formula.=Volume~Height) check.lm(linmod.form.Volume.tr.update, lm.Volume.tr.update) check.lm(linmod.xy.Volume.tr, lm.Volume.tr, newdata=trees[3,1:2]) stopifnot(almost.equal(coef(linmod.xy.Volume.tr), coef(lm.Volume.tr))) stopifnot(identical(names(coef(linmod.xy.Volume.tr)), names(coef(lm.Volume.tr)))) stopifnot(almost.equal(fitted(linmod.xy.Volume.tr), fitted(lm.Volume.tr))) stopifnot(identical(names(fitted(linmod.xy.Volume.tr)), names(fitted(lm.Volume.tr)))) stopifnot(identical(na.action(linmod.xy.Volume.tr), na.action(lm.Volume.tr))) stopifnot(almost.equal(residuals(linmod.xy.Volume.tr), residuals(lm.Volume.tr))) stopifnot(identical(names(residuals(linmod.xy.Volume.tr)), names(residuals(lm.Volume.tr)))) stopifnot(identical(case.names(linmod.xy.Volume.tr), case.names(lm.Volume.tr))) stopifnot(identical(variable.names(linmod.xy.Volume.tr), variable.names(lm.Volume.tr))) stopifnot(identical(nobs(linmod.xy.Volume.tr), nobs(lm.Volume.tr))) stopifnot(identical(weights(linmod.xy.Volume.tr), weights(lm.Volume.tr))) stopifnot(almost.equal(df.residual(linmod.xy.Volume.tr), df.residual(lm.Volume.tr))) stopifnot(identical(names(df.residual(linmod.xy.Volume.tr)), names(df.residual(lm.Volume.tr)))) stopifnot(almost.equal(deviance(linmod.xy.Volume.tr), deviance(lm.Volume.tr))) stopifnot(identical(names(deviance(linmod.xy.Volume.tr)), names(deviance(lm.Volume.tr)))) stopifnot(identical(weights(linmod.xy.Volume.tr), weights(lm.Volume.tr))) expect.err(try(model.frame(linmod.xy.Volume.tr)), "model.frame cannot be used on linmod models built without a formula") expect.err(try(model.matrix(linmod.xy.Volume.tr)), "model.frame cannot be used on linmod models built without a formula") stopifnot(almost.equal(logLik(linmod.xy.Volume.tr), logLik(lm.Volume.tr))) par(mfrow=c(2,2)) plot(linmod.form.Volume.tr) plot(lm.Volume.tr, which=1, main="lm.Volume.tr") plot(linmod.xy.Volume.tr) plot(linmod.form.Volume.tr, xlim=c(0,80), ylim=c(-10,10), pch=20, main="linmod.form.Volume.tr: test plot args") par(org.par) cat0("==test one predictor model\n") linmod.onepred.form <- linmod(Volume~Girth, data=tr) # one predictor lm.onepred.form <- lm(Volume~Girth, data=tr) check.lm(linmod.onepred.form, lm.onepred.form, newdata=trees[3,1:2]) linmod.onepred.xy <- linmod(tr[,1,drop=FALSE], tr[,3]) # one predictor print(summary(linmod.onepred.xy)) check.lm(linmod.onepred.xy, lm.onepred.form, newdata=trees[3,1,drop=FALSE]) par(mfrow=c(2,2)) plot(linmod.onepred.form) plot(lm.onepred.form, which=1, main="lm.onepred.form") plot(linmod.onepred.xy) par(org.par) plotres(linmod.onepred.form) plotmo(linmod.onepred.form, pt.col=2) cat0("==test no intercept model\n") # no intercept models are only supported with the formula interface (not x,y interface) linmod.noint <- linmod(Volume~.-1, data=trees) # no intercept print(summary(linmod.noint)) lm.noint <- lm(Volume~.-1, data=trees) # no intercept check.lm(linmod.noint, lm.noint) linmod.noint.keep <- linmod(Volume~.-1, data=trees, keep=TRUE) print(summary(linmod.noint.keep)) check.lm(linmod.noint, lm.noint) stopifnot(class(linmod.noint.keep$data) == class(linmod.form.Volume.trees.keep$data)) stopifnot(all(dim(linmod.noint.keep$data) == dim(linmod.form.Volume.trees.keep$data))) stopifnot(all(linmod.noint.keep$data == linmod.form.Volume.trees.keep$data)) stopifnot(class(linmod.noint.keep$y) == class(linmod.form.Volume.trees.keep$y)) stopifnot(all(dim(linmod.noint.keep$data) == dim(linmod.form.Volume.trees.keep$data))) stopifnot(all(linmod.noint.keep$data == linmod.form.Volume.trees.keep$data)) # check method functions in no-intercept model stopifnot(almost.equal(coef(linmod.noint), coef(lm.noint))) stopifnot(identical(names(coef(linmod.noint)), names(coef(lm.noint)))) stopifnot(almost.equal(fitted(linmod.noint), fitted(lm.noint))) stopifnot(identical(names(fitted(linmod.noint)), names(fitted(lm.noint)))) stopifnot(identical(na.action(linmod.noint), na.action(lm.noint))) stopifnot(almost.equal(residuals(linmod.noint), residuals(lm.noint))) stopifnot(identical(names(residuals(linmod.noint)), names(residuals(lm.noint)))) stopifnot(identical(case.names(linmod.noint), case.names(lm.noint))) stopifnot(identical(variable.names(linmod.noint), variable.names(lm.noint))) stopifnot(identical(nobs(linmod.noint), nobs(lm.noint))) stopifnot(identical(weights(linmod.noint), weights(lm.noint))) stopifnot(almost.equal(df.residual(linmod.noint), df.residual(lm.noint))) stopifnot(identical(names(df.residual(linmod.noint)), names(df.residual(lm.noint)))) stopifnot(almost.equal(deviance(linmod.noint), deviance(lm.noint))) stopifnot(identical(names(deviance(linmod.noint)), names(deviance(lm.noint)))) stopifnot(identical(weights(linmod.noint), weights(lm.noint))) stopifnot(identical(model.frame(linmod.noint), model.frame(lm.noint))) stopifnot(identical(model.matrix(linmod.noint), model.matrix(lm.noint))) stopifnot(identical(model.matrix(linmod.noint, data=tr[1:2,]), model.matrix(lm.noint, data=tr[1:2,]))) stopifnot(almost.equal(logLik(linmod.noint), logLik(lm.noint))) stopifnot(almost.equal(estfun(linmod.noint), estfun(lm.noint))) # check error messages with bad newdata in no-intercept model expect.err(try(predict(linmod.noint, newdata=NA)), "object 'Girth' not found") expect.err(try(predict(linmod.noint, newdata=data.frame(Height=c(1,NA), Girth=c(3,4)))), "NA in 'newdata'") expect.err(try(predict(linmod.noint, newdata=trees[0,])), "'newdata' is empty") expect.err(try(predict(linmod.noint, newdata=trees[3:5,"Height"])), "object 'Girth' not found") # check that extra fields in predict newdata are ok with (formula) models without intercept stopifnot(almost.equal(predict(linmod.noint, newdata=data.frame(Girth=10, Height=80, extra=99)), predict(lm.noint, newdata=data.frame(Girth=10, Height=80, extra=99)))) par(mfrow=c(2,2)) plot(linmod.noint) plot(lm.noint, which=1, main="lm.noint") par(org.par) plotres(linmod.noint) plotmo(linmod.noint) cat0("==test one predictor no intercept model\n") # no intercept models are only supported with the formula interface (not x,y interface) linmod.onepred.noint <- linmod(Volume~Girth-1, data=trees) # one predictor, no intercept print(summary(linmod.onepred.noint)) lm.onepred.noint <- lm(Volume~Girth-1, data=trees) # one predictor, no intercept check.lm(linmod.onepred.noint, lm.onepred.noint) linmod.onepred.noint.keep <- linmod(Volume~.-1, data=trees, keep=TRUE) print(summary(linmod.onepred.noint.keep)) check.lm(linmod.onepred.noint, lm.onepred.noint) stopifnot(class(linmod.onepred.noint.keep$data) == class(linmod.form.Volume.trees.keep$data)) stopifnot(all(dim(linmod.onepred.noint.keep$data) == dim(linmod.form.Volume.trees.keep$data))) stopifnot(all(linmod.onepred.noint.keep$data == linmod.form.Volume.trees.keep$data)) stopifnot(class(linmod.onepred.noint.keep$y) == class(linmod.form.Volume.trees.keep$y)) stopifnot(all(dim(linmod.onepred.noint.keep$data) == dim(linmod.form.Volume.trees.keep$data))) stopifnot(all(linmod.onepred.noint.keep$data == linmod.form.Volume.trees.keep$data)) # check method functions in one predictor no-intercept model stopifnot(almost.equal(coef(linmod.onepred.noint), coef(lm.onepred.noint))) stopifnot(identical(names(coef(linmod.onepred.noint)), names(coef(lm.onepred.noint)))) stopifnot(almost.equal(fitted(linmod.onepred.noint), fitted(lm.onepred.noint))) stopifnot(identical(names(fitted(linmod.onepred.noint)), names(fitted(lm.onepred.noint)))) stopifnot(identical(na.action(linmod.onepred.noint), na.action(lm.onepred.noint))) stopifnot(almost.equal(residuals(linmod.onepred.noint), residuals(lm.onepred.noint))) stopifnot(identical(names(residuals(linmod.onepred.noint)), names(residuals(lm.onepred.noint)))) stopifnot(identical(case.names(linmod.onepred.noint), case.names(lm.onepred.noint))) stopifnot(identical(variable.names(linmod.onepred.noint), variable.names(lm.onepred.noint))) stopifnot(identical(nobs(linmod.onepred.noint), nobs(lm.onepred.noint))) stopifnot(identical(weights(linmod.onepred.noint), weights(lm.onepred.noint))) stopifnot(almost.equal(df.residual(linmod.onepred.noint), df.residual(lm.onepred.noint))) stopifnot(identical(names(df.residual(linmod.onepred.noint)), names(df.residual(lm.onepred.noint)))) stopifnot(almost.equal(deviance(linmod.onepred.noint), deviance(lm.onepred.noint))) stopifnot(identical(names(deviance(linmod.onepred.noint)), names(deviance(lm.onepred.noint)))) stopifnot(identical(weights(linmod.onepred.noint), weights(lm.onepred.noint))) stopifnot(identical(model.frame(linmod.onepred.noint), model.frame(lm.onepred.noint))) stopifnot(identical(model.matrix(linmod.onepred.noint), model.matrix(lm.onepred.noint))) stopifnot(identical(model.matrix(linmod.onepred.noint, data=tr[1:2,]), model.matrix(lm.onepred.noint, data=tr[1:2,]))) stopifnot(almost.equal(logLik(linmod.onepred.noint), logLik(lm.onepred.noint))) stopifnot(almost.equal(estfun(linmod.onepred.noint), estfun(lm.onepred.noint))) # check error messages with bad newdata in one predictor no-intercept model expect.err(try(predict(linmod.onepred.noint, newdata=99)), "object 'Girth' not found") expect.err(try(predict(linmod.onepred.noint, newdata=data.frame(Girth=NA))), "NA in 'newdata'") expect.err(try(predict(linmod.onepred.noint, newdata=trees[0,1])), "'newdata' is empty") expect.err(try(predict(linmod.onepred.noint, newdata=trees[3:5,"Height"])), "object 'Girth' not found") # check that extra fields in predict newdata are ok with (formula) models without intercept stopifnot(almost.equal(predict(linmod.onepred.noint, newdata=data.frame(Girth=10, extra=99)), predict(lm.onepred.noint, newdata=data.frame(Girth=10, extra=99)))) par(mfrow=c(2,2)) plot(linmod.onepred.noint) plot(lm.onepred.noint, which=1, main="lm.onepred.noint") par(org.par) plotres(linmod.onepred.noint) plotmo(linmod.onepred.noint) expect.err(try(linmod(Volume~nonesuch, data=trees)), "object 'nonesuch' not found") expect.err(try(linmod(Volume~0, data=trees)), "'x' is empty") # no predictor expect.err(try(linmod(Volume~-1, data=trees)), "'x' is empty") # no predictor, no intercept cat0("==check model with many variables\n") set.seed(2018) p <- 300 # number of variables n <- floor(1.1 * p) bigdat <- as.data.frame(matrix(rnorm(n * (p+1)), ncol=p+1)) colnames(bigdat) <- c("y", paste0("var", 1:p)) lm.bigdat <- lm(y~., data=bigdat) linmod.bigdat <- linmod(y~., data=bigdat) check.lm(linmod.form.Volume.tr, lm.Volume.tr) print(linmod.bigdat) print(summary(linmod.bigdat)) expect.err(try(predict(linmod.bigdat, newdata=bigdat[,1:(p-3)])), "object 'var297' not found") plot(linmod.bigdat) # plotmo(linmod.bigdat) # works, but commented out because slow(ish) # plotres(linmod.bigdat) # ditto cat0("==check use of matrix as data in linmod.form\n") # linmod.form allows a matrix, lm doesn't TODO is this inconsistency what we want? tr.mat <- as.matrix(tr) cat0("class(tr.mat)=", class(tr.mat), "\n") # class(tr.mat)=matrix expect.err(try(lm(Volume~., data=tr.mat)), "'data' must be a data.frame, not a matrix or an array") linmod.form.Volume.mat.tr <- linmod(Volume~., data=tr.mat) check.lm(linmod.form.Volume.mat.tr, linmod.form.Volume.tr) cat0("==print(summary(linmod.form.Volume.mat.tr))\n") print(summary(linmod.form.Volume.mat.tr)) plotres(linmod.form.Volume.mat.tr) tr.mat.no.colnames <- as.matrix(tr) colnames(tr.mat.no.colnames) <- NULL expect.err(try(linmod(Volume~., data=tr.mat.no.colnames)), "object 'Volume' not found") linmod.form.Volume.mat.tr.no.colnames <- linmod(V3~., data=tr.mat.no.colnames) check.lm(linmod.form.Volume.mat.tr.no.colnames, linmod.form.Volume.tr, check.coef.names=FALSE, check.newdata=FALSE) # no check.newdata else object 'V1' not found # Check what happens when we change the original data used to build the model. # Use plotres as an example function that must figure out residuals from predict(). pr <- function(model, main=deparse(substitute(model))) { plotres(model, which=3, main=main) # which=3 for just the residuals plot } cat0("==linmod.formula: change data used to build the model\n") trees1 <- trees linmod.trees1 <- linmod(Volume~., data=trees1) # delete the saved residuals and fitted.values so plotres has to use the saved # call etc. to get the x and y used to build the model, and rely on predict() linmod.trees1$residuals <- NULL linmod.trees1$fitted.values <- NULL par(mfrow=c(3,3)) pr(linmod.trees1) trees1 <- trees[, 3:1] # change column order in original data pr(linmod.trees1, "change col order") trees1 <- trees[1:3, ] # change number of rows in original data pr(linmod.trees1, "change nbr rows") # TODO wrong residuals! (lm has the same issue) cat("call$data now refers to the changed data:\n") # lm has the same problem if called with model=FALSE print(eval(linmod.trees1$call$data)) cat("model.frame now returns the changed data:\n") print(model.frame(linmod.trees1)) trees1 <- trees[nrow(tr):1, ] # change row order (but keep same nbr of rows) pr(linmod.trees1, "change row order") colnames(trees1) <- c("x1", "x2", "x3") # change column names in original data expect.err(try(pr(linmod.trees1, "change colnames")), "cannot get the original model predictors") trees1 <- "garbage" expect.err(try(pr(linmod.trees1, "trees1=\"garbage\"")), "cannot get the original model predictors") trees1 <- 1:1000 expect.err(try(pr(linmod.trees1, "trees1=1:1000")), "cannot get the original model predictors") trees1 <- NULL # original data no longer available expect.err(try(pr(linmod.trees1, "trees1=NULL")), "cannot get the original model predictors") remove(trees1) expect.err(try(pr(linmod.trees1, "remove(trees1)")), "cannot get the original model predictors") # similar to above, but don't delete the saved residuals and fitted.values trees1 <- trees linmod2.trees1 <- linmod(Volume~., data=trees1) trees1 <- trees[1:3, ] # change number of rows in original data expect.err(try(plotmo(linmod2.trees1)), "plotmo_y returned the wrong length (got 3 but expected 31)") par(org.par) cat0("==linmod.formula(keep=TRUE): change data used to build the model\n") par(mfrow=c(3,3)) trees1 <- trees linmod.trees1.keep <- linmod(Volume~., data=trees1, keep=TRUE) # delete the saved residuals and fitted.values so plotres has to use the saved # call etc. to get the x and y used to build the model, and rely on predict() linmod.trees1.keep$residuals <- NULL linmod.trees1.keep$fitted.values <- NULL pr(linmod.trees1.keep) trees1 <- trees[, 3:1] # change column order in original data pr(linmod.trees1.keep, "change col order") trees1 <- trees[1:3, ] # change number of rows in original data pr(linmod.trees1.keep, "change nbr rows") trees1 <- trees[nrow(tr):1, ] # change row order (but keep same nbr of rows) pr(linmod.trees1.keep, "change row order") colnames(trees1) <- c("x1", "x2", "x3") # change column names in original data pr(linmod.trees1.keep, "change colnames") trees1 <- NULL # original data no longer available pr(linmod.trees1.keep, "trees1=NULL") remove(trees1) pr(linmod.trees1.keep, "remove(trees1)") par(org.par) cat0("==linmod.default: change data used to build the model\n") trees1 <- trees x1 <- trees1[,1:2] y1 <- trees1[,3] linmod.xy <- linmod(x1, y1) # delete the saved residuals and fitted.values so plotres has to use the saved # call etc. to get the x1 and y1 used to build the model, and rely on predict() linmod.xy$residuals <- NULL linmod.xy$fitted.values <- NULL par(mfrow=c(3,3)) pr(linmod.xy) x1 <- trees1[,2:1] # change column order in original x1 pr(linmod.xy, "change col order") x1 <- trees1[1:3, 1:2] # change number of rows in original x1 expect.err(try(pr(linmod.xy, "change nbr rows")), "plotmo_y returned the wrong length (got 31 but expected 3)") # TODO different behaviour to linmod.trees1 cat("call$x1 now refers to the changed x1:\n") # lm has the same problem if called with model=FALSE print(eval(linmod.xy$call$x1)) x1 <- trees1[nrow(tr):1, 1:2] # change row order (but keep same nbr of rows) pr(linmod.xy, "change row order") x1 <- trees1[,1:2] colnames(x1) <- c("x1", "x2") # change column names in original x1 pr(linmod.xy, "change colnames") x1 <- "garbage" expect.err(try(pr(linmod.xy, "x1=\"garbage\"")), "cannot get the original model predictors") x1 <- 1:1000 expect.err(try(pr(linmod.xy, "x1=1:1000")), "ncol(newdata) is 1 but should be 2") x1 <- NULL # original x1 no longer available expect.err(try(pr(linmod.xy, "x1=NULL")), "cannot get the original model predictors") remove(x1) expect.err(try(pr(linmod.xy, "remove(x1)")), "cannot get the original model predictors") # similar to above, but don't delete the saved residuals and fitted.values trees1 <- trees x1 <- trees1[,1:2] y1 <- trees1[,3] linmod.xy <- linmod(x1, y1) x1 <- trees1[1:3, 1:2] # change number of rows in original x1 expect.err(try(plotmo(linmod2.x1)), "object 'linmod2.x1' not found") # TODO error message misleading? par(org.par) cat0("==linmod.default(keep=TRUE): change data used to build the model\n") par(mfrow=c(3,3)) trees1 <- trees x1 <- trees1[,1:2] linmod.xy <- linmod(x1, y1, keep=TRUE) # delete the saved residuals and fitted.values so plotres has to use the saved # call etc. to get the x1 and y1 used to build the model, and rely on predict() linmod.xy$residuals <- NULL linmod.xy$fitted.values <- NULL pr(linmod.xy.keep) x1 <- trees1[, 2:1] # change column order in original x1 pr(linmod.xy.keep, "change col order") x1 <- trees1[1:3, 1:2] # change number of rows in original x1 pr(linmod.xy.keep, "change nbr rows") x1 <- trees1[nrow(tr):1, 1:2] # change row order (but keep same nbr of rows) pr(linmod.xy.keep, "change row order") x1 <- trees1[,1:2] colnames(x1) <- c("x1", "x2") # change column names in original x1 pr(linmod.xy.keep, "change colnames") x1 <- NULL # original x1 no longer available pr(linmod.xy.keep, "x1=NULL") remove(x1) pr(linmod.xy.keep, "remove(x1)") par(org.par) cat("==test processing a model created in a function with local data\n") # pr <- function(model, main=deparse(substitute(model))) # { # plotmo(model, degree1=1, degree2=0, pt.col=2, do.par=FALSE, main=main) # } pr <- function(model, main=deparse(substitute(model))) { plotres(model, which=3, main=main) # which=3 for just the residuals plot } lm.form.func <- function(keep=FALSE) { local.tr <- trees[1:20,] lm(Volume~., data=local.tr, model=keep) } linmod.form.func <- function(keep=FALSE) { local.tr <- trees[1:20,] model <- linmod(Volume~., data=local.tr, keep=keep) # delete the saved residuals and fitted.values so plotres has to use the saved # call etc. to get the x and y used to build the model, and rely on predict() model$residuals <- NULL model$fitted.values <- NULL model } linmod.xy.func <- function(keep) { xx <- trees[1:20,1:2] yy <- trees[1:20,3] model <- linmod(xx, yy, keep=keep) # delete the saved residuals and fitted.values so plotres has to use the saved # call etc. to get the x and y used to build the model, and rely on predict() model$residuals <- NULL model$fitted.values <- NULL model } par(mfrow=c(3,2)) lm.form <- lm.form.func(keep=FALSE) pr(lm.form) lm.form.keep <- lm.form.func(keep=TRUE) pr(lm.form.keep) linmod.form <- linmod.form.func(keep=FALSE) pr(linmod.form) linmod.form.keep <- linmod.form.func(keep=TRUE) pr(linmod.form.keep) linmod.xy <- linmod.xy.func(keep=FALSE) expect.err(try(pr(linmod.xy)), "cannot get the original model predictors") linmod.xy.keep <- linmod.xy.func(keep=TRUE) pr(linmod.xy.keep) par(org.par) # test xlevels (predict with newdata using a string to represent a factor) data(iris) linmod.Sepal.Length <- linmod(Sepal.Length~Species,data=iris) lm.Sepal.Length <- lm(Sepal.Length~Species,data=iris) predict.linmod <- predict(linmod.Sepal.Length, newdata=data.frame(Species="setosa")) predict.lm <- predict(lm.Sepal.Length, newdata=data.frame(Species="setosa")) stopifnot(all.equal(predict.linmod, predict.lm)) source("test.epilog.R") plotmo/inst/slowtests/linmod.methods.R0000644000176200001440000000517613725307660017701 0ustar liggesusers# limod.methods.R: Additional method functions for the linmod example. # # See www.milbo.org/doc/modguide.pdf. # This software may be freely used. variable.names.linmod <- function(object, ...) { stopifnot(inherits(object, "linmod")) stop.if.dot.arg.used(...) names(coef(object)) } case.names.linmod <- function(object, ...) { stopifnot(inherits(object, "linmod")) stop.if.dot.arg.used(...) names(residuals(object)) } nobs.linmod <- function(object, use.fall.back = FALSE, ...) { stopifnot(inherits(object, "linmod")) stop.if.dot.arg.used(...) NROW(object$residuals) } deviance.linmod <- function(object, ...) { stopifnot(inherits(object, "linmod")) stop.if.dot.arg.used(...) sum(residuals(object)^2) } model.frame.linmod <- function(formula, ...) { stopifnot(inherits(formula, "linmod")) if(is.null(formula$terms)) # model built with linmod.default? stop("model.frame cannot be used on linmod models built without a formula") else model.frame.default(formula, ...) } model.matrix.linmod <- function(object, data = NULL, ...) { stopifnot(inherits(object, "linmod")) if(is.null(data)) data <- model.frame.linmod(object) model.matrix.default(object, data = data, ...) } logLik.linmod <- function(object, REML = FALSE, ...) { stopifnot(inherits(object, "linmod")) stop.if.dot.arg.used(...) stopifnot(!REML) # linmod does not save qr hence cannot do REML res <- object$residuals p <- object$rank n <- length(res) w <- rep.int(1, n) n0 <- n val <- .5* (sum(log(w)) - n * (log(2 * pi) + 1 - log(n) + log(sum(w*res^2)))) attr(val, "nall") <- n0 attr(val, "nobs") <- n attr(val, "df") <- p + 1 class(val) <- "logLik" val } estfun.linmod <- function (x, ...) # for sandwich package { stopifnot(inherits(x, "linmod")) stop.if.dot.arg.used(...) xmat <- model.matrix(x) res <- residuals(x) rval <- as.vector(res) * xmat attr(rval, "assign") <- NULL attr(rval, "contrasts") <- NULL return(rval) } plot.linmod <- function(x, main = NULL, ...) # dots are passed to plot() { stopifnot(inherits(x, "linmod")) call.as.char <- paste0(deparse(x$call, control = NULL, nlines = 5), sep = " ", collapse = " ") plot(fitted(x), residuals(x), xlab = "Fitted values", ylab = "Residuals", main = if(is.null(main)) substr(call.as.char, 1, 50) else main, ...) smooth <- lowess(fitted(x), residuals(x), f = .5) lines(smooth$x, smooth$y, col = 2) } plotmo/inst/slowtests/test.pre.Rout.save0000644000176200001440000001275614563614021020201 0ustar liggesusers> # test.pre.R: test the "pre" package with plotmo and plotres > > source("test.prolog.R") > library(pre) > library(plotmo) Loading required package: Formula Loading required package: plotrix > library(earth) # for ozone1 > options(warn=1) # print warnings as they occur > data(airquality) > airq <- airquality[complete.cases(airquality), (c("Ozone", "Wind", "Temp"))] > # prevent confusion caused by integer rownames which don't match row numbers > rownames(airq) <- NULL > airq <- airq[1:50, ] # small set of data for quicker test > > coef.glmnet <- glmnet:::coef.glmnet # TODO workaround required for glmnet 3.0 > predict.cv.glmnet <- glmnet:::predict.cv.glmnet > > set.seed(2018) > pre.mod <- pre(Ozone~., data=airq, ntrees=10) # ntrees=10 for faster test > plotres(pre.mod) # variable importance and residual plots > plotres(pre.mod, which=3, main="pre.mod residuals") # which=3 for just the residual vs fitted plot > plotmo(pre.mod) # plot model surface with background variables held at their medians plotmo grid: Wind Temp 10.3 75 > > # sanity check: compare model surface to to randomForest > # (commented out to save test time) > # > # library(randomForest) > # set.seed(2018) > # rf.mod <- randomForest(Ozone~., data=airq) > # plotmo(rf.mod) > > # compare singleplot and plotmo > > par(mfrow=c(2,2)) # 4 plots per page > > singleplot(pre.mod, varname="Temp", main="Temp\n(singleplot)") > > plotmo(pre.mod, + pmethod="partdep", # plot partial dependence plot, + degree1="Temp", degree2=0, # plot only Temp, no degree2 plots + do.par=FALSE, # don't automatically set par(), use above par(mfrow) + main="Temp\n(plotmo partdep)") calculating partdep for Temp > > # test penalty.par.val="lambda.min" > singleplot(pre.mod, varname="Temp", + main="penalty.par.val=lambda.min\n(singleplot)", + penalty.par.val="lambda.min") > > plotmo(pre.mod, + pmethod="partdep", + degree1="Temp", degree2=0, + do.par=FALSE, + main="penalty.par.val=lambda.min\n(plotmo partdep)", + predict.penalty.par.val="lambda.min") # use "predict." to pass it on to predict.pre calculating partdep for Temp > > par(org.par) > > # compare pairplot and plotmo > > par(mfrow=c(2,3)) # 6 plots per page > > pairplot(pre.mod, c("Temp", "Wind"), main="pairplot") Loading required namespace: interp > plotmo(pre.mod, main="plotmo partdep", + pmethod="partdep", + degree1=0, degree2="Temp", + do.par=FALSE) calculating partdep for Wind:Temp 01234567890 > > # Compare to pmethod="apartdep". An approximate partdep plot is > # faster than a full partdep plot (plotmo vignette Section 9.2). > > plotmo(pre.mod, main="plotmo apartdep", + pmethod="apartdep", + degree1=0, degree2="Temp", + do.par=FALSE) calculating apartdep for Wind:Temp 01234567890 > > # plot contour and image plots with plotmo > > plotmo(pre.mod, type2="contour", + degree1=0, degree2="Temp", do.par=FALSE) > > plotmo(pre.mod, type2="image", + degree1=0, degree2="Temp", do.par=FALSE) > > par(org.par) > > # test gpe models > > set.seed(2018) > gpe.mod <- gpe(Ozone~., data=airq, + base_learners=list(gpe_linear(), gpe_trees(), gpe_earth())) > plotmo(gpe.mod) # by default no degree2 plots because importance(gpe) not available plotmo grid: Wind Temp 10.3 75 > plotmo(gpe.mod, all2=TRUE, # force degree2 plot(s) by specifying all2=TRUE + persp.ticktype="detailed", persp.nticks=2) # optional (these get passed on to persp) plotmo grid: Wind Temp 10.3 75 > plotmo(gpe.mod, degree1=0, degree2=c("Wind", "Temp"), SHOWCALL=TRUE) # explictly specify degree2 plot > # which=3 below for only the residuals-vs-fitted plot > # optional info=TRUE to plot some extra information (RSq etc.) > plotres(gpe.mod, which=3, info=TRUE, main="gpe.mod residuals") > > # multinomial response > > set.seed(2018) > pre.iris <- pre(Species~., data=iris, ntrees=10) # ntrees=10 for faster testoptions(warn=2) # treat warnings as errors > options(warn=2) # treat warnings as errors > expect.err(try(plotmo(pre.iris)), "Defaulting to nresponse=1, see above messages") predict.pre[3,3]: setosa versicolor virginica 1 0.9746686 0.01299582 0.01233561 2 0.9746686 0.01299582 0.01233561 3 0.9750720 0.01300120 0.01192680 predict.pre returned multiple columns (see above) but nresponse is not specified Use the nresponse argument to specify a column. Example: nresponse=2 Example: nresponse="versicolor" Error : (converted from warning) Defaulting to nresponse=1, see above messages Got expected error from try(plotmo(pre.iris)) > options(warn=1) # print warnings as they occur > plotmo(pre.iris, all2=TRUE, nresponse="virginica", trace=1) importance: Petal.Length Petal.Width stats::predict(pre.object, data.frame[3,4], type="response") stats::fitted(object=pre.object) fitted() was unsuccessful, will use predict() instead assuming "Species" in the model.frame is the response, because terms(object) did not return the terms nresponse=3 but for plotmo_y using nresponse=1 because ncol(y) == 1 assuming "Species" in the model.frame is the response, because terms(object) did not return the terms got model response from model.frame(Species ~ ., data=object$data, na.action="na.fail") plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 5.8 3 4.35 1.3 > > source("test.epilog.R") plotmo/inst/slowtests/test.plotmo.args.Rout.save0000644000176200001440000001725314563614021021655 0ustar liggesusers> # test.plotmo.args..R: test dot and other argument handling in plotmo > > source("test.prolog.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix > data(ozone1) > options(warn=1) # print warnings as they occur > > options(warn=2) # treat warnings as errors > lm.mod <- lm(O3~wind, data=ozone1) > > expect.err(try(plotmo(lm.mod, se=2, leve=.95)), "plotmo's 'se' argument is deprecated, please use 'level' instead") Error : plotmo's 'se' argument is deprecated, please use 'level' instead Got expected error from try(plotmo(lm.mod, se = 2, leve = 0.95)) > > expect.err(try(plotmo(lm.mod, se=T)), "plotmo's 'se' argument is deprecated, please use 'level=.95' instead") Error : (converted from warning) plotmo's 'se' argument is deprecated, please use 'level=.95' instead Got expected error from try(plotmo(lm.mod, se = T)) > > expect.err(try(plotmo(lm.mod, se=.8)), "plotmo's 'se' argument is deprecated, please use 'level=.95' instead") Error : plotmo's 'se' argument is deprecated, please use 'level=.95' instead Got expected error from try(plotmo(lm.mod, se = 0.8)) > > expect.err(try(plotmo(lm.mod, level=2)), "level=2 is out of range, try level=.95") Error : level=2 is out of range, try level=.95 Got expected error from try(plotmo(lm.mod, level = 2)) > > oz2 <- ozone1[1:40,] > set.seed(2015) > a <- earth(O3~temp+wind, dat=oz2, deg=2, nk=21, ncr=3, nfo=3, varmod.me="lm") > > expect.err(try(plotmo(a, lw=2, trace=1, thresh=.9, SHOWCALL=TRUE)), "predict.earth ignored argument 'lw'") stats::predict(earth.object, NULL, type="response", lw=2, thresh=0.9) Error : (converted from warning) predict.earth ignored argument 'lw' Got expected error from try(plotmo(a, lw = 2, trace = 1, thresh = 0.9, SHOWCALL = TRUE)) > > options(warn=1) > > # test col.response and friends > plotmo(a, col.response=2, pch.response=c(1, 2, 20), type2="co", SHOWCALL=TRUE) # pch.response tests back compat plotmo grid: temp wind 53.5 4 > plotmo(a, pt.col=c(1,2,3), pt.pch=c(1, 2, 20), type2="im", SHOWCALL=TRUE) plotmo grid: temp wind 53.5 4 > plotmo(a, pt.col=c(1,2,3), pt.pch=paste(1:nrow(oz2)), pt.cex=.8, type2="im", do.par=2, SHOWCALL=TRUE) plotmo grid: temp wind 53.5 4 > plotmo(a, pt.col=c(1,2,3), pt.pch=paste(1:nrow(oz2)), pt.cex=.8, type2="co", degree1=0, do.par=F) Warning: plotmo: nothing to plot > par(org.par) > plotmo(a, col=2, SHOWCALL=TRUE) # will cause red response points plotmo grid: temp wind 53.5 4 > plotmo(a, pt.col=4, col=3, persp.col="pink", SHOWCALL=TRUE) # col now goes to lines plotmo grid: temp wind 53.5 4 > > # test cex and nrug and smooth > plotmo(a, cex=.8, SHOWCALL=TRUE, nrug=-1, rug.col=2, rug.lwd=1, smooth.col=3, + bty="n", col.lab="darkorange", xlab="an x label", cex.lab=1.2) # esoteric, but they work plotmo grid: temp wind 53.5 4 > plotmo(a, SHOWCALL=TRUE, density.col=2, density.lty=2, smooth.col=3, smooth.f=.3, col="lightblue") plotmo grid: temp wind 53.5 4 > plotmo(a, cex=1.2, SHOWCALL=TRUE, nrug="density") plotmo grid: temp wind 53.5 4 > > # test caption, grid, interval options > plotmo(a, caption.col=3, caption.font=2, grid.col="pink", + level=.8, SHOWCALL=TRUE) plotmo grid: temp wind 53.5 4 > plotmo(a, caption.col=2, caption.font=2, caption.cex=.8, grid.col=TRUE, bty="n", + level=.8, level.shade="lightblue", level.shade2="red", + grid.lty=3, grid.lwd=4, grid.nx=NA, SHOWCALL=TRUE) plotmo grid: temp wind 53.5 4 > > # test overall plot args handled by par() and graphics args outside do.par > par(mfrow=c(2,2), mar = c(3,3,3,1), mgp = c(1.5,.5,0), oma=c(0,0,4,0)) > par(col.main="#456789") > old.mar <- par("mar") > old.mfcol <- par("mfcol") > cat("before par: cex=", par("cex"), " col.main=", par("col.main"), + " col.axis=", par("col.axis"), " mar=", par("mar"), " mfcol=", par("mfcol"), + "\n", sep="") before par: cex=0.83 col.main=#456789 col.axis=black mar=3331 mfcol=22 > plotmo(a, mfcol=c(2,3), cex.main=1.4, oma=c(5,5,5,5), SHOWCALL=TRUE) plotmo grid: temp wind 53.5 4 > plotmo(a, caption="no cex") plotmo grid: temp wind 53.5 4 > plotmo(a, cex=1, caption="cex=1, plot should be identical to previous page") plotmo grid: temp wind 53.5 4 > plotmo(a, cex=1.2, caption="cex=1.2") plotmo grid: temp wind 53.5 4 > plotmo(a, do.par=FALSE, degree2=0, degree1=1, main="do.par=FALSE no cex", caption="a test graphics args with do.par=FALSE") plotmo grid: temp wind 53.5 4 > plotmo(a, do.par=FALSE, degree2=0, degree1=1, cex=1, main="do.par=FALSE cex=1") plotmo grid: temp wind 53.5 4 > plotmo(a, do.par=FALSE, degree2=0, degree1=1, cex=.8, main="do.par=FALSE cex=.8") plotmo grid: temp wind 53.5 4 > plotmo(a, do.par=FALSE, degree2=0, degree1=1, cex=1.1, xlab="xlab", col.main=2, col.axis="blue", col.lab=3, font.lab=2, + main="do.par=FALSE cex=1.1, col.main=2\ncol.axis=\"blue\", col.lab=3, font.lab=2") plotmo grid: temp wind 53.5 4 > plotmo(a, do.par=FALSE, degree1=1, degree2=1, persp.ticktype="d", + main="do.par=FALSE persp.ticktype=\"d\"") Warning: 'degree2' specified but no degree2 plots (maybe use all2=TRUE?) plotmo grid: temp wind 53.5 4 > # all of these should have been restored > cat("after par: cex=", par("cex"), " col.main=", par("col.main"), + " col.axis=", par("col.axis"), " mar=", par("mar"), " mfcol=", par("mfcol"), + "\n", sep="") after par: cex=0.83 col.main=#456789 col.axis=black mar=3331 mfcol=22 > stopifnot(par("col.main") == "#456789") > stopifnot(par("mar") == old.mar) > stopifnot(par("mfcol") == old.mfcol) > par(col.main=1) > > # test aliasing of col with other args, and back compat of col.degree1 vs degree1.col > data(etitanic) > a20 <- earth(pclass ~ ., data=etitanic, degree=2) > plotmo(a20, nresponse=1, col=2, col.degree1=3, persp.col="pink", SHOWCALL=1, degree1=1:2, degree2=1:2) plotmo grid: survived sex age sibsp parch 0 male 28 0 0 > plotmo(a20, nresponse=1, lty=2, persp.lty=1, SHOWCALL=1, degree1=1:2, degree2=1:2) plotmo grid: survived sex age sibsp parch 0 male 28 0 0 > > # test "prednames." with a long predictor name > data(trees) > trees.with.long.predname <- trees > trees.with.long.predname$a_quite_long_variable_name <- trees.with.long.predname$Girth > trees.with.long.predname$Girth <- NULL > mod <- earth(Volume~.,data=trees.with.long.predname) > par(mfrow=c(3,2), mar = c(3,3,3,1), mgp = c(1.5,.5,0), oma=c(0,0,4,0)) > plotmo(mod, do.par=FALSE) plotmo grid: Height a_quite_long_variable_name 76 12.9 > plotmo(mod, do.par=FALSE, prednames.abbreviate=FALSE) plotmo grid: Height a_quite_long_variable_name 76 12.9 > expect.err(try(plotmo(mod, do.par=FALSE, prednames.abbreviate=c(1,2))), "the prednames.abbreviate argument is not FALSE, TRUE, 0, or 1") Error : the prednames.abbreviate argument is not FALSE, TRUE, 0, or 1 Got expected error from try(plotmo(mod, do.par = FALSE, prednames.abbreviate = c(1, 2))) > plotmo(mod, do.par=FALSE, prednames.minlength=3) plotmo grid: Height a_quite_long_variable_name 76 12.9 > > source("test.epilog.R") plotmo/inst/slowtests/test.gbm.R0000644000176200001440000006241014664454304016473 0ustar liggesusers# test.gbm.R: gbm tests for plotmo and plotres source("test.prolog.R") library(gbm) library(rpart.plot) # for ptitanic, want data with NAs for testing library(plotmo) data(ptitanic) cat("--- distribution=\"gaussian\", formula interface ----------------------------------\n") set.seed(2016) ptit <- ptitanic[sample(1:nrow(ptitanic), size=70), ] # small data for fast test set.seed(2016) # # TODO bug in gbm: following causes error: survived is not of type numeric, ordered, or factor # ptit$survived <- ptit$survived == "survived" ptit <- ptit[!is.na(ptit$age), ] train.frac <- .8 set.seed(2016) gbm.gaussian <- gbm(age~., data=ptit, train.frac=train.frac, distribution="gaussian", n.trees=50, shrinkage=.1, keep.data=FALSE) expect.err(try(plotres(gbm.gaussian)), "use keep.data=TRUE in the call to gbm") set.seed(2016) gbm.gaussian <- gbm(age~., data=ptit, train.frac=train.frac, distribution="gaussian", n.trees=50, shrinkage=.1) par(mfrow=c(2,2), mar=c(3,3,4,1)) w1 <- plotres(gbm.gaussian, which=1, do.par=FALSE, w1.smooth=TRUE, w1.main="gbm.gaussian") cat("w1 plot for gbm.gaussian returned (w1.smooth=TRUE):\n") print(w1) plot(0, 0) # dummy plot w3 <- plotres(gbm.gaussian, which=3, do.par=FALSE, info=TRUE, smooth.col=0, col=ptit$sex, # ylim=c(-40,40), wmain="nresponse=1") # compare to manual residuals iused <- 1:(train.frac * nrow(ptit)) y <- ptit$age[iused] n.trees <- plotmo:::gbm.n.trees(gbm.gaussian) # TODO following fails in the new version of gbm (version 2.2) (you have to provide newdata) # yhat <- predict(gbm.gaussian, type="response", n.trees=n.trees) yhat <- predict(gbm.gaussian, newdata=ptit, type="response", n.trees=n.trees) yhat <- yhat[iused] plot(yhat, y - yhat, col=ptit$sex[iused], main="manual gaussian residuals", pch=20, ylim=c(-40,40)) abline(h=0, col="gray") stopifnot(all(yhat == w3$x)) stopifnot(all(y - yhat == w3$y)) par(org.par) w1 <- plotres(gbm.gaussian, predict.n.trees=13, w1.grid.col=1, trace=1, SHOWCALL=TRUE, w1.smooth=TRUE, w1.main="predict.n.trees=13 w1.grid.col=1") cat("second w1 plot for gbm.gaussian returned (w1.smooth=TRUE):\n") print(w1) plotmo(gbm.gaussian, trace=-1, SHOWCALL=TRUE) # plotmo(gbm.gaussian, trace=-1, all1=TRUE, SHOWCALL=TRUE) # plotmo(gbm.gaussian, trace=-1, all2=TRUE, SHOWCALL=TRUE) # test color argument par(mfrow=c(2,2), mar=c(3,3,4,1)) plotres(gbm.gaussian, which=1) title("test color argument") plotres(gbm.gaussian, which=1, w1.col=c(1,2,3,0)) plotres(gbm.gaussian, which=1, w1.col=c(1,0,0,4), w1.legend.x=40, w1.legend.y=.3) plotres(gbm.gaussian, which=1, w1.col=c(2,3,4,1), w1.legend.x="topright") par(org.par) par(mfrow=c(2,2), mar=c(3,3,4,1)) plot_gbm(gbm.gaussian) title("test plot_gbm") w1 <- plot_gbm(gbm.gaussian, col=c(1,2,3,0), grid.col=1, smooth=TRUE, main="col=c(1,2,3,0), grid.col=1") cat("third w1 plot for gbm.gaussian returned (smooth=TRUE):\n") print(w1) par(org.par) # test xlim and ylim par(mfrow=c(2,3), mar=c(3,3,4,1)) plot_gbm(gbm.gaussian, main="test xlim and ylim default") plot_gbm(gbm.gaussian, ylim=NULL, main="ylim=NULL") plot_gbm(gbm.gaussian, xlim=c(5, 50), main="xlim=c(5, 50)") plot_gbm(gbm.gaussian, ylim=c(100, 250), main="ylim=c(100, 250)") plot_gbm(gbm.gaussian, xlim=c(10, 25), ylim=c(150, 170), main="xlim=c(10, 25), ylim=c(150, 170)") plot_gbm(gbm.gaussian, xlim=c(-10, 40), ylim=c(-10, 300), legend.x=NA, main="xlim=c(-10, 40), ylim=c(-10, 300)\nlegend.x=NA") par(org.par) # test the smooth argument par(mfrow=c(3,3), mar=c(3,3,4,1)) imin <- plot_gbm(gbm.gaussian, main="smooth=default") imin.default <- imin cat("smooth=default imin=c(", imin[1], ",", imin[2], ",", imin[3], ",", imin[4], ")\n", sep="") imin <- plot_gbm(gbm.gaussian, smooth=c(1,0,0,0), main="smooth=c(1,0,0,0)") cat("smooth=c(1,0,0,0) imin=c(", imin[1], ",", imin[2], ",", imin[3], ",", imin[4], ")\n", sep="") imin <- plot_gbm(gbm.gaussian, smooth=c(0,1,0,0), main="smooth=c(0,1,0,0)") cat("smooth=c(0,1,0,0) imin=c(", imin[1], ",", imin[2], ",", imin[3], ",", imin[4], ")\n", sep="") imin <- plot_gbm(gbm.gaussian, smooth=c(0,0,1,0), main="smooth=c(0,0,1,0)") cat("smooth=c(0,0,1,0) imin=c(", imin[1], ",", imin[2], ",", imin[3], ",", imin[4], ")\n", sep="") imin <- plot_gbm(gbm.gaussian, smooth=c(0,0,0,1), main="smooth=c(0,0,0,1)\nsame as default") cat("smooth=c(0,0,0,1) imin=c(", imin[1], ",", imin[2], ",", imin[3], ",", imin[4], ")\n", sep="") imin <- plot_gbm(gbm.gaussian, smooth=c(0,0,0,0), main="smooth=c(0,0,0,0)") cat("smooth=c(0,0,0,0) imin=c(", imin[1], ",", imin[2], ",", imin[3], ",", imin[4], ")\n", sep="") imin <- plot_gbm(gbm.gaussian, smooth=c(0,0,1,1), main="smooth=c(0,0,1,1)") cat("smooth=c(0,0,1,1) imin=c(", imin[1], ",", imin[2], ",", imin[3], ",", imin[4], ")\n", sep="") imin <- plot_gbm(gbm.gaussian, smooth=1, main="smooth=1") # gets recycled cat("smooth=1 imin=c(", imin[1], ",", imin[2], ",", imin[3], ",", imin[4], ")\n", sep="") imin.smooth <- imin imin.noplot <- plot_gbm(gbm.gaussian, col=0) # will not be plotted print(imin.default) print(imin.noplot) stopifnot(identical(imin.default, imin.noplot)) imin.noplot <- plot_gbm(gbm.gaussian, col=0, smooth=1) # will not be plotted print(imin.smooth) print(imin.noplot) stopifnot(identical(imin.smooth, imin.noplot)) par(org.par) cat("--- distribution=\"gaussian\", glm.fit interface ----------------------------------\n") set.seed(2016) ptit <- ptitanic[sample(1:nrow(ptitanic), size=70), ] set.seed(2016) ptit <- ptit[!is.na(ptit$age), ] train.frac <- .8 set.seed(2016) gbm.gaussian.fit <- gbm.fit(ptit[,-4], ptit[,4], nTrain=floor(train.frac * nrow(ptit)), distribution="gaussian", verbose=FALSE, n.trees=50, shrinkage=.1) par(mfrow=c(2,2), mar=c(3,3,4,1)) w1 <- plotres(gbm.gaussian.fit, which=1, do.par=FALSE, w1.smooth=TRUE, w1.main="gbm.gaussian.fit") cat("w1 plot for gbm.gaussian.fit returned (w1.smooth=TRUE):\n") print(w1) plot(0, 0) # dummy plot w3 <- plotres(gbm.gaussian.fit, which=3, do.par=FALSE, info=TRUE, trace=0, smooth.col=0, col=ptit$sex, # ylim=c(-40,40), wmain="nresponse=1") # compare to manual residuals iused <- 1:(train.frac * nrow(ptit)) y.fit <- ptit$age[iused] n.trees <- plotmo:::gbm.n.trees(gbm.gaussian.fit) # TODO following fails in the new version of gbm (version 2.2) (you have to provide newdata) # yhat.fit <- predict(gbm.gaussian.fit, type="response", n.trees=n.trees) yhat.fit <- predict(gbm.gaussian.fit, newdata=ptit[,-4], type="response", n.trees=n.trees) yhat.fit <- yhat.fit[iused] # plot(yhat.fit, y.fit - yhat.fit, # col=ptit$sex[iused], main="manual gaussian residuals\n(TODO gbm.fit don't match)", # pch=20, ylim=c(-40,40)) # abline(h=0, col="gray") # --- TODO known issue, these fail --- # compare to formual interface # stopifnot(all(yhat.fit == yhat)) stopifnot(all(y.fit == y)) # # sanity check # stopifnot(all(yhat.fit == w3$x)) # stopifnot(all(y.fit - yhat.fit == w3$y.fit)) plotmo(gbm.gaussian.fit, trace=-1, SHOWCALL=TRUE) par(org.par) cat("--- distribution=\"laplace\" ----------------------------------\n") set.seed(2016) ptit <- ptitanic[sample(1:nrow(ptitanic), size=70), ] ptit <- ptit[!is.na(ptit$age), ] ptit$survived <- ptit$parch <- ptit$sex <- NULL train.frac <- .8 set.seed(2016) gbm.laplace <- gbm(age~., data=ptit, train.frac=train.frac, distribution="laplace", n.trees=100, shrinkage=.1) par(mfrow=c(2,2), mar=c(3,3,4,1)) w1 <- plotres(gbm.laplace, which=1:2, do.par=FALSE, w1.smooth=TRUE, w1.main="gbm.laplace") cat("w1 plot for gbm.laplace returned (w1.smooth=TRUE):\n") print(w1) w3 <- plotres(gbm.laplace, which=3, do.par=FALSE, info=TRUE) # compare to manual residuals iused <- 1:(train.frac * nrow(ptit)) y <- ptit$age[iused] n.trees <- plotmo:::gbm.n.trees(gbm.laplace) # TODO following fails in the new version of gbm (version 2.2) (you have to provide newdata) # yhat <- predict(gbm.laplace, type="response", n.trees=n.trees) yhat <- predict(gbm.laplace, newdata=ptit, type="response", n.trees=n.trees) yhat <- yhat[iused] plot(yhat, y - yhat, main="manual laplace residuals", pch=20, ylim=c(-40,40)) abline(h=0, col="gray") stopifnot(all(yhat == w3$x)) stopifnot(all(y - yhat == w3$y)) plotmo(gbm.laplace, trace=-1, SHOWCALL=TRUE) par(org.par) # # TODO commented out because gives random slightly different results per invocation # cat("--- distribution=\"tdist\" ----------------------------------\n") # # set.seed(2016) # ptit <- ptitanic[sample(1:nrow(ptitanic), size=70), ] # ptit <- ptit[!is.na(ptit$age), ] # ptit$survived <- ptit$parch <- ptit$sex <- NULL # train.frac <- .8 # set.seed(2016) # gbm.tdist <- gbm(age~., data=ptit, train.frac=train.frac, # distribution="tdist", # n.trees=100, shrinkage=.1) # par(mfrow=c(2,2), mar=c(3,3,4,1)) # set.seed(2016) # w1 <- plotres(gbm.tdist, which=1:2, do.par=FALSE, # w1.main="gbm.tdist") # # cat("w1 plot for gbm.tdist returned (w1.smooth=default):\n") # print(w1) # # set.seed(2016) # w3 <- plotres(gbm.tdist, which=3, do.par=FALSE, info=TRUE) # # # compare to manual residuals # iused <- 1:(train.frac * nrow(ptit)) # y <- ptit$age[iused] # n.trees <- plotmo:::gbm.n.trees(gbm.tdist) # # TODO following fails in the new version of gbm (version 2.2) (you have to provide newdata) # # yhat <- predict(gbm.tdist, type="response", n.trees=n.trees) # yhat <- predict(gbm.tdist, newdata=ptit, type="response", n.trees=n.trees) # yhat <- yhat[iused] # plot(yhat, y - yhat, # main="manual tdist residuals", # pch=20, ylim=c(-40,40)) # abline(h=0, col="gray") # stopifnot(all(yhat == w3$x)) # stopifnot(all(y - yhat == w3$y)) # plotmo(gbm.tdist, trace=-1, SHOWCALL=TRUE) # par(org.par) cat("--- distribution=\"bernoulli\" ----------------------------------\n") set.seed(2016) ptit <- ptitanic[sample(1:nrow(ptitanic), size=80), ] ptit$survived <- as.numeric(ptit$survived == "survived") temp <- ptit$pclass # put pclass at the end so can check ordering of importances ptit$pclass <- NULL ptit$pclass <- factor(as.numeric(temp), labels=c("first", "second", "third")) train.frac <- .9 set.seed(2016) gbm.bernoulli <- gbm(survived~., data=ptit, train.frac=train.frac, distribution="bernoulli", n.trees=100, shrinkage=.1, cv.folds=3) par(mfrow=c(2,2)) par(mar=c(3.5, 3, 2, 0.5)) # small margins and text to pack figs in par(mgp=c(1.5, .4, 0)) # squash axis annotations w1 <- plotres(gbm.bernoulli, which=c(1,4), col=ptit$survived+2, trace=0, do.par=FALSE, w1.main="gbm.bernoulli") cat("w1 plot for gbm.bernoulli with cv.folds=3 returned:\n") print(w1) w3 <- plotres(gbm.bernoulli, which=3, predict.n.trees=40, ylim=c(-.6, 1), xlim=c(.1, .6), col=ptit$sex, trace=0, do.par=FALSE, smooth.col=0) # compare to manual residuals iused <- 1:(train.frac * nrow(ptit)) y <- ptit$survived[iused] # TODO following fails in the new version of gbm (version 2.2) (you have to provide newdata) # yhat <- predict(gbm.bernoulli, type="response", n.trees=40) yhat <- predict(gbm.bernoulli, newdata=ptit, type="response", n.trees=40) yhat <- yhat[iused] plot(yhat, y - yhat, col=ptit$sex, main="manual bernoulli residuals", pch=20, cex=1, ylim=c(-.6, 1), xlim=c(.1, .6)) abline(h=0, col="gray") stopifnot(all(yhat == w3$x)) stopifnot(all(y - yhat == w3$y)) par(org.par) plotmo(gbm.bernoulli, do.par=2) print(summary(gbm.bernoulli)) # will also plot par(org.par) cat("--- distribution=\"huberized\" ----------------------------------\n") set.seed(2016) ptit <- ptitanic[sample(1:nrow(ptitanic), size=100), ] ptit$survived <- as.numeric(ptit$survived == "survived") ptit$sibsp <- ptit$parch <- ptit$pclass <- NULL train.frac <- 1 set.seed(2016) gbm.huberized <- gbm(survived~., data=ptit, train.frac=train.frac, distribution="huberized", n.trees=200, shrinkage=.1) par(mfrow=c(2,2)) par(mar=c(3.5, 3, 2, 0.5)) # small margins and text to pack figs in par(mgp=c(1.5, .4, 0)) # squash axis annotations w1 <- plotres(gbm.huberized, which=c(1,4), col=ptit$survived+2, trace=0, do.par=FALSE, w1.main="gbm.huberized") cat("w1 plot for gbm.huberized returned (smooth=default):\n") print(w1) # TODO huberized residuals look weird w3 <- plotres(gbm.huberized, which=3, predict.n.trees=40, col=ptit$sex, trace=0, do.par=FALSE, smooth.col=0) # compare to manual residuals iused <- 1:(train.frac * nrow(ptit)) y <- ptit$survived[iused] # TODO following fails in the new version of gbm (version 2.2) (you have to provide newdata) # yhat <- predict(gbm.huberized, type="response", n.trees=40) yhat <- predict(gbm.huberized, newdata=ptit, type="response", n.trees=40) yhat <- yhat[iused] plot(yhat, y - yhat, col=ptit$sex, ylim=c(-2.5, 2.5), main="manual huberized residuals", pch=20) abline(h=0, col="gray") stopifnot(all(yhat == w3$x)) stopifnot(all(y - yhat == w3$y)) par(org.par) plotmo(gbm.huberized, do.par=2) print(summary(gbm.huberized)) # will also plot par(org.par) cat("--- distribution=\"adaboost\" ----------------------------------\n") set.seed(2016) ptit <- ptitanic[sample(1:nrow(ptitanic), size=100), ] ptit$survived <- as.numeric(ptit$survived == "survived") ptit$sibsp <- ptit$parch <- ptit$pclass <- NULL train.frac <- .8 set.seed(2016) gbm.adaboost <- gbm(survived~., data=ptit, train.frac=train.frac, distribution="adaboost", n.trees=150, shrinkage=.01) par(mfrow=c(2,2)) par(mar=c(3.5, 3, 2, 0.5)) # small margins and text to pack figs in par(mgp=c(1.5, .4, 0)) # squash axis annotations w1 <- plotres(gbm.adaboost, which=c(1,4), col=ptit$survived+2, trace=0, do.par=FALSE, w1.main="gbm.adaboost") cat("w1 plot for gbm.adaboost returned (smooth=default):\n") print(w1) w3 <- plotres(gbm.adaboost, which=3, predict.n.trees=40, col=ptit$sex, trace=0, do.par=FALSE, smooth.col=0) # compare to manual residuals iused <- 1:(train.frac * nrow(ptit)) y <- ptit$survived[iused] # TODO following fails in the new version of gbm (version 2.2) (you have to provide newdata) # yhat <- predict(gbm.adaboost, type="response", n.trees=40) yhat <- predict(gbm.adaboost, newdata=ptit, type="response", n.trees=40) yhat <- yhat[iused] plot(yhat, y - yhat, col=ptit$sex, main="manual adaboost residuals", pch=20) abline(h=0, col="gray") stopifnot(all(yhat == w3$x)) stopifnot(all(y - yhat == w3$y)) par(org.par) plotmo(gbm.adaboost, do.par=2) print(summary(gbm.adaboost)) # will also plot par(org.par) # test gbm multinomial model, also test very small number of trees in plot_gbm data(iris) set.seed(2016) gbm.iris <- gbm(Species~., data=iris, distribution="multinomial", n.tree=5) expect.err(try(plotres(gbm.iris)), "gbm distribution=\"multinomial\" is not yet supported") expect.err(try(plotmo(gbm.iris)), "gbm distribution=\"multinomial\" is not yet supported") plot_gbm(gbm.iris) # TODO following fails in the new version of gbm (version 2.2) # (distribution "multinomial" is no longer supported) # # cat("--- distribution=\"multinomial\" ----------------------------------\n") # # set.seed(2016) # ptit <- ptitanic[sample(1:nrow(ptitanic), size=500), ] # set.seed(2016) # gbm.multinomial <- gbm(pclass~., # data=ptit, train.frac=.7, # distribution="multinomial", # n.trees=100, shrinkage=.1) # # w1 <- plot_gbm(gbm.multinomial, main="gbm.multinomial", smooth=T) # cat("plot_gbm for gbm.multinomial returned (smooth=TRUE):\n") # print(w1) # # expect.err(try(plotres(gbm.multinomial)), # "gbm distribution=\"multinomial\" is not yet supported") # # expect.err(try(plotmo(gbm.multinomial)), # "gbm distribution=\"multinomial\" is not yet supported") # cat("--- gbmt distribution=\"Gaussian\", formula interface ----------------------------------\n") # # set.seed(2016) # ptit <- ptitanic[sample(1:nrow(ptitanic), size=70), ] # small data for fast test # set.seed(2016) # # # TODO bug in gbm: following causes error: survived is not of type numeric, ordered, or factor # # ptit$survived <- ptit$survived == "survived" # ptit <- ptit[!is.na(ptit$age), ] # # TODO change this to build same model as gbm.gaussian # train_params <- # training_params(num_trees = 50, # shrinkage = 0.1, # bag_fraction = 0.5, # num_train = round(.8 * nrow(ptit))) # par(mfrow=c(2,2), mar=c(3,3,4,1)) # set.seed(2016) # gbmt.gaussian <- gbmt(age~., data=ptit, # distribution=gbm_dist("Gaussian"), # train_params = train_params, # is_verbose = FALSE) # expect.err(try(plotres(gbmt.gaussian)), # "use keep.data=TRUE in the call to gbm") # set.seed(2016) # gbmt.gaussian <- gbmt(age~., data=ptit, # distribution=gbm_dist("Gaussian"), # train_params = train_params, # is_verbose = FALSE, keep_gbm_data=TRUE) # w1 <- plotres(gbmt.gaussian, which=1, do.par=FALSE, w1.smooth=TRUE, # w1.main="gbmt.gaussian") # cat("w1 plot for gbmt.gaussian returned (w1.smooth=TRUE):\n") # print(w1) # plot(0, 0) # dummy plot # set.seed(2016) # w3 <- plotres(gbmt.gaussian, which=3, do.par=FALSE, info=TRUE, # smooth.col=0, col=ptit$sex, # ylim=c(-40,40), # wmain="nresponse=1") # # # compare to manual residuals # iused <- 1:(train.frac * nrow(ptit)) # y <- ptit$age[iused] # n.trees <- plotmo:::gbm.n.trees(gbmt.gaussian) # # TODO following fails in the new version of gbm (version 2.2) (you have to provide newdata) # # yhat <- predict(gbmt.gaussian, type="response", n.trees=n.trees) # yhat <- predict(gbmt.gaussian, newdata=ptit, type="response", n.trees=n.trees) # yhat <- yhat[iused] # plot(yhat, y - yhat, # col=ptit$sex[iused], main="manual gaussian residuals", # pch=20, ylim=c(-40,40)) # abline(h=0, col="gray") # stopifnot(all(yhat == w3$x)) # stopifnot(all(y - yhat == w3$y)) # par(org.par) # # w1 <- plotres(gbmt.gaussian, predict.n.trees=13, w1.grid.col=1, trace=1, SHOWCALL=TRUE, # w1.smooth=TRUE, # w1.main="predict.n.trees=13 w1.grid.col=1") # cat("second w1 plot for gbmt.gaussian returned (w1.smooth=TRUE):\n") # print(w1) # plotmo(gbmt.gaussian, trace=-1, SHOWCALL=TRUE) # # par(org.par) # # cat("--- distribution=\"bernoulli\" ----------------------------------\n") # # set.seed(2016) # ptit <- ptitanic[sample(1:nrow(ptitanic), size=80), ] # ptit$survived <- ptit$survived == "survived" # temp <- ptit$pclass # put pclass at the end so can check ordering of importances # ptit$pclass <- NULL # ptit$pclass <- factor(as.numeric(temp), labels=c("first", "second", "third")) # # TODO change this to build same model as gbm.bernoulli # train_params <- # training_params(num_trees = 100, # shrinkage = 0.1, # bag_fraction = 0.5, # num_train = round(.8 * nrow(ptit))) # set.seed(2016) # gbmt.bernoulli <- gbmt(survived~., data=ptit, # distribution=gbm_dist("Bernoulli"), # train_params = train_params, # cv_folds = 3, # is_verbose = FALSE, keep_gbm_data=TRUE) # par(mfrow=c(2,2)) # par(mar=c(3.5, 3, 2, 0.5)) # small margins and text to pack figs in # par(mgp=c(1.5, .4, 0)) # squash axis annotations # w1 <- plotres(gbmt.bernoulli, which=c(1,4), # col=ptit$survived+2, trace=0, do.par=FALSE, # w1.main="gbmt.bernoulli") # cat("w1 plot for gbmt.bernoulli with cv.folds=3 returned:\n") # print(w1) # # w3 <- plotres(gbmt.bernoulli, which=3, predict.n.trees=40, # ylim=c(-.6, 1), xlim=c(.1, .6), # col=ptit$sex, trace=0, do.par=FALSE, smooth.col=0) # # # compare to manual residuals # iused <- 1:(train.frac * nrow(ptit)) # y <- ptit$survived[iused] # # TODO following fails in the new version of gbm (version 2.2) (you have to provide newdata) # # yhat <- predict(gbmt.bernoulli, type="response", n.trees=40) # yhat <- predict(gbmt.bernoulli, newdata=ptit, type="response", n.trees=40) # yhat <- yhat[iused] # plot(yhat, y - yhat, col=ptit$sex, # main="manual bernoulli residuals", pch=20, cex=1, # ylim=c(-.6, 1), xlim=c(.1, .6)) # abline(h=0, col="gray") # stopifnot(all(yhat == w3$x)) # stopifnot(all(y - yhat == w3$y)) # par(org.par) # # plotmo(gbmt.bernoulli, do.par=2) # print(summary(gbmt.bernoulli)) # will also plot # par(org.par) cat("--- gbm3: distribution=\"gaussian\", formula interface ----------------------------------\n") library(gbm3) set.seed(2016) ptit <- ptitanic[sample(1:nrow(ptitanic), size=70), ] # small data for fast test set.seed(2016) # # TODO bug in gbm3: 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) gbm3.gaussian <- gbm3::gbm(age~., data=ptit, train.frac=train.frac, distribution="gaussian", n.trees=50, shrinkage=.1, keep.data=FALSE) expect.err(try(plotres(gbm3.gaussian)), "use keep_gbm_data=TRUE in the call to gbm") set.seed(2016) gbm3.gaussian <- gbm3::gbm(age~., data=ptit, train.frac=train.frac, distribution="gaussian", n.trees=50, shrinkage=.1) par(mfrow=c(2,2), mar=c(3,3,4,1)) w1 <- plotres(gbm3.gaussian, which=1, do.par=FALSE, w1.smooth=TRUE, w1.main="gbm3.gaussian") cat("w1 plot for gbm3.gaussian returned (w1.smooth=TRUE):\n") print(w1) plot(0, 0) # dummy plot w3 <- plotres(gbm3.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(gbm3.gaussian) # TODO following fails in the new version of gbm (version 2.2) (you have to provide newdata) # yhat <- predict(gbm3.gaussian, type="response", n.trees=n.trees) yhat <- predict(gbm3.gaussian, newdata=ptit, type="response", n.trees=n.trees) yhat <- yhat[iused] plot(yhat, y - yhat, col=ptit$sex[iused], main="manual gaussian residuals", pch=20, ylim=c(-40,40)) abline(h=0, col="gray") stopifnot(all(yhat == w3$x)) stopifnot(all(y - yhat == w3$y)) par(org.par) w1 <- plotres(gbm3.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 gbm3.gaussian returned (w1.smooth=TRUE):\n") print(w1) plotmo(gbm3.gaussian, trace=-1, SHOWCALL=TRUE) # plotmo(gbm3.gaussian, trace=-1, all1=TRUE, SHOWCALL=TRUE) # plotmo(gbm3.gaussian, trace=-1, all2=TRUE, SHOWCALL=TRUE) cat("--- gbm3: distribution=\"gaussian\", xy interface ----------------------------------\n") y = ptit$age x = ptit[,c(1,2,3,5,6)] train_params=gbm3::training_params(num_trees=100, interaction_depth=2, min_num_obs_in_node=3, shrinkage=0.1, bag_fraction=0.5, id=seq_len(nrow(x)), num_train=round(0.5 * nrow(x)), num_features=ncol(x)) gbm3fit <- gbm3::gbmt_fit(x, y, train_params=train_params, keep_gbm_data=TRUE, dist=gbm_dist("Gaussian")) plotmo(gbm3fit, trace=-1, SHOWCALL=TRUE) plotres(gbm3fit, trace=-1, SHOWCALL=TRUE) cat("--- gbm3: large number of variables ----------------------------------\n") set.seed(2024) N <- 1000 X <- data.frame(X1=runif(N), X2=2*runif(N), X3=3*runif(N), X4=runif(N), X5=2*runif(N), X6=3*runif(N), X7=runif(N), X8=2*runif(N), X9=3*runif(N), X10=runif(N), X11=2*runif(N), X12=3*runif(N), X13=runif(N), X14=2*runif(N), X15=3*runif(N)) # Y <- sample(c(0, 1), N, replace = TRUE) set.seed(2024) Y <- sqrt(X[,1]) + sqrt(X[,2]) + sqrt(X[,3]) + sqrt(X[,4]) + sqrt(X[,5]) + sqrt(X[,6]) + .5 * sqrt(X[,8]) + sqrt(X[,9]) + sqrt(X[,10]) + sqrt(X[,11]) + sqrt(X[,12]) data <- data.frame(Y, X) set.seed(2024) gbm3.big <- gbm3::gbm(Y~., data=data, shrinkage=0.1, dist="gaussian") y = data[,1] x = data[,2:ncol(data)] train_params=gbm3::training_params(num_trees=100, interaction_depth=3, min_num_obs_in_node=10, shrinkage=0.1, bag_fraction=0.5, id=seq_len(nrow(x)), num_train=round(0.5 * nrow(x)), num_features=ncol(x)) gbm3fit.big <- gbm3::gbmt_fit(x, y, train_params=train_params, keep_gbm_data=TRUE, dist=gbm_dist("Gaussian")) set.seed(2024) plotmo(gbm3.big, SHOWCALL=TRUE) plotmo(gbm3.big, all1=TRUE, all2=TRUE, caption="all1=TRUE, all2=TRUE") plotmo(gbm3.big, all1=TRUE, all2=2, caption="all1=TRUE, all2=2") plotres(gbm3.big, trace=-1, SHOWCALL=TRUE) set.seed(2024) plotmo(gbm3fit.big, SHOWCALL=TRUE) plotmo(gbm3fit.big, all1=TRUE, caption="all1=TRUE") plotmo(gbm3fit.big, all2=TRUE, caption="all2=TRUE") plotmo(gbm3fit.big, all2=2, caption="all2=2") plotres(gbm3.big, trace=-1, SHOWCALL=TRUE) source("test.epilog.R") plotmo/inst/slowtests/test.plotmo.x.R0000644000176200001440000002737213725307664017521 0ustar liggesusers# test.plotmo.x.R: test plotmo_x and related functions source("test.prolog.R") library(plotmo) library(earth) options(warn=1) # print warnings as they occur data(ozone1) data(etitanic) get.tit <- function() { tit <- etitanic pclass <- as.character(tit$pclass) # change the order of the factors so not alphabetical pclass[pclass == "1st"] <- "first" pclass[pclass == "2nd"] <- "class2" pclass[pclass == "3rd"] <- "classthird" tit$pclass <- factor(pclass, levels=c("class2", "classthird", "first")) # log age is so we have a continuous predictor even when model is age~. set.seed(2015) tit$logage <- log(tit$age) + rnorm(nrow(tit)) tit$parch <- NULL # by=12 gives us a small fast model with an additive and a interaction term tit <- tit[seq(1, nrow(etitanic), by=12), ] } X <- X1 <- X2 <- Y <- DF <- NULL get.data <- function() { X <<- matrix(c(1,2,3,4,5,6,7,8,9, 2,3,3,5,6,7,8,9,9), ncol=2) colnames(X) <- c("xx1", "xx2") X1 <<- X[,1] X2 <<- X[,2] Y <<- c(1,2,7,4,5,6,6,6,6) DF <<- data.frame(Y=Y, X1=X1, X2=X2) } stopifnot1 <- function(x, y){ xname <- deparse(substitute(x)) yname <- deparse(substitute(y)) if(!all(x == y)) stop(sprint("%s == %s failed\n", xname, yname, call.=FALSE)) printf("%s == %s passed\n", xname, yname) } printf("====== standard earth.formula model with a data frame\n") get.data() earth.form.df.dot <- earth(Y~., data=DF) plotmo(earth.form.df.dot, caption="test basic use of DF") printf("-- test basic use of DF\n") rv <- plotmo(earth.form.df.dot, trace=100) stopifnot1(rv, X) printf("-- test use same DF even when other variables change\n") get.data() earth.form.df.dot <- earth(Y~., data=DF) X1 <- "rubbish" rv <- plotmo(earth.form.df.dot, trace=100) stopifnot1(rv, X) printf("-- test detect that DF is now trashed\n") get.data() earth.form.df.dot <- earth(Y~., data=DF) DF <- "rubbish" X1 <- "rubbish" # DF is corrupt and will treated as NULL by plotmo, so make sure plotmo doesn't find the global X1 # invalid 'envir' argument of type 'character' expect.err(try(plotmo(earth.form.df.dot, trace=100)), "cannot get the original model predictors") # Removed this test because this no longer fails, because we get the formula using formula(object) # printf("-- DF is NULL so will get '.' in formula and no 'data' argument\n") # get.data() # earth.form.df.dot <- earth(Y~., data=DF) # DF <- NULL # # '.' in formula and no 'data' argument # expect.err(try(plotmo(earth.form.df.dot, trace=100)), "cannot get the original model predictors") printf("-- DF is NULL so will pick up X1 with same values from global environment\n") get.data() earth.form.df <- earth(Y~X1+X2, data=DF) DF <- NULL rv <- plotmo(earth.form.df, trace=100) stopifnot1(rv, X) printf("-- DF is NULL so will will pick up trashed X1 from global environment\n") earth.form.df <- earth(Y~X1+X2, data=DF) DF <- NULL X1 <- "rubbish" # variable lengths differ (found for 'X1') expect.err(try(plotmo(earth.form.df, trace=100)), "cannot get the original model predictors") printf("-- DF has only one column, so will pick up X1 from it and X2 from global environment\n") get.data() earth.form.df <- earth(Y~X1+X2, data=DF) DF <- data.frame(Y=Y, X1=X1) DF[1,2] <- 99 X2[1] <- 98 rv <- plotmo(earth.form.df, trace=100) stopifnot1(rv[1,1], 99) stopifnot1(rv[1,2], 98) printf("-- sanity check, make sure we are back to normal\n") get.data() earth.form.df <- earth(Y~X1+X2, data=DF) rv <- plotmo(earth.form.df, trace=100) stopifnot1(rv, X) printf("-- change the data frame, make sure we pick up the changed value\n") get.data() earth.form.df <- earth(Y~X1+X2, data=DF) DF[1,2] <- 99 rv <- plotmo(earth.form.df, trace=100) stopifnot1(rv[1,1], 99) printf("-- change order of columns in the data frame, should be ok\n") get.data() earth.form.df <- earth(Y~X1+X2, data=DF) DF <- data.frame(X2=X2, X1=X1) rv <- plotmo(earth.form.df, trace=100) stopifnot1(rv, X) printf("======= standard earth.formula model with a data frame and keepxy\n") get.data() earth.form.df.keepxy <- earth(Y~., data=DF, keepxy=TRUE) printf("-- test basic use of DF\n") rv <- plotmo(earth.form.df.keepxy, trace=100) stopifnot1(rv, X) printf("-- test use same DF even when other variables change\n") earth.form.df.keepxy <- earth(Y~., data=DF, keepxy=TRUE) X1 <- "rubbish" rv <- plotmo(earth.form.df.keepxy, trace=100) stopifnot1(rv, X) printf("-- DF is now trashed but it doesn't matter because keepxy=T\n") DF <- "rubbish" rv <- plotmo(earth.form.df.keepxy, trace=100) stopifnot1(rv, X) printf("-- DF is NULL but it doesn't matter because keepxy=T\n") get.data() earth.form.df.keepxy <- earth(Y~., data=DF, keepxy=TRUE) DF <- NULL rv <- plotmo(earth.form.df.keepxy, trace=100) stopifnot1(rv, X) printf("-- DF and X1 are NULL but it doesn't matter because keepxy=T\n") DF <- NULL X1 <- "rubbish" rv <- plotmo(earth.form.df.keepxy, trace=100) stopifnot1(rv, X) printf("-- sanity check, make sure we are back to normal\n") get.data() earth.form.df.keepxy <- earth(Y~., data=DF, keepxy=TRUE) rv <- plotmo(earth.form.df.keepxy, trace=100) stopifnot1(rv, X) printf("-- change the data frame, but it doesn't matter because keepxy=T\n") get.data() earth.form.df.keepxy <- earth(Y~., data=DF, keepxy=TRUE) DF[1,2] <- 99 rv <- plotmo(earth.form.df.keepxy, trace=100) stopifnot1(rv, X) printf("-- change order of columns in the data frame, should be ok\n") get.data() earth.form.df.keepxy <- earth(Y~., data=DF, keepxy=TRUE) DF <- data.frame(X2=X2, X1=X1) rv <- plotmo(earth.form.df.keepxy, trace=100) stopifnot1(rv, X) printf("======= standard lm model with a data frame but with model=FALSE\n") get.data() lm.form.df.model.false.with.dot <- lm(Y~., data=DF, model=FALSE) printf("-- test basic use of DF\n") rv <- plotmo(lm.form.df.model.false.with.dot, trace=100) stopifnot1(rv, X) printf("-- test use same DF even when other variables change\n") get.data() lm.form.df.model.false.with.dot <- lm(Y~., data=DF, model=FALSE) X1 <- "rubbish" rv <- plotmo(lm.form.df.model.false.with.dot, trace=100) stopifnot1(rv, X) printf("-- test detect that DF is now trashed\n") DF <- "rubbish" # invalid 'envir' argument of type 'character' expect.err(try(plotmo(lm.form.df.model.false.with.dot, trace=100)), "cannot get the original model predictors") printf("-- DF is NULL so will pick up X1 with same values from global environment\n") get.data() lm.form.df.model.false <- lm(Y~X1+X2, data=DF, model=FALSE) DF <- NULL rv <- plotmo(earth.form.df, trace=100) stopifnot1(rv, X) printf("-- DF is NULL so will will pick up trashed X1 from global environment\n") get.data() lm.form.df.model.false <- lm(Y~X1+X2, data=DF, model=FALSE) DF <- NULL X1 <- "rubbish" # variable lengths differ (found for 'X1') expect.err(try(plotmo(lm.form.df.model.false, trace=100)), "cannot get the original model predictors") printf("-- sanity check, make sure we are back to normal\n") get.data() lm.form.df.model.false <- lm(Y~X1+X2, data=DF, model=FALSE) rv <- plotmo(lm.form.df.model.false, trace=100) stopifnot1(rv, X) printf("-- change the data frame, make sure we pick up the changed value\n") get.data() lm.form.df.model.false <- lm(Y~X1+X2, data=DF, model=FALSE) DF[1,2] <- 99 rv <- plotmo(lm.form.df.model.false, trace=100) stopifnot1(rv[1,1], 99) printf("-- change order of columns in the data frame, should be ok\n") get.data() lm.form.df.model.false <- lm(Y~X1+X2, data=DF, model=FALSE) DF <- data.frame(X2=X2, X1=X1) rv <- plotmo(lm.form.df.model.false, trace=100) stopifnot1(rv, X) printf("======= standard lm with a data frame and model=TRUE (the default)\n") get.data() lm.form.df.with.dot <- lm(Y~., data=DF) printf("-- test basic use of DF\n") rv <- plotmo(lm.form.df.with.dot, trace=100) stopifnot1(rv, X) printf("-- test use same DF even when other variables change\n") get.data() lm.form.df.with.dot <- lm(Y~., data=DF) X1 <- "rubbish" rv <- plotmo(lm.form.df.with.dot, trace=100) stopifnot1(rv, X) printf("-- DF is now trashed but it doesn't matter because keepxy=T\n") DF <- "rubbish" rv <- plotmo(lm.form.df.with.dot, trace=100) stopifnot1(rv, X) printf("-- DF is NULL but it doesn't matter because keepxy=T\n") get.data() lm.form.df.with.dot <- lm(Y~., data=DF) DF <- NULL rv <- plotmo(lm.form.df.with.dot, trace=100) stopifnot1(rv, X) printf("-- DF and X1 are NULL but it doesn't matter because keepxy=T\n") DF <- NULL X1 <- "rubbish" rv <- plotmo(lm.form.df.with.dot, trace=100) stopifnot1(rv, X) printf("-- sanity check, make sure we are back to normal\n") get.data() lm.form.df.with.dot <- lm(Y~., data=DF) rv <- plotmo(lm.form.df.with.dot, trace=100) stopifnot1(rv, X) printf("-- change the data frame, but it doesn't matter because keepxy=T\n") get.data() lm.form.df.with.dot <- lm(Y~., data=DF) DF[1,2] <- 99 rv <- plotmo(lm.form.df.with.dot, trace=100) stopifnot1(rv, X) printf("-- change order of columns in the data frame, should be ok\n") get.data() lm.form.df.with.dot <- lm(Y~., data=DF) DF <- data.frame(X2=X2, X1=X1) rv <- plotmo(lm.form.df.with.dot, trace=100) stopifnot1(rv, X) printf("======= standard lm with a data frame and model=FALSE but x=TRUE\n") get.data() lm.form.df.model.false.x.true <- lm(Y~., data=DF, model=FALSE, x=TRUE) printf("-- test basic use of DF\n") rv <- plotmo(lm.form.df.model.false.x.true, trace=100) stopifnot1(rv, X) printf("-- test DF not available (shouldn't matter)\n") DF <- "rubbish" rv <- plotmo(lm.form.df.model.false.x.true, trace=100) stopifnot1(rv, X) printf("-- test $x trashed causes failure\n") get.data() lm.form.df.model.false.x.true <- lm(Y~., data=DF, model=FALSE, x=TRUE) DF <- "rubbish" X2 <- "rubbish1" lm.form.df.model.false.x.true[["x"]] <- "nonesuch" expect.err(try(plotmo(lm.form.df.model.false.x.true, trace=100)), "cannot get the original model predictors") printf("-- test ok with $x trashed but DF ok\n") # although with trace!=100 will get downstream failures in predict.lm, that's ok get.data() lm.form.df.model.false.x.true[["x"]] <- "nonesuch" # Warning: object$x may be corrupt rv <- plotmo(lm.form.df.model.false.x.true, trace=100) stopifnot1(rv, X) printf("-- test \"warning: object$x may be corrupt\", same as above but set options(warn=2)\n") options(warn=2) get.data() lm.form.df.model.false.x.true[["x"]] <- "nonesuch" # Warning: object$x may be corrupt expect.err(try(plotmo(lm.form.df.model.false.x.true, trace=100)), "x may be corrupt") options(warn=1) stopifnot1(rv, X) printf("====== strings in the data.frame\n") tit1 <- get.tit() tit1$char.pclass <- as.character(tit1$pclass) earth.survived.vs.pclass <- earth(survived~pclass, data=tit1, linpreds=TRUE) x.earth.survived.vs.pclass <- plotmo(earth.survived.vs.pclass, trace=100, linpreds=TRUE) stopifnot(is.factor(x.earth.survived.vs.pclass[[1]])) earth.survived.vs.char.pclass <- earth(survived~char.pclass, data=tit1) x.earth.survived.vs.char.pclass <- plotmo(earth.survived.vs.char.pclass, trace=100) stopifnot(is.factor(x.earth.survived.vs.char.pclass[[1]])) stopifnot(x.earth.survived.vs.pclass == x.earth.survived.vs.char.pclass) lm.survived.vs.pclass <- earth(survived~pclass, data=tit1, linpreds=TRUE) x.lm.survived.vs.pclass <- plotmo(lm.survived.vs.pclass, trace=100, linpreds=TRUE) stopifnot(is.factor(x.lm.survived.vs.pclass[[1]])) lm.survived.vs.char.pclass <- earth(survived~char.pclass, data=tit1) x.lm.survived.vs.char.pclass <- plotmo(lm.survived.vs.char.pclass, trace=100) stopifnot(is.factor(x.lm.survived.vs.char.pclass[[1]])) stopifnot(x.lm.survived.vs.pclass == x.lm.survived.vs.char.pclass) stopifnot(x.lm.survived.vs.pclass == x.earth.survived.vs.pclass) printf("-- test.plotmo.x done\n") source("test.epilog.R") plotmo/inst/slowtests/test.glmnetUtils.R0000644000176200001440000001414413727235376020243 0ustar liggesusers# test.glmnet.R: glmnetUtils tests for plotmo and plotres source("test.prolog.R") library(earth) library(glmnetUtils) data(ozone1) data(etitanic) get.tit <- function() # abbreviated titanic data { tit <- etitanic pclass <- as.character(tit$pclass) # change the order of the factors so not alphabetical pclass[pclass == "1st"] <- "first" pclass[pclass == "2nd"] <- "class2" pclass[pclass == "3rd"] <- "classthird" tit$pclass <- factor(pclass, levels=c("class2", "classthird", "first")) # log age is so we have a continuous predictor even when model is age~. set.seed(2015) tit$logage <- log(tit$age) + rnorm(nrow(tit)) tit$parch <- NULL # by=12 gives us a small fast model with an additive and a interaction term tit <- tit[seq(1, nrow(etitanic), by=12), ] } plotmores <- function(object, ..., trace=0, SHOWCALL=TRUE, title.extra="", ncol=2) { old.par <- par(no.readonly=TRUE) on.exit(par(old.par)) par(mfrow=c(2,ncol)) caption <- paste(deparse(substitute(object)), collapse=" ") call <- match.call(expand.dots=TRUE) call <- strip.space(paste(deparse(substitute(call)), collapse=" ")) call <- gsub(",", ", ", call) call <- paste(title.extra, call, sep="") printf("%s\n", call) # plotmo on glmnet mods is boring but we test it anyway plotres(object, trace=trace, SHOWCALL=SHOWCALL, do.par=FALSE, which=c(1,3), ...) title(paste("\n", call), outer=TRUE) plotmo(object, trace=trace, SHOWCALL=SHOWCALL, do.par=FALSE, ...) } tit <- get.tit() set.seed(2015) xmat <- as.matrix(tit[,c(2,5,6)]) agedata <- data.frame(tit[,4], xmat) colnames(agedata) <- c("age", "survived", "sibsp", "logage") set.seed(2015) mod.glmnet.xmat <- glmnet(xmat, tit[,4]) # tit[,4] is age plotres(mod.glmnet.xmat) plotmo(mod.glmnet.xmat) plotmores(mod.glmnet.xmat, predict.s=2.5) mod.glmnet.agedata <- glmnet(age~., data=agedata) expect.err(try(plotres(mod.glmnet.agedata)), "for this plot, glmnet.formula must be called with use.model.frame=TRUE") mod.glmnet.agedata <- glmnet(age~., data=agedata, use.model.frame=TRUE) plotmores(mod.glmnet.agedata, predict.s=2.5) set.seed(2015) mod.cv.glmnet.xmat <- cv.glmnet(xmat, tit[,4], nfolds=3) cat("==Test plotmo trace=1 and lambda.min\n") plotmores(mod.cv.glmnet.xmat, predict.s="lambda.min", trace=1, ncol=3) set.seed(2015) mod.cv.glmnet.agedata <- cv.glmnet(age~., data=agedata) expect.err(try(plotres(mod.cv.glmnet.agedata)), "for this plot, cv.glmnet.formula must be called with use.model.frame=TRUE") set.seed(2015) mod.cv.glmnet.agedata <- cv.glmnet(age~., data=agedata, use.model.frame=TRUE) cat("==Test lambda.min\n") plotmores(mod.cv.glmnet.agedata, predict.s="lambda.min", trace=1, ncol=3) printf("======== binomial model\n") set.seed(2016) n <- 50 p <- 4 xx <- matrix(rnorm(n*p), n, p) colnames(xx) <- paste("x", 1:ncol(xx), sep="") yy <- ifelse(xx[,1] + xx[,2] + rnorm(n) > .5, TRUE, FALSE) print(cov(xx, yy)) yy <- factor(yy) dataxy <- data.frame(yy, xx) binomial.mod <- glmnet(xx, yy, family="binomial") plotmores(binomial.mod, ncol=3) binomial.mod.form <- glmnet(yy~., data=dataxy, family="binomial", use.model.frame=TRUE) plotmores(binomial.mod.form, ncol=3) par(org.par) printf("======== glmnet family=\"mgaussian\"\n") set.seed(2015) p <- 10 n <- 30 xx <- cbind((1:n)/n, matrix(rnorm(n*(p-1)),n,p-1)) colnames(xx) <- paste0("x", 1:p) # ymultresp <- cbind(rowSums(xx[,1:5]^3), rowSums(xx[,5:p]^3), 1:n) set.seed(1) ymultresp <- cbind(xx[,1]+.001*rnorm(n), rowSums(xx[,2:5]^3), rnorm(n)) glmnet.mgaussian <- glmnet(xx, ymultresp, family="mgaussian") plotres(glmnet.mgaussian, nresponse=1, SHOWCALL=TRUE, which=c(1:3), do.par=2, info=1) # manually calculate the residuals plot(x=predict(glmnet.mgaussian, newx=xx, s=0)[,1,1], y=ymultresp[,1] - predict(glmnet.mgaussian, newx=xx, s=0)[,1,1], pch=20, xlab="Fitted", ylab="Residuals", main="Manually calculated residuals, nresponse=1, s=0") abline(h=0, col="gray") par(org.par) # # TODO is glmnet mgaussian supported with a formula interface? # dataxy <- data.frame(ymultresp, xx) # colnames(dataxy) <- c("y1", "y2", "y3", "x1", "x2", "x3", "x4", "x5", "x5", "x6", "x7", "x8", "x9", "x10") # glmnet.mgaussian.form <- glmnet(xx, ymultresp, family="mgaussian") # plotres(glmnet.mgaussian.form, nresponse=1, SHOWCALL=TRUE, which=c(1:3), do.par=2, info=1) par(mfrow=c(2,3), mar=c(3,3,3,.5), oma=c(0,0,3,0), mgp=c(1.5,0.4,0), tcl=-0.3) data(trees) set.seed(2015) # variable with a long name x50 <- cbind(trees[,1:2], Girth12345678901234567890=rnorm(nrow(trees))) mod.with.long.name <- glmnet(data.matrix(x50),data.matrix(trees$Volume)) plotmores(mod.with.long.name, ncol=3) data.x50 <- data.frame(trees$Volume, x50) colnames(data.x50) <- c("Volume", "Girth", "Height", "Girth12345678901234567890") mod.with.long.name.form <- glmnet(Volume~., data=data.x50, use.model.frame=TRUE) plotmores(mod.with.long.name.form, ncol=3) par(org.par) #-- make sure that we can work with all families set.seed(2016) par(mfrow=c(3,3), mar=c(3,3,3,1)) n <- 100 p <- 4 xx <- matrix(rnorm(n*p), n, p) g2 <- sample(1:2, n, replace=TRUE) data.xg2 <- data.frame(g2, xx) for(family in c("gaussian","binomial","poisson")) { title.extra <- paste(family, ": ") mod <- glmnet(xx,g2,family=family) plotmores(mod, xvar="lambda", ncol=3, title.extra=title.extra) title.extra <- paste("formula", family, ": ") mod.form <- glmnet(g2~., data.xg2, family=family, use.model.frame=TRUE) plotmores(mod.form, xvar="lambda", ncol=3, title.extra=title.extra) } par(org.par) # cox library(plotmo) n <- 100 p <- 20 nzc <- trunc(p/10) set.seed(2016) beta <- rnorm(nzc) x7 <- matrix(rnorm(n*p), n, p) beta <- rnorm(nzc) fx <- x7[,seq(nzc)] %*% beta/3 hx <- exp(fx) ty <- rexp(n, hx) tcens <- rbinom(n=n, prob=.3, size=1)# censoring indicator yy <- cbind(time=ty, status=1-tcens) # yy=Surv(ty,1-tcens) with library(survival) glmnet.cox <- glmnet(x=x7, y=yy, family="cox") plotmores(glmnet.cox, ncol=3, degree1=1:4) par(org.par) # TODO formula interface not tested for cox models source("test.epilog.R") plotmo/inst/slowtests/test.glmnet.Rout.save0000644000176200001440000013550214663413106020676 0ustar liggesusers> # test.glmnet.R: glmnet tests for plotmo and plotres > > source("test.prolog.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix > library(glmnet) Loading required package: Matrix Loaded glmnet 4.1-8 > data(ozone1) > data(etitanic) > get.tit <- function() # abbreviated titanic data + { + tit <- etitanic + pclass <- as.character(tit$pclass) + # change the order of the factors so not alphabetical + pclass[pclass == "1st"] <- "first" + pclass[pclass == "2nd"] <- "class2" + pclass[pclass == "3rd"] <- "classthird" + tit$pclass <- factor(pclass, levels=c("class2", "classthird", "first")) + # log age is so we have a continuous predictor even when model is age~. + set.seed(2015) + tit$logage <- log(tit$age) + rnorm(nrow(tit)) + tit$parch <- NULL + # by=12 gives us a small fast model with an additive and a interaction term + tit <- tit[seq(1, nrow(etitanic), by=12), ] + } > plotmo1 <- function(object, ..., trace=0, SHOWCALL=TRUE, caption=NULL) { + if(is.null(caption)) + caption <- paste(deparse(substitute(object)), collapse=" ") + call <- match.call(expand.dots=TRUE) + call <- strip.space(paste(deparse(substitute(call)), collapse=" ")) + printf("%s\n", call) + plotmo(object, trace=trace, SHOWCALL=SHOWCALL, caption=caption, ...) + } > plotres1 <- function(object, ..., trace=0, SHOWCALL=TRUE, caption=NULL) { + if(is.null(caption)) + caption <- paste(deparse(substitute(object)), collapse=" ") + call <- match.call(expand.dots=TRUE) + call <- strip.space(paste(deparse(substitute(call)), collapse=" ")) + printf("%s\n", call) + plotres(object, trace=trace, SHOWCALL=SHOWCALL, caption=caption, ...) + } > tit <- get.tit() > set.seed(2015) > xmat <- as.matrix(tit[,c(2,5,6)]) > set.seed(2015) > mod.glmnet.xmat <- glmnet(xmat, tit[,4]) > # plotmo on glmnet mods is boring but we test it anyway > plotmo1(mod.glmnet.xmat) plotmo1(object=mod.glmnet.xmat) plotmo grid: survived sibsp logage 0 0 3.06991 > plotres1(mod.glmnet.xmat) plotres1(object=mod.glmnet.xmat) > > # compare to plot.glmnet > par(mfrow=c(4,2), mar=c(3,6,3.5,6)) # extra side margins for more square plots > plot_glmnet(mod.glmnet.xmat, main="mod.glmnet.xmat\ncompare to plot.glmnet") > plot(0,0) > plot_glmnet(mod.glmnet.xmat, xvar="norm", col=c(3,2,1)) > plot(mod.glmnet.xmat, xvar="norm") > plot_glmnet(mod.glmnet.xmat, xvar="lambda") > plot(mod.glmnet.xmat, xvar="lambda") > plot_glmnet(mod.glmnet.xmat, xvar="dev") > plot(mod.glmnet.xmat, xvar="dev") > par(org.par) > > set.seed(2015) > mod.cv.glmnet.xmat <- cv.glmnet(xmat, tit[,4], nfolds=3) > > # following was needed before plotmo 3.1.3 (before adding plotmo.prolog.cv.glmnet) > # mod.cv.glmnet.xmat$x <- as.data.frame(xmat) > # mod.cv.glmnet.xmat$y <- tit[,4] > > cat("==Test plotmo trace=1 and lambda.min\n") ==Test plotmo trace=1 and lambda.min > plotmo1(mod.cv.glmnet.xmat, predict.s="lambda.min", trace=1) plotmo1(object=mod.cv.glmnet.xmat,predict.s="lambda.min",trace=1) stats::predict(cv.glmnet.object, matrix[3,3], type="response", s="lambda.min") stats::fitted(object=cv.glmnet.object) fitted() was unsuccessful, will use predict() instead got model response from getCall(object)$y plotmo grid: survived sibsp logage 0 0 3.06991 > cat("==Test plotmo trace=2 and lambda.min\n") ==Test plotmo trace=2 and lambda.min > plotmo1(mod.cv.glmnet.xmat, predict.s="lambda.min", trace=2) plotmo1(object=mod.cv.glmnet.xmat,predict.s="lambda.min",trace=2) plotmo trace 2: plotmo(object, trace=trace, SHOWCALL=SHOWCALL, caption=caption, ...) --get.model.env for object with class cv.glmnet object call is cv.glmnet(x=xmat, y=tit[, 4], nfolds=3) assuming the environment of the cv.glmnet model is that of plotmo's caller: env(..., call, caption, object, SHOWCALL, trace) --plotmo_prolog for cv.glmnet object 'object' --plotmo_x for cv.glmnet object get.object.x: object$x is NULL (and it has no colnames) object call is cv.glmnet(x=xmat, y=tit[, 4], nfolds=3) get.x.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$x, env(..., call, caption, object, SHOWCALL, trace)) getCall(object)$x is usable and has column names survived sibsp logage plotmo_x returned[88,3]: survived sibsp logage 1 1 0 1.821847 13 1 0 3.814495 26 0 0 3.094392 ... 0 0 5.950193 1308 0 0 5.116245 ----Metadata: plotmo_predict with nresponse=NULL and newdata=NULL plotmo_predict with NULL newdata (nrows=3), using plotmo_x to get the data --plotmo_x for cv.glmnet object get.object.x: object$x is NULL (and it has no colnames) object call is cv.glmnet(x=xmat, y=tit[, 4], nfolds=3) get.x.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$x, env(..., call, caption, object, SHOWCALL, trace)) getCall(object)$x is usable and has column names survived sibsp logage plotmo_x returned[88,3]: survived sibsp logage 1 1 0 1.821847 13 1 0 3.814495 26 0 0 3.094392 ... 0 0 5.950193 1308 0 0 5.116245 will use the above data instead of newdata=NULL for predict.cv.glmnet stats::predict(cv.glmnet.object, matrix[3,3], type="response", s="lambda.min") predict returned[3,1]: s="lambda.min" 1 25.64083 13 34.58457 26 31.45755 predict after processing with nresponse=NULL is [3,1]: s="lambda.min" 1 25.64083 13 34.58457 26 31.45755 ----Metadata: plotmo_fitted with nresponse=NULL stats::fitted(object=cv.glmnet.object) fitted() was unsuccessful, will use predict() instead plotmo_predict with NULL newdata, using plotmo_x to get the data --plotmo_x for cv.glmnet object get.object.x: object$x is NULL (and it has no colnames) object call is cv.glmnet(x=xmat, y=tit[, 4], nfolds=3) get.x.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$x, env(..., call, caption, object, SHOWCALL, trace)) getCall(object)$x is usable and has column names survived sibsp logage plotmo_x returned[88,3]: survived sibsp logage 1 1 0 1.821847 13 1 0 3.814495 26 0 0 3.094392 ... 0 0 5.950193 1308 0 0 5.116245 will use the above data instead of newdata=NULL for predict.cv.glmnet stats::predict(cv.glmnet.object, matrix[88,3], type="response", s="lambda.min") predict returned[88,1]: s="lambda.min" 1 25.64083 13 34.58457 26 31.45755 ... 44.27544 1308 40.53237 predict after processing with nresponse=NULL is [88,1]: s="lambda.min" 1 25.64083 13 34.58457 26 31.45755 ... 44.27544 1308 40.53237 got fitted values by calling predict (see above) ----Metadata: plotmo_y with nresponse=NULL --plotmo_y with nresponse=NULL for cv.glmnet object get.object.y: object$y is NULL (and it has no colnames) object call is cv.glmnet(x=xmat, y=tit[, 4], nfolds=3) get.y.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$y, env(..., call, caption, object, SHOWCALL, trace)) getCall(object)$y is usable but without colnames so we will keep on searching names(call) is "" "x" "y" "nfolds" the name of argument 2 is "y" so we will not process it with argn object$y is NULL call$y is usable but without colnames but we will use it anyway plotmo_y returned[88,1] with no column names: 1 29 2 24 3 25 ... 41 88 27 plotmo_y after processing with nresponse=NULL is [88,1] with no column names: 1 29 2 24 3 25 ... 41 88 27 converted nresponse=NA to nresponse=1 nresponse=1 (was NA) ncol(fitted) 1 ncol(predict) 1 ncol(y) 1 ----Metadata: plotmo_y with nresponse=1 --plotmo_y with nresponse=1 for cv.glmnet object get.object.y: object$y is NULL (and it has no colnames) object call is cv.glmnet(x=xmat, y=tit[, 4], nfolds=3) get.y.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$y, env(..., call, caption, object, SHOWCALL, trace)) getCall(object)$y is usable but without colnames so we will keep on searching names(call) is "" "x" "y" "nfolds" the name of argument 2 is "y" so we will not process it with argn object$y is NULL call$y is usable but without colnames but we will use it anyway got model response from getCall(object)$y plotmo_y returned[88,1] with no column names: 1 29 2 24 3 25 ... 41 88 27 plotmo_y after processing with nresponse=1 is [88,1]: plotmo_y 1 29 2 24 3 25 ... 41 88 27 got response name "s="lambda.min"" from yhat resp.levs is NULL ----Metadata: done number of x values: survived 2 sibsp 5 logage 88 ----plotmo_singles for cv.glmnet object singles: 1 survived, 2 sibsp, 3 logage ----plotmo_pairs for cv.glmnet object Error in attr(x, "formula") %||% { : invalid formula formula(object) failed for cv.glmnet object in plotmo.pairs.default Error in x$terms %||% attr(x, "terms") %||% stop("no terms component nor attribute") : no terms component nor attribute terms(object) failed for cv.glmnet object in plotmo.pairs.default no pairs graphics::par(mfrow=c(2,2), mgp=c(1.5,0.4,0), tcl=-0.3, font.main=2, mar=c(3,2,1.2,0.8), oma=c(0,0,4,0), cex.main=1.2, cex.lab=1, cex.axis=1, cex=0.83) ----Figuring out ylim --get.ylim.by.dummy.plots --plot.degree1(draw.plot=FALSE) degree1 plot1 (pmethod "plotmo") variable survived newdata[2,3]: survived sibsp logage 1 0 0 3.06991 2 1 0 3.06991 stats::predict(cv.glmnet.object, matrix[2,3], type="response", s="lambda.min") predict returned[2,1]: s="lambda.min" 1 31.34766 2 31.24259 predict after processing with nresponse=1 is [2,1]: s="lambda.min" 1 31.34766 2 31.24259 Reducing trace level for subsequent degree1 plots degree1 plot2 (pmethod "plotmo") variable sibsp degree1 plot3 (pmethod "plotmo") variable logage --done get.ylim.by.dummy.plots ylim c(4.856, 44.28) clip TRUE --plot.degree1(draw.plot=TRUE) plotmo grid: survived sibsp logage 0 0 3.06991 graphics::plot.default(x=c(0,0.5,0.5,1), y=c(31.35,31.35,3...), type="n", main="1 survived", xlab="", ylab="", xaxt="s", yaxt="s", xlim=c(-0.1,1.1), ylim=c(4.86,44.28)) > cat("==Test plotres trace=1 and lambda.1se\n") ==Test plotres trace=1 and lambda.1se > plotres1(mod.cv.glmnet.xmat, predict.s="lambda.1se", trace=1) plotres1(object=mod.cv.glmnet.xmat,predict.s="lambda.1se",trace=1) stats::residuals(object=cv.glmnet.object, type="response") residuals() was unsuccessful, will use predict() instead stats::predict(cv.glmnet.object, matrix[3,3], type="response", s="lambda.1se") stats::fitted(object=cv.glmnet.object) fitted() was unsuccessful, will use predict() instead got model response from getCall(object)$y graphics::plot(cv.glmnet.object) training rsq 0.24 > cat("==Test plotres trace=2 and lambda.1se\n") ==Test plotres trace=2 and lambda.1se > plotres1(mod.cv.glmnet.xmat, predict.s="lambda.1se", trace=2) plotres1(object=mod.cv.glmnet.xmat,predict.s="lambda.1se",trace=2) plotres trace 2: plotres(object, trace=trace, SHOWCALL=SHOWCALL, caption=caption, ...) --get.model.env for object with class cv.glmnet object call is cv.glmnet(x=xmat, y=tit[, 4], nfolds=3) assuming the environment of the cv.glmnet model is that of plotres's caller: env(..., call, caption, object, SHOWCALL, trace) --plotmo_prolog for cv.glmnet object 'object' ----Metadata: plotmo_resids(object, type="response", nresponse=NULL) doTryCatch invoked call.dots TRACE plotmo_resids via try called call.dots(residuals, DROP="*", KEEP="PREFIX", TRACE=if(trace==0)-1elsetr...), force.object=object, force.type=residtype, SHOWCALL=TRUE, predict.s="lambda.1se") PREFIX residuals. DROP .* KEEP >STANDARDPREFIXES|^force\.|^def\.|^drop\. >PREFIX|^residuals\. >CALLARGS|^force\.object$|^force\.type$ >EXPLICIT input dotnames force.object force.type SHOWCALL predict.s after DROP and KEEP force.object force.type return dotnames object type stats::residuals(object=cv.glmnet.object, type="response") residuals() was unsuccessful, will use predict() instead ----Metadata: plotmo_predict with nresponse=NULL and newdata=NULL plotmo_predict with NULL newdata (nrows=3), using plotmo_x to get the data --plotmo_x for cv.glmnet object get.object.x: object$x is NULL (and it has no colnames) object call is cv.glmnet(x=xmat, y=tit[, 4], nfolds=3) get.x.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$x, env(..., call, caption, object, SHOWCALL, trace)) getCall(object)$x is usable and has column names survived sibsp logage plotmo_x returned[88,3]: survived sibsp logage 1 1 0 1.821847 13 1 0 3.814495 26 0 0 3.094392 ... 0 0 5.950193 1308 0 0 5.116245 will use the above data instead of newdata=NULL for predict.cv.glmnet stats::predict(cv.glmnet.object, matrix[3,3], type="response", s="lambda.1se") predict returned[3,1]: s="lambda.1se" 1 26.57900 13 33.26779 26 30.85060 predict after processing with nresponse=NULL is [3,1]: s="lambda.1se" 1 26.57900 13 33.26779 26 30.85060 ----Metadata: plotmo_fitted with nresponse=NULL stats::fitted(object=cv.glmnet.object) fitted() was unsuccessful, will use predict() instead plotmo_predict with NULL newdata, using plotmo_x to get the data --plotmo_x for cv.glmnet object get.object.x: object$x is NULL (and it has no colnames) object call is cv.glmnet(x=xmat, y=tit[, 4], nfolds=3) get.x.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$x, env(..., call, caption, object, SHOWCALL, trace)) getCall(object)$x is usable and has column names survived sibsp logage plotmo_x returned[88,3]: survived sibsp logage 1 1 0 1.821847 13 1 0 3.814495 26 0 0 3.094392 ... 0 0 5.950193 1308 0 0 5.116245 will use the above data instead of newdata=NULL for predict.cv.glmnet stats::predict(cv.glmnet.object, matrix[88,3], type="response", s="lambda.1se") predict returned[88,1]: s="lambda.1se" 1 26.57900 13 33.26779 26 30.85060 ... 40.43678 1308 37.63743 predict after processing with nresponse=NULL is [88,1]: s="lambda.1se" 1 26.57900 13 33.26779 26 30.85060 ... 40.43678 1308 37.63743 got fitted values by calling predict (see above) ----Metadata: plotmo_y with nresponse=NULL --plotmo_y with nresponse=NULL for cv.glmnet object get.object.y: object$y is NULL (and it has no colnames) object call is cv.glmnet(x=xmat, y=tit[, 4], nfolds=3) get.y.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$y, env(..., call, caption, object, SHOWCALL, trace)) getCall(object)$y is usable but without colnames so we will keep on searching names(call) is "" "x" "y" "nfolds" the name of argument 2 is "y" so we will not process it with argn object$y is NULL call$y is usable but without colnames but we will use it anyway plotmo_y returned[88,1] with no column names: 1 29 2 24 3 25 ... 41 88 27 plotmo_y after processing with nresponse=NULL is [88,1] with no column names: 1 29 2 24 3 25 ... 41 88 27 converted nresponse=NA to nresponse=1 nresponse=1 (was NA) ncol(fitted) 1 ncol(predict) 1 ncol(y) 1 ----Metadata: plotmo_y with nresponse=1 --plotmo_y with nresponse=1 for cv.glmnet object get.object.y: object$y is NULL (and it has no colnames) object call is cv.glmnet(x=xmat, y=tit[, 4], nfolds=3) get.y.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$y, env(..., call, caption, object, SHOWCALL, trace)) getCall(object)$y is usable but without colnames so we will keep on searching names(call) is "" "x" "y" "nfolds" the name of argument 2 is "y" so we will not process it with argn object$y is NULL call$y is usable but without colnames but we will use it anyway got model response from getCall(object)$y plotmo_y returned[88,1] with no column names: 1 29 2 24 3 25 ... 41 88 27 plotmo_y after processing with nresponse=1 is [88,1]: plotmo_y 1 29 2 24 3 25 ... 41 88 27 got response name "s="lambda.1se"" from yhat resp.levs is NULL ----Metadata: done --plotmo_response for plotmo_rsq1 --plotmo_response for newdata: NULL plotmo_response trace 2: plotmo_response(object=object, newdata=newdata, trace=max(0,trace), nresponse=meta$nresponse, type=meta$type, meta=meta, ...) --get.model.env for object with class cv.glmnet object call is cv.glmnet(x=xmat, y=tit[, 4], nfolds=3) using attr(obj,".Environment") saved with cv.glmnet model: env(..., call, caption, object, SHOWCALL, trace) --plotmo_y with nresponse=1 for cv.glmnet object get.object.y: object$y is NULL (and it has no colnames) object call is cv.glmnet(x=xmat, y=tit[, 4], nfolds=3) get.y.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$y, env(..., call, caption, object, SHOWCALL, trace)) getCall(object)$y is usable but without colnames so we will keep on searching names(call) is "" "x" "y" "nfolds" the name of argument 2 is "y" so we will not process it with argn object$y is NULL call$y is usable but without colnames but we will use it anyway plotmo_y returned[88,1] with no column names: 1 29 2 24 3 25 ... 41 88 27 plotmo_y after processing with nresponse=1 is [88,1]: plotmo_y 1 29 2 24 3 25 ... 41 88 27 response is usable and has column name plotmo_y plotmo_response returned[88,1]: plotmo_y 1 29 2 24 3 25 ... 41 88 27 plotmo_response after processing with nresponse=1 is [88,1]: plotmo_y 1 29 2 24 3 25 ... 41 88 27 --plotmo_predict for plotmo_rsq1 plotmo_predict with NULL newdata, using plotmo_x to get the data --plotmo_x for cv.glmnet object get.object.x: object$x is NULL (and it has no colnames) object call is cv.glmnet(x=xmat, y=tit[, 4], nfolds=3) get.x.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$x, env(..., call, caption, object, SHOWCALL, trace)) getCall(object)$x is usable and has column names survived sibsp logage plotmo_x returned[88,3]: survived sibsp logage 1 1 0 1.821847 13 1 0 3.814495 26 0 0 3.094392 ... 0 0 5.950193 1308 0 0 5.116245 will use the above data instead of newdata=NULL for predict.cv.glmnet stats::predict(cv.glmnet.object, matrix[88,3], type="response", s="lambda.1se") predict returned[88,1]: s="lambda.1se" 1 26.57900 13 33.26779 26 30.85060 ... 40.43678 1308 37.63743 predict after processing with nresponse=1 is [88,1]: s="lambda.1se" 1 26.57900 13 33.26779 26 30.85060 ... 40.43678 1308 37.63743 ----plotmo_rinfo: plotmo_resids(object, type="response", nresponse=1) doTryCatch invoked call.dots TRACE plotmo_resids via try called call.dots(residuals, DROP="*", KEEP="PREFIX", TRACE=if(trace==0)-1elsetr...), force.object=object, force.type=residtype, SHOWCALL=TRUE, predict.s="lambda.1se") PREFIX residuals. DROP .* KEEP >STANDARDPREFIXES|^force\.|^def\.|^drop\. >PREFIX|^residuals\. >CALLARGS|^force\.object$|^force\.type$ >EXPLICIT input dotnames force.object force.type SHOWCALL predict.s after DROP and KEEP force.object force.type return dotnames object type stats::residuals(object=cv.glmnet.object, type="response") calling predict() because residuals() was unsuccessful plotmo_predict with NULL newdata, using plotmo_x to get the data --plotmo_x for cv.glmnet object get.object.x: object$x is NULL (and it has no colnames) object call is cv.glmnet(x=xmat, y=tit[, 4], nfolds=3) get.x.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$x, env(..., call, caption, object, SHOWCALL, trace)) getCall(object)$x is usable and has column names survived sibsp logage plotmo_x returned[88,3]: survived sibsp logage 1 1 0 1.821847 13 1 0 3.814495 26 0 0 3.094392 ... 0 0 5.950193 1308 0 0 5.116245 will use the above data instead of newdata=NULL for predict.cv.glmnet stats::predict(cv.glmnet.object, matrix[88,3], type="response", s="lambda.1se") predict returned[88,1]: s="lambda.1se" 1 26.57900 13 33.26779 26 30.85060 ... 40.43678 1308 37.63743 predict after processing with nresponse=1 is [88,1]: s="lambda.1se" 1 26.57900 13 33.26779 26 30.85060 ... 40.43678 1308 37.63743 --plotmo_y with nresponse=1 for cv.glmnet object get.object.y: object$y is NULL (and it has no colnames) object call is cv.glmnet(x=xmat, y=tit[, 4], nfolds=3) get.y.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$y, env(..., call, caption, object, SHOWCALL, trace)) getCall(object)$y is usable but without colnames so we will keep on searching names(call) is "" "x" "y" "nfolds" the name of argument 2 is "y" so we will not process it with argn object$y is NULL call$y is usable but without colnames but we will use it anyway plotmo_y returned[88,1] with no column names: 1 29 2 24 3 25 ... 41 88 27 plotmo_y after processing with nresponse=1 is [88,1]: plotmo_y 1 29 2 24 3 25 ... 41 88 27 residuals returned[88,1]: resids 1 2.4210049 2 -9.2677944 3 -5.8505971 ... 0.5632234 88 -10.6374291 residuals after processing with nresponse=1 is [88,1]: resids 1 2.4210049 2 -9.2677944 3 -5.8505971 ... 0.5632234 88 -10.6374291 generated the residuals using plotmo_predict() and plotmo_y() ----plotmo_rinfo: done graphics::par(mfrow=c(2,2), mgp=c(1.5,0.4,0), tcl=-0.3, font.main=1, mar=c(4,3,1.2,0.8), oma=c(0,0,4,0), cex.main=1, cex.lab=1, cex.axis=1, cex=0.83) graphics::plot(cv.glmnet.object) training rsq 0.24 > > set.seed(2015) > x <- matrix(rnorm(100*20),100,20) # 20 variables > y <- rnorm(100) > mod <- glmnet(x,y) > plotmo1(mod) plotmo1(object=mod) plotmo grid: x1 x2 x3 x4 x5 x6 -0.02229245 -0.03060877 0.02595536 -0.2306748 0.2048663 -0.2711153 x7 x8 x9 x10 x11 x12 x13 0.04214883 -0.1573321 0.05656354 -0.2789684 -0.01729983 0.05494411 -0.04358897 x14 x15 x16 x17 x18 x19 x20 -0.184689 -0.01875314 -0.08998893 0.05206396 0.1317551 -0.033794 0.1125339 > > # test w1.label > par(mfrow=c(2,3)) > par(cex=1) > par(mar=c(3,3,3,1)) > plotres(mod, which=1, w1.main="default w1.label") > plotres(mod, which=1, w1.label=5, w1.main="w1.label=5") > plotres(mod, which=1, w1.label=0, w1.main="w1.label=0") > plotres(mod, which=1, w1.label=TRUE, w1.main="w1.label=TRUE") > plotres(mod, which=1, w1.label=100, w1.main="w1.label=100") > par(org.par) > > # test w1 and non w1 args passed > par(mfrow=c(2,2), mar=c(4,4,4,4), cex=1) > > plot_glmnet(mod, w1.col=3:4, w1.xvar="norm", + main="plot_glmnet\nw1.col=3:4 w1.xvar=\"norm\"") > > plot_glmnet(mod, col=3:4, xvar="norm", + main="plot_glmnet\ncol=3:4 xvar=\"norm\"") > > plot_glmnet(mod, col=3:4, w1.col=1:2, + w1.xvar="norm", xvar="lambda", + main="plot_glmnet\ncol=3:4 w1.col=1:2\nw1.xvar=\"norm\", xvar=\"lambda\"") > > par(org.par) > par(mfrow=c(3,2), mar=c(3,4,4,4), cex=1) > > plotres(mod, which=c(1,3), do.par=FALSE, w1.col=3:4, w1.xvar="norm", + w1.main="plotres\nw1.col=3:4 w1.xvar=\"norm\"") > > plotres(mod, which=c(1,3), do.par=FALSE, col=3:4, xvar="norm", + w1.main="plotres\nplotres\ncol=3:4 xvar=\"norm\"") > > plotres(mod, which=c(1,3), do.par=FALSE, col=3:4, w1.col=1:2, + w1.main="plotres\ncol=3:4 w1.col=1:2") > > par(org.par) > > # glmnet with sparse matrices > set.seed(2015) > n <- 100 > p <- 20 > nzc <- trunc(p/10) > x <- matrix(rnorm(n*p),n,p) > iz <- sample(1:(n*p),size=n*p*.85,replace=FALSE) > x[iz] <- 0 > sx <- Matrix(x,sparse=TRUE) > # colnames(sx) <- paste("x", 1:ncol(sx), sep="") # need column names for plotmo > inherits(sx,"sparseMatrix") # confirm that it is sparse [1] TRUE > beta <- rnorm(nzc) > fx <- x[,seq(nzc)]%*%beta > eps <- rnorm(n) > y <- fx+eps > px <- exp(fx) > px <- px/(1+px) > ly <- rbinom(n=length(px),prob=px,size=1) > mod.glmnet.sx <- glmnet(sx,y) > plotmo1(mod.glmnet.sx, all2=TRUE) # will give warning: too many predictors to plot all pairs plotmo1(object=mod.glmnet.sx,all2=TRUE) Warning: too many predictors to plot all pairs, so plotting degree2 plots for just the first 7 predictors. Call plotmo with all2=2 to plot degree2 plots for up to 20 predictors. plotmo grid: x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 x19 x20 0 0 > plotmo1(mod.glmnet.sx, all2=2, caption="all2=2") # test all2=2 plotmo1(object=mod.glmnet.sx,all2=2,caption="all2=2") More than 64 degree2 plots. Consider using plotmo's degree2 argument to limit the number of plots. For example, degree2=1:10 or degree2="x1" Call plotmo with trace=-1 to make this message go away. plotmo grid: x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 x19 x20 0 0 > plotmo1(mod.glmnet.sx, all2=2, degree2=1:3, caption="all2=2 degree2=1:3") plotmo1(object=mod.glmnet.sx,all2=2,degree2=1:3,caption="all2=2degree2=1:3") plotmo grid: x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 x19 x20 0 0 > plotres(mod.glmnet.sx) > par(org.par) > > par(mfrow=c(2,4), mar=c(3,3,3,1), mgp=c(1.5,0.5,0), oma=c(0,0,2.5,0)) > y <- trees$Volume > x <- as.matrix(data.frame(Girth=trees$Girth, Height=trees$Height)) > glmnet <- glmnet(x, y) > plotres(glmnet, do.par=FALSE, caption="glmnet and lm: top and bottom should be the same") > lm <- lm(Volume~., data=trees) > plotres(lm, do.par=FALSE, SHOWCALL=TRUE) > > par(mfrow=c(3,2), mar=c(3,3,3,1), mgp=c(1.5,0.5,0), oma=c(0,0,2.5,0)) > plotres(glmnet, do.par=FALSE, which=c(1,3), w1.xvar="norm", + caption="glmnet with various options", SHOWCALL=TRUE) > plotres(glmnet, trace=1, do.par=FALSE, which=c(1,3), SHOWCALL=TRUE) stats::residuals(object=elnet.object, type="response") residuals() was unsuccessful, will use predict() instead stats::predict(elnet.object, matrix[3,2], type="response", s=0) stats::fitted(object=elnet.object) fitted() was unsuccessful, will use predict() instead got model response from getCall(object)$y plot_glmnet(elnet.object, xvar="rlambda", grid.col=0, s=0, nresponse=1) training rsq 0.95 > plotres(glmnet, trace=1, do.par=FALSE, which=c(1,3), predict.s=5, SHOWCALL=TRUE) stats::residuals(object=elnet.object, type="response") residuals() was unsuccessful, will use predict() instead stats::predict(elnet.object, matrix[3,2], type="response", s=5) stats::fitted(object=elnet.object) fitted() was unsuccessful, will use predict() instead got model response from getCall(object)$y plot_glmnet(elnet.object, xvar="rlambda", grid.col=0, s=5, nresponse=1) training rsq 0.84 > par(org.par) > > printf("======== glmnet additional tests\n") ======== glmnet additional tests > set.seed(2015) > p <- 10 > n <- 30 > x <- cbind(matrix(rnorm(n*p),n,p)) > y <- rowSums(x[,1:3]^3) > glmnet <- glmnet(x,y) > plotres(glmnet, SHOWCALL=TRUE, caption="glmnet: y <- rowSums(x[,1:3]^3)") > plotres(glmnet, SHOWCALL=TRUE, w1.xvar="norm") > par(mfrow=c(1,1)) > omar <- par("mar") > ocex.axis <- par("cex.axis") > ocex.lab <- par("cex.lab") > plotres(glmnet, SHOWCALL=TRUE, which=1) > stopifnot(par("mar") == omar) > stopifnot(par("cex.axis") == ocex.axis) > stopifnot(par("cex.lab") == ocex.lab) > par(org.par) > > # test some args for plot_glmnet > plotres(glmnet, predict.s=.05, SHOWCALL=TRUE, trace=0, col.main=2, + w1.xlab="my xlab", w1.ylab="my ylab", + w1.main="test some args for plot_glmnet1", + w1.col=4:1) > > plot_glmnet(glmnet, trace=0, col.main=2, main="test some args for plot_glmnet2", + xlab="my xlab", ylab="my ylab", + col=4:1, ylim=c(-2,4)) # TODO xlim=c(-5,3)) > > plotres(glmnet, predict.s=.05, SHOWCALL=TRUE, which=c(1,3), grid.col="gray", do.par=2) > plotres(glmnet, predict.s=.05, SHOWCALL=TRUE, which=c(1,3), w1.s.col=0, do.par=0) > par(org.par) > > # TODO the following issues a stream of warnings: restarting interrupted promise evaluation > expect.err(try(plotres(glmnet, w1.col=nonesuch)), "cannot evaluate 'col'") Warning in eval(dots[[i]]) : restarting interrupted promise evaluation Warning in eval(dots[[i]]) : restarting interrupted promise evaluation Warning in eval(dots[[i]]) : restarting interrupted promise evaluation Warning in eval(dots[[i]]) : restarting interrupted promise evaluation Warning in eval(dots[[i]]) : restarting interrupted promise evaluation Warning in eval(dots[[i]]) : restarting interrupted promise evaluation Warning in eval(dots[[i]]) : restarting interrupted promise evaluation Warning in eval(dots[[i]]) : restarting interrupted promise evaluation Warning in eval(dots[[i]]) : restarting interrupted promise evaluation Warning in eval(dots[[i]]) : restarting interrupted promise evaluation Warning in eval(dots[[i]]) : restarting interrupted promise evaluation Warning in eval(dots[[i]]) : restarting interrupted promise evaluation Warning in eval(dots[[i]]) : restarting interrupted promise evaluation Warning in eval(dots[[i]]) : restarting interrupted promise evaluation Warning in eval(dots[[i]]) : restarting interrupted promise evaluation Warning in eval(dots[[i]]) : restarting interrupted promise evaluation Warning in eval(dots[[i]]) : restarting interrupted promise evaluation Warning in eval(dots[[i]], envir = env, enclos = env) : restarting interrupted promise evaluation Warning in eval(dots[[i]], envir = env, enclos = env) : restarting interrupted promise evaluation Warning in eval(dots[[i]], envir = env, enclos = env) : restarting interrupted promise evaluation Warning in eval(dots[[i]], envir = env, enclos = env) : restarting interrupted promise evaluation Warning in eval(dots[[i]], envir = env, enclos = env) : restarting interrupted promise evaluation Error in eval(dots[[idot]], parent.frame(1)) : ..6 used in an incorrect context, no ... to look in plot_glmnet(elnet.object, xvar="rlambda", grid.col=0, col=..6, s=0, nresponse=1) Error in eval(dots[[idot]], parent.frame(1)) : ..6 used in an incorrect context, no ... to look in Error : cannot evaluate 'col' Got expected error from try(plotres(glmnet, w1.col = nonesuch)) > > printf("======== glmnet multinomial (multnet)\n") ======== glmnet multinomial (multnet) > par(mfrow=c(4,4), mar=c(3,3,3,1)) > set.seed(2016) > n <- 200 > p <- 4 > x <- matrix(rnorm(n*p), n, p) > colnames(x) <- paste("x", 1:ncol(x), sep="") > > # "1" is correlated with x[,1], "4" is correlated with x[,2], "2" and "3" not correlated > y <- ifelse(x[,1] > 0.5, 1, + ifelse(x[,2] > 0.0, 4, + sample(c(2,3), size=nrow(x), replace=TRUE))) > print(cov(x, y)) [,1] x1 -0.84023279 x2 0.38654310 x3 -0.11396993 x4 -0.07611821 > y <- factor(y) > > # TODO Following causes the following warning: > # Warning: from glmnet Fortran code (error code -90); Convergence for 90th lambda value not reached after maxit=100000 iterations; solutions for larger lambdas returned > multinomial.mod <- glmnet(x, y, family="multinomial") Warning: from glmnet C++ code (error code -90); Convergence for 90th lambda value not reached after maxit=100000 iterations; solutions for larger lambdas returned > > plotres(multinomial.mod, nresponse=1, w1.main="nresponse=1", + main="family=\"multinomial\"", + smooth.col=0, info=TRUE, + trace=0, which=c(1,3), do.par=FALSE, xlim=c(-.2,1.2), ylim=c(-1.2, 1.2)) > > plotres(multinomial.mod, nresponse=2, w1.main="nresponse=2", + smooth.col=0, info=TRUE, + trace=0, which=c(1,3), do.par=FALSE, xlim=c(-.2,1.2), ylim=c(-1.2, 1.2)) > > plotres(multinomial.mod, nresponse=3, w1.main="nresponse=3", + smooth.col=0, info=TRUE, + trace=0, which=c(1,3), do.par=FALSE, xlim=c(-.2,1.2), ylim=c(-1.2, 1.2)) > > plotres(multinomial.mod, nresponse=4, w1.main="nresponse=4", + smooth.col=0, info=TRUE, + trace=0, which=c(1,3), do.par=FALSE, xlim=c(-.2,1.2), ylim=c(-1.2, 1.2)) > > plotmo(multinomial.mod, nresponse=1, trace=0, do.par=FALSE, degree1=1:2) plotmo grid: x1 x2 x3 x4 -0.01157106 0.1530614 0.04853916 0.02097713 > plotmo(multinomial.mod, nresponse=2, trace=0, do.par=FALSE, degree1=1:2) plotmo grid: x1 x2 x3 x4 -0.01157106 0.1530614 0.04853916 0.02097713 > > par(mgp=c(1.5, .4, 0)) > plot(multinomial.mod, xvar="norm") # compare to plot.glmnet > par(org.par) > > # compare to earth > par(mfrow=c(4,3), mar=c(3,3,1,1)) > yfac <- factor(c("a","b","c","d")[y]) > earth.mod <- earth(x, yfac, trace=0) > > plotres(earth.mod, nresponse=1, + main=sprint("multiresponse\nnresponse=1 rsq %.2g", earth.mod$rsq.per.response[1]), + which=3, xlim=c(-.2, 1.2), ylim=c(-1.2, 1.2), + smooth.col=0, info=TRUE, + do.par=FALSE, trace=0, jitter=7, cex.response=.7) > plotmo(earth.mod, nresponse=1, do.par=FALSE) plotmo grid: x1 x2 x3 x4 -0.01157106 0.1530614 0.04853916 0.02097713 > > plotres(earth.mod, nresponse=2, + main=sprint("nresponse=2 rsq %.2g", earth.mod$rsq.per.response[2]), + which=3, xlim=c(-.2, 1.2), ylim=c(-1.2, 1.2), + smooth.col=0, info=TRUE, + do.par=FALSE, trace=0, jitter=7, cex.response=.7) > plotmo(earth.mod, nresponse=2, do.par=FALSE) plotmo grid: x1 x2 x3 x4 -0.01157106 0.1530614 0.04853916 0.02097713 > > plotres(earth.mod, nresponse=3, + main=sprint("nresponse=3 rsq %.2g", earth.mod$rsq.per.response[3]), + which=3, xlim=c(-.2, 1.2), ylim=c(-1.2, 1.2), + smooth.col=0, info=TRUE, + do.par=FALSE, trace=0, jitter=7, cex.response=.7) > plotmo(earth.mod, nresponse=3, do.par=FALSE) plotmo grid: x1 x2 x3 x4 -0.01157106 0.1530614 0.04853916 0.02097713 > > plotres(earth.mod, nresponse=4, + main=sprint("nresponse=4 rsq %.2g", earth.mod$rsq.per.response[4]), + which=3, xlim=c(-.2, 1.2), ylim=c(-1.2, 1.2), + smooth.col=0, info=TRUE, + do.par=FALSE, trace=0, jitter=7, cex.response=.7) > plotmo(earth.mod, nresponse=4, do.par=FALSE) plotmo grid: x1 x2 x3 x4 -0.01157106 0.1530614 0.04853916 0.02097713 > > print(summary(earth.mod)) Call: earth(x=x, y=yfac, trace=0) a b c d (Intercept) -0.00759508 0.4777590 0.32170406 0.2081320 h(x1-0.333835) 2.90462369 -0.8647319 -0.45258311 -1.5873087 h(x1-0.698191) -2.95380448 0.8748909 0.44797354 1.6309401 h(x2- -0.724713) 0.00083945 0.8851614 -0.25504553 -0.6309554 h(x2- -0.399683) 0.00512171 -1.9558653 -0.04067399 1.9914176 h(x2-0.255847) -0.00181500 1.1141555 0.31084638 -1.4231869 Selected 6 of 14 terms, and 2 of 4 predictors Termination condition: Reached nk 21 Importance: x1, x2, x3-unused, x4-unused Number of terms at each degree of interaction: 1 5 (additive model) GCV RSS GRSq RSq a 0.01233701 2.203452 0.9438697 0.9493692 b 0.10618691 18.965513 0.3429519 0.4073277 c 0.08491793 15.166767 0.1053911 0.1930425 d 0.07399172 13.215291 0.6874511 0.7180738 All 0.27743357 49.551022 0.6109269 0.6490472 > > par(org.par) > > printf("======== binomial model\n") ======== binomial model > > set.seed(2019) > n <- 50 > p <- 4 > x <- matrix(rnorm(n*p), n, p) > colnames(x) <- paste("x", 1:ncol(x), sep="") > y <- ifelse(x[,1] + x[,2] + .1 * rnorm(n) > .5, TRUE, FALSE) > print(cov(x, y)) [,1] x1 0.26996406 x2 0.19322507 x3 0.04850061 x4 0.01568008 > y <- factor(y) > glmnet.binomial <- glmnet(x, y, family="binomial") > par(mfrow=c(2,3), mar=c(3,3,1,1)) > plotres(glmnet.binomial, info=T, predict.s=.02, which=c(1,3), do.par=FALSE, w1.main="glmnet.binomial") > plot(glmnet.binomial) > earth.mod <- earth(x, y) > set.seed(2019) > plotres(earth.mod, info=T, which=c(1,3), do.par=FALSE) > par(org.par) > par(mfrow=c(2,4), mar=c(3,3,1,1)) > set.seed(2019) > plotmo(glmnet.binomial, do.par=FALSE) plotmo grid: x1 x2 x3 x4 0.05687241 -0.2477018 -0.1266239 -0.2475514 > plotmo(earth.mod, do.par=FALSE, main="binomial earth.mod") plotmo grid: x1 x2 x3 x4 0.05687241 -0.2477018 -0.1266239 -0.2475514 > par(org.par) > > printf("======== glmnet family=\"mgaussian\"\n") ======== glmnet family="mgaussian" > set.seed(2015) > p <- 10 > n <- 30 > x <- cbind((1:n)/n, matrix(rnorm(n*(p-1)),n,p-1)) > colnames(x) <- paste0("x", 1:p) > # ymultresp <- cbind(rowSums(x[,1:5]^3), rowSums(x[,5:p]^3), 1:n) > set.seed(1) > ymultresp <- cbind(x[,1]+.001*rnorm(n), rowSums(x[,2:5]^3), rnorm(n)) > glmnet.mgaussian <- glmnet(x, ymultresp, family="mgaussian") > plotres(glmnet.mgaussian, nresponse=1, SHOWCALL=TRUE, which=c(1:3), do.par=2, info=1) > # manually calculate the residuals > plot(x=predict(glmnet.mgaussian, newx=x, s=0)[,1,1], + y=ymultresp[,1] - predict(glmnet.mgaussian, newx=x, s=0)[,1,1], + pch=20, xlab="Fitted", ylab="Residuals", + main="Manually calculated residuals, nresponse=1, s=0") > abline(h=0, col="gray") > par(org.par) > plotres(glmnet.mgaussian, nresponse=2, SHOWCALL=TRUE, which=c(1:3), do.par=2, info=1) > # manually calculate the residuals > plot(x=predict(glmnet.mgaussian, newx=x, s=0)[,2,1], + y=ymultresp[,2] - predict(glmnet.mgaussian, newx=x, s=0)[,2,1], + pch=20, xlab="Fitted", ylab="Residuals", + main="Manually calculated residuals, nresponse=2, s=0") > abline(h=0, col="gray") > par(org.par) > plotmo(glmnet.mgaussian, nresponse=1, SHOWCALL=TRUE) plotmo grid: x1 x2 x3 x4 x5 x6 0.5166667 0.002216547 0.3749872 -0.1927516 -0.3806807 -0.03575992 x7 x8 x9 x10 0.01386232 0.0135174 0.04028881 0.0426105 > plotmo(glmnet.mgaussian, nresponse=2, SHOWCALL=TRUE) plotmo grid: x1 x2 x3 x4 x5 x6 0.5166667 0.002216547 0.3749872 -0.1927516 -0.3806807 -0.03575992 x7 x8 x9 x10 0.01386232 0.0135174 0.04028881 0.0426105 > > graphics::par(mfrow=c(2,2), mgp=c(1.5,0.4,0), tcl=-0.3, cex.main=1, + font.main=1, mar=c(4,3,1.2,0.8), oma=c(0,0,4,0), cex=0.83) > > plotres(glmnet.mgaussian, nresponse=2, SHOWCALL=TRUE, which=3, do.par=FALSE, + caption="glmnet.mgaussian compare to manually calculated residuals") > plot(x=predict(glmnet.mgaussian, newx=x, s=0)[,2,1], + y=ymultresp[,2] - predict(glmnet.mgaussian, newx=x, s=0)[,2,1], + pch=20, xlab="Fitted", ylab="Residuals", + main="Manual residuals, nresponse=2, s=0") > abline(h=0, col="gray") > > plotres(glmnet.mgaussian, nresponse=2, predict.s=.5, SHOWCALL=TRUE, which=3, do.par=FALSE) > plot(x=predict(glmnet.mgaussian, newx=x, s=.5)[,2,1], + y=ymultresp[,2] - predict(glmnet.mgaussian, newx=x, s=.5)[,2,1], + pch=20, xlab="Fitted", ylab="Residuals", + main="Manual residuals, nresponse=2, s=.5") > abline(h=0, col="gray") > > plotres(glmnet.mgaussian, predict.s=.05, nresponse=3, info=TRUE, SHOWCALL=TRUE) # essentially random > > par(org.par) > par(mfrow=c(2,3), mar=c(3,3,3,.5), oma=c(0,0,3,0), mgp=c(1.5,0.4,0), tcl=-0.3) > > data(trees) > set.seed(2015) > # variable with a long name > x50 <- cbind(trees[,1:2], Girth12345678901234567890=rnorm(nrow(trees))) > mod.with.long.name <- glmnet(data.matrix(x50),data.matrix(trees$Volume)) > plotres(mod.with.long.name, which=1, caption="test plot_glmnet with x50 and x60") > > # one inactive variable (all coefs are zero for variable "rand") > set.seed(2015) > x60 <- cbind(trees[,1], rand=rnorm(nrow(trees)), trees[,2]) > # complicate the issue: use an unnamed column (column 3) > colnames(x60) <- c("Girth", "rand", "") > mod.with.inactive.var <- glmnet(data.matrix(x60),data.matrix(trees$Volume)) > mod.with.inactive.var$beta["rand",] = 0 # TODO hack force inactive variable > plotres(mod.with.inactive.var, which=1) > plotres(mod.with.inactive.var, which=1, w1.xvar="norm") > # compare to plot.glmnet (but note that labels aren't always plotted unless par=c(1,1)?) > plot(mod.with.inactive.var, xvar="norm", label=TRUE) > # plotmo calls the unnamed column "x3", fair enough > plotmo(mod.with.inactive.var, do.par=FALSE, pt.col=2) plotmo grid: Girth rand x3 12.9 0.004544606 76 > > # single active variable > x70 <- cbind(trees[,1,drop=F], 0) > a <- glmnet(data.matrix(x70), data.matrix(trees$Volume)) > par(org.par) > par(mfrow=c(2,2), mar=c(3,3,2,4)) > plotres(a, which=1, predict.s=1, caption="single active variable") > plotres(a, which=1, w1.xvar="norm") > plotres(a, which=1, w1.xvar="lambda") > plotres(a, which=1, w1.xvar="dev") > > #--- test interaction of w1. and non w1 args ------------------------------------- > > #--- glmnet model, which=1 --- > > par(org.par) > par(mfrow=c(4,3), mar=c(3, 3, 4, 1), mgp=c(2, 0.6, 0)) > > plotres(mod.glmnet.xmat, which=1, + w1.xlim=c(6,-6), + w1.ylim=c(-5,5), + w1.col=1:2, + w1.main="TEST INTERACTION OF W1 ARGS PAGE 1 (which=1)\n\nwhich=1 w1.xlim=c(6,-6)\nw1.ylim=c(-5,5)) w1.col=1:2,") > > plotres(mod.glmnet.xmat, which=1, cex.main=1.2, + xlim=c(9,-9), + ylim=c(-60,60), + col=3:4, + w1.main="which=1 xlim=c(9,-9)\nylim=c(-60,60)) col=3:4,") > > plotres(mod.glmnet.xmat, which=1, cex.main=1, + xlim=c(9,-9), w1.xlim=c(6,-6), + ylim=c(-60,60), w1.ylim=c(-5,5), + w1.col=1:2, col=3:4, + w1.main="which=1 xlim=c(9,-9), w1.xlim=c(6,-6)\nylim=c(-60,60), w1.ylim=c(-5,5)) w1.col=1:2, col=3:4") > > #--- glmnet model, which=c(1,3,4) --- > > plotres(mod.glmnet.xmat, which=c(1,3,4), cex.main=1, + ylim=c(-70,70), xlim=c(-20, 60), + col=2:3, do.par=FALSE, + w1.main="TEST INTERACTION OF W1 ARGS PAGE 1 (which=c(1,3,4))\nlim=c(-70,70), xlim=c(-20, 60)") > > plotres(mod.glmnet.xmat, which=c(1,3,4), cex.main=1.2, + ylim=c(-70,70), xlim=c(-20, 60), qq.xlim=c(-7,5), + col=2:3, do.par=FALSE, + w1.main="ylim=c(-70,70), xlim=c(-20, 60)\nqq.xlim=c(-7,5)") > > plotres(mod.glmnet.xmat, which=c(1,3,4), cex.main=1.2, + w1.ylim=c(-7,7), w1.xlim=c(4,-4), col=2:3, do.par=FALSE, + w1.main="w1.ylim=c(-7,7), w1.xlim=c(4,-4)") > > # plotres(mod.glmnet.xmat, which=c(1,3,4), cex.main=.9, > # w1.ylim=c(-7,7), ylim=c(-20,20), > # qq.xlim=c(-7,5), col=2:3, do.par=FALSE, > # qq.ylim=c(-100,100), > # main="w1.ylim=c(-7,7) ylim=c(-20,20)\nqq.xlim=c(-7,5) qq.ylim=c(-100,100)") > > par(org.par) > par(mfrow=c(3,3), mar=c(3, 3, 4, 1), mgp=c(2, 0.6, 0)) > > plotres(mod.glmnet.xmat, which=c(1,3,4), do.par=FALSE, # w1.main="which=c(1,3,4)", + w1.xlim=c(6,-6), + w1.ylim=c(-5,5), + w1.col=2:3, + w1.main="TEST INTERACTION OF W1 ARGS PAGE 2\n\nwhich=c(1,3,4) w1.xlim=c(6,-6)\nw1.ylim=c(-5,5)) w1.col=2:3") > > plotres(mod.glmnet.xmat, which=c(1,3,4), w1.cex.main=1, do.par=FALSE, # w1.main="which=c(1,3,4)", + xlim=c(-20,70), + ylim=c(-60,60), + w1.col=2:3, + col=3:4, + w1.main="which=c(1,3,4) ylim=c(-60,60))\nw1.col=2:3, col=3:4") > > plotres(mod.glmnet.xmat, which=c(1,3,4), w1.cex.main=1, do.par=FALSE, # w1.main="which=c(1,3,4)", + xlim=c(-20,70), w1.xlim=c(6,-6), + ylim=c(-60,60), w1.ylim=c(-5,5), + col=3:4, + w1.main="which=c(1,3,4) xlim=c(9,-9), w1.xlim=c(6,-6)\nylim=c(-60,60), w1.ylim=c(-5,5)) w1.col=1:2, col=3:4") > > par(org.par) > > #-- make sure that we can work with all families > > set.seed(2016) > par(mfrow=c(3,3), mar=c(3,3,3,1)) > n <- 100 > p <- 4 > x <- matrix(rnorm(n*p), n, p) > g2 <- sample(1:2, n, replace=TRUE) > for(family in c("gaussian","binomial","poisson")) { + mod <- glmnet(x,g2,family=family) + plot(mod, xvar="lambda") + plotres(mod, w1.xvar="lambda", main=paste("family", family), + which=c(1,3), do.par=FALSE) + } > # cox > library(plotmo) > n <- 100 > p <- 20 > nzc <- trunc(p/10) > set.seed(2016) > beta <- rnorm(nzc) > x7 <- matrix(rnorm(n*p), n, p) > beta <- rnorm(nzc) > fx <- x7[,seq(nzc)] %*% beta/3 > hx <- exp(fx) > ty <- rexp(n, hx) > tcens <- rbinom(n=n, prob=.3, size=1)# censoring indicator > y <- cbind(time=ty, status=1-tcens) # y=Surv(ty,1-tcens) with library(survival) > glmnet.cox <- glmnet(x=x7, y=y, family="cox") > plot(glmnet.cox) > title("glmnet.cox", line=2) > plot_glmnet(glmnet.cox, xvar="norm") > plotres(glmnet.cox, which=3, do.par=FALSE) > par(org.par) > > # test col argument > par(mfrow=c(2,3), mar=c(3,3,5,1), cex=1) > mod <- glmnet(as.matrix(mtcars[-1]), mtcars[,1]) > plot_glmnet(mod, main="plot_glmnet default") > plot_glmnet(mod, col=c(1,2,3,0,0,NA,0,0,0,0), main="col=c(1,2,3,0,0,NA,0,0,0,0)") > g <- "gray" > plot_glmnet(mod, col=c("black","red","green",g,g,g,g,g,"steelblue","darkorange"), main="col=c('black','red','green',g,g,g,g,g,'steelblue','darkorange')") > plot_glmnet(mod, col=c("black","red","green",0,0,0,0,0,"steelblue","darkorange"), main="col=c('black','red','green',0,0,0,0,0,'steelblue','darkorange')") > plot_glmnet(mod, col=c("black","red", 0), main="col=c('black','red', 0)") # test recycling, including 0 > par(org.par) > > source("test.epilog.R") plotmo/inst/slowtests/test.partdep.bat0000755000176200001440000000150714655214117017731 0ustar liggesusers@rem test.partdep.bat: partdep tests for plotmo and plotres @echo test.partdep.bat @"C:\PROGRA~1\R\R-4.4.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.partykit.Rout.save0000644000176200001440000005361714567065443021277 0ustar liggesusers> # test.partykit.R: test partykit and evtree packages > > source("test.prolog.R") > library(plotmo) Loading required package: Formula Loading required package: plotrix > library(partykit) Loading required package: grid Loading required package: libcoin Loading required package: mvtnorm > data("BostonHousing", package = "mlbench") > data("PimaIndiansDiabetes", package = "mlbench") > > # lmtree > > boston <- transform(BostonHousing, + chas = factor(chas, levels = 0:1, labels = c("no", "yes")), + rad = factor(rad, ordered = TRUE)) > set.seed(2018) > lmtree.boston1 <- lmtree(medv ~ log(lstat) + rm^2 | + crim + ptratio + tax + dis + rad + chas, + data = boston, minsize = 40) > > boston2 <- boston > boston2$log.lstat <- log(boston2$lstat) > boston2$lstat <- NULL > boston2$rm.squared <- boston2$rm^2 > boston2$rm <- NULL > set.seed(2018) > lmtree.boston2 <- lmtree(medv ~ log.lstat + rm.squared | + crim + ptratio + tax + dis + rad + chas, + data = boston2, minsize = 40) > > plot(lmtree.boston1) > plot(lmtree.boston2) > > plotmo(lmtree.boston1, SHOWCALL=TRUE) plotmo grid: lstat rm crim ptratio tax dis rad chas 11.36 6.2085 0.25651 19.05 330 3.20745 24 no > plotmo(lmtree.boston2, trace=2, SHOWCALL=TRUE) plotmo trace 2: plotmo(object=lmtree.boston2, trace=2, SHOWCALL=TRUE) --get.model.env for object with class lmtree object call is lmtree(formula=medv~log.lstat+rm.squared|crim+ptratio+tax+dis+rad+chas, data=boston2, minsize=40) using the environment saved in $terms of the lmtree model: R_GlobalEnv --plotmo_prolog for lmtree object 'lmtree.boston2' variable importance: log.lstat rm.squared tax ptratio changing class of 'lmtree.boston2' from c("lmtree", "modelparty", "party") to "party_plotmo" for standard "[[" --plotmo_x for party_plotmo object get.object.x: object$x is NULL (and it has no colnames) object call is lmtree(formula=medv~log.lstat+rm.squared|crim+ptratio+tax+dis+rad+chas, data=... get.x.from.model.frame: formula(object) is medv ~ log.lstat + rm.squared + (crim + ptratio + tax + d... naked formula is medv ~ log.lstat + rm.squared + crim + ptratio + tax + dis + rad + chas formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names crim zn indus chas nox age dis rad tax ptratio b medv log.lstat rm.squared na.action(object) is "na.pass" stats::model.frame(medv ~ log.lstat + rm.squared + crim ..., data=call$data, na.action="na.pass") x=model.frame[,-1] is usable and has column names log.lstat rm.squared crim ptratio tax dis rad chas plotmo_x returned[506,8]: log.lstat rm.squared crim ptratio tax dis rad chas 1 1.605430 43.23063 0.00632 15.3 296 4.0900 1 no 2 2.212660 41.22924 0.02731 17.8 242 4.9671 2 no 3 1.393766 51.62422 0.02729 17.8 242 4.9671 2 no ... 1.078410 48.97200 0.03237 18.7 222 6.0622 3 no 506 2.064328 36.36090 0.04741 21.0 273 2.5050 1 no factors: rad(ordered) chas ----Metadata: plotmo_predict with nresponse=NULL and newdata=NULL plotmo_predict with NULL newdata (nrows=3), using plotmo_x to get the data --plotmo_x for party_plotmo object get.object.x: object$x is NULL (and it has no colnames) object call is lmtree(formula=medv~log.lstat+rm.squared|crim+ptratio+tax+dis+rad+chas, data=... get.x.from.model.frame: formula(object) is medv ~ log.lstat + rm.squared + (crim + ptratio + tax + d... naked formula is medv ~ log.lstat + rm.squared + crim + ptratio + tax + dis + rad + chas formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names crim zn indus chas nox age dis rad tax ptratio b medv log.lstat rm.squared na.action(object) is "na.pass" stats::model.frame(medv ~ log.lstat + rm.squared + crim ..., data=call$data, na.action="na.pass") x=model.frame[,-1] is usable and has column names log.lstat rm.squared crim ptratio tax dis rad chas plotmo_x returned[506,8]: log.lstat rm.squared crim ptratio tax dis rad chas 1 1.605430 43.23063 0.00632 15.3 296 4.0900 1 no 2 2.212660 41.22924 0.02731 17.8 242 4.9671 2 no 3 1.393766 51.62422 0.02729 17.8 242 4.9671 2 no ... 1.078410 48.97200 0.03237 18.7 222 6.0622 3 no 506 2.064328 36.36090 0.04741 21.0 273 2.5050 1 no factors: rad(ordered) chas will use the above data instead of newdata=NULL for predict.party_plotmo stats::predict(lmtree.object, data.frame[3,8], type="response") predict returned[3,1] with no column names: 1 26.03975 2 26.21389 3 35.63227 predict after processing with nresponse=NULL is [3,1] with no column names: 1 26.03975 2 26.21389 3 35.63227 ----Metadata: plotmo_fitted with nresponse=NULL stats::fitted(object=party_plotmo.object) fitted(object) returned[506,1]: (fitted) 1 7 2 6 3 6 ... 6 506 8 fitted(object) after processing with nresponse=NULL is [506,1]: (fitted) 1 7 2 6 3 6 ... 6 506 8 ----Metadata: plotmo_y with nresponse=NULL --plotmo_y with nresponse=NULL for party_plotmo object get.object.y: object$y is NULL (and it has no colnames) object call is lmtree(formula=medv~log.lstat+rm.squared|crim+ptratio+tax+dis+rad+chas, data=... get.y.from.model.frame: formula(object) is medv ~ log.lstat + rm.squared + (crim + ptratio + tax + d... formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names crim zn indus chas nox age dis rad tax ptratio b medv log.lstat rm.squared na.action(object) is "na.pass" stats::model.frame(medv ~ log.lstat + rm.squared + (crim..., data=call$data, na.action="na.pass") y=model.frame[,1] is usable and has column name medv plotmo_y returned[506,1]: medv 1 24.0 2 21.6 3 34.7 ... 33.4 506 11.9 plotmo_y after processing with nresponse=NULL is [506,1]: medv 1 24.0 2 21.6 3 34.7 ... 33.4 506 11.9 converted nresponse=NA to nresponse=1 nresponse=1 (was NA) ncol(fitted) 1 ncol(predict) 1 ncol(y) 1 ----Metadata: plotmo_y with nresponse=1 --plotmo_y with nresponse=1 for party_plotmo object get.object.y: object$y is NULL (and it has no colnames) object call is lmtree(formula=medv~log.lstat+rm.squared|crim+ptratio+tax+dis+rad+chas, data=... get.y.from.model.frame: formula(object) is medv ~ log.lstat + rm.squared + (crim + ptratio + tax + d... formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names crim zn indus chas nox age dis rad tax ptratio b medv log.lstat rm.squared na.action(object) is "na.pass" stats::model.frame(medv ~ log.lstat + rm.squared + (crim..., data=call$data, na.action="na.pass") y=model.frame[,1] is usable and has column name medv got model response from model.frame(medv ~ log.lstat + rm.squared + (crim..., data=call$data, na.action="na.pass") plotmo_y returned[506,1]: medv 1 24.0 2 21.6 3 34.7 ... 33.4 506 11.9 plotmo_y after processing with nresponse=1 is [506,1]: medv 1 24.0 2 21.6 3 34.7 ... 33.4 506 11.9 got response name "medv" from yfull resp.levs is NULL ----Metadata: done number of x values: log.lstat 455 rm.squared 446 crim 504 ptratio 46 tax 66 d... ----plotmo_singles for party_plotmo object singles: 1 log.lstat, 2 rm.squared, 4 ptratio, 5 tax ----plotmo_pairs for party_plotmo object pairs: [,1] [,2] [1,] "1 log.lstat" "2 rm.squared" [2,] "1 log.lstat" "4 ptratio" [3,] "1 log.lstat" "5 tax" [4,] "2 rm.squared" "4 ptratio" [5,] "2 rm.squared" "5 tax" [6,] "4 ptratio" "5 tax" graphics::par(mfrow=c(4,4), mgp=c(1.5,0.4,0), tcl=-0.3, font.main=2, mar=c(3,2,1.2,0.8), oma=c(0,0,4,0), cex.main=1.1, cex.lab=1, cex.axis=1, cex=0.66) ----Figuring out ylim --get.ylim.by.dummy.plots --plot.degree1(draw.plot=FALSE) degree1 plot1 (pmethod "plotmo") variable log.lstat newdata[50,8]: log.lstat rm.squared crim ptratio tax dis rad chas 1 0.5481214 38.54547 0.25651 19.05 330 3.20745 24 no 2 0.6111556 38.54547 0.25651 19.05 330 3.20745 24 no 3 0.6741898 38.54547 0.25651 19.05 330 3.20745 24 no ... 0.7372240 38.54547 0.25651 19.05 330 3.20745 24 no 50 3.6367964 38.54547 0.25651 19.05 330 3.20745 24 no factors: rad(ordered) chas stats::predict(lmtree.object, data.frame[50,8], type="response") predict returned[50,1] with no column names: 1 23.25924 2 23.24236 3 23.22549 ... 23.20861 50 22.43238 predict after processing with nresponse=1 is [50,1]: predict 1 23.25924 2 23.24236 3 23.22549 ... 23.20861 50 22.43238 Reducing trace level for subsequent degree1 plots degree1 plot2 (pmethod "plotmo") variable rm.squared degree1 plot3 (pmethod "plotmo") variable ptratio degree1 plot4 (pmethod "plotmo") variable tax --plot.degree2(draw.plot=FALSE) degree2 plot1 (pmethod "plotmo") variables log.lstat:rm.squared newdata[400,8]: log.lstat rm.squared crim ptratio tax dis rad chas 1 0.5481214 12.68072 0.25651 19.05 330 3.20745 24 no 2 0.7106832 12.68072 0.25651 19.05 330 3.20745 24 no 3 0.8732451 12.68072 0.25651 19.05 330 3.20745 24 no ... 1.0358069 12.68072 0.25651 19.05 330 3.20745 24 no 400 3.6367964 77.08840 0.25651 19.05 330 3.20745 24 no factors: rad(ordered) chas stats::predict(lmtree.object, data.frame[400,8], type="response") predict returned[400,1] with no column names: 1 6.346628 2 6.303109 3 6.259590 ... 6.216071 400 47.635075 predict after processing with nresponse=1 is [400,1]: predict 1 6.346628 2 6.303109 3 6.259590 ... 6.216071 400 47.635075 Reducing trace level for subsequent degree2 plots degree2 plot2 (pmethod "plotmo") variables log.lstat:ptratio degree2 plot3 (pmethod "plotmo") variables log.lstat:tax degree2 plot4 (pmethod "plotmo") variables rm.squared:ptratio degree2 plot5 (pmethod "plotmo") variables rm.squared:tax degree2 plot6 (pmethod "plotmo") variables ptratio:tax --done get.ylim.by.dummy.plots ylim c(3.124, 53.64) clip TRUE --plot.degree1(draw.plot=TRUE) plotmo grid: log.lstat rm.squared crim ptratio tax dis rad chas 2.430097 38.54547 0.25651 19.05 330 3.20745 24 no graphics::plot.default(x=c(0.548,0.611,0...), y=c(23.26,23.24,2...), type="n", main="1 log.lstat", xlab="", ylab="", xaxt="s", yaxt="s", xlim=c(0.548,3.637), ylim=c(3.12,53.64)) --plot.degree2(draw.plot=TRUE) persp(log.lstat:rm.squard) theta 55 persp(log.lstat:ptratio) theta 145 persp(log.lstat:tax) theta 55 persp(rm.squard:ptratio) theta 235 persp(rm.squard:tax) theta 235 persp(ptratio:tax) theta 145 > plotmo(lmtree.boston2, trace=1, all1=TRUE, degree2=c("ptratio", "log.lstat"), SHOWCALL=TRUE) variable importance: log.lstat rm.squared tax ptratio stats::predict(lmtree.object, data.frame[3,8], type="response") stats::fitted(object=party_plotmo.object) got model response from model.frame(medv ~ log.lstat + rm.squared + (crim..., data=call$data, na.action="na.pass") plotmo grid: log.lstat rm.squared crim ptratio tax dis rad chas 2.430097 38.54547 0.25651 19.05 330 3.20745 24 no > plotmo(lmtree.boston2, all1=TRUE, all2=TRUE, SHOWCALL=TRUE) plotmo grid: log.lstat rm.squared crim ptratio tax dis rad chas 2.430097 38.54547 0.25651 19.05 330 3.20745 24 no > > # TODO gives warnings because of because of price/citations in formula > # data("Journals", package = "AER") > # Journals <- transform(Journals, > # age = 2000 - foundingyear, > # chars = charpp * pages) > # j_tree <- lmtree(log(subs) ~ log(price/citations) | price + citations + > # age + chars + society, data = Journals, minsize = 10) > # plotmo(j_tree, SHOWCALL=TRUE) > > # Works, but commented out to save testing time: > # data("TeachingRatings", package = "AER") > # tr_tree <- lmtree(eval ~ beauty | age + gender + division, > # data = TeachingRatings, weights = students, subset = credits == "more", > # caseweights = FALSE) > # plot(tr_tree) > # plotmo(tr_tree, all1=TRUE, all2=TRUE, SHOWCALL=TRUE) > > # glmtree > > glmtree1 <- glmtree(diabetes ~ glucose | mass + age, + data = PimaIndiansDiabetes, family = binomial) > plot(glmtree1) Loading required namespace: vcd > plotmo(glmtree1, SHOWCALL=TRUE) plotmo grid: glucose mass age 117 32 29 > plotmo(glmtree1, all2=TRUE, SHOWCALL=TRUE) plotmo grid: glucose mass age 117 32 29 > > # mob > > pima <- PimaIndiansDiabetes[1:50,] # small set of data for fast test > > logit1 <- function(y, x, start = NULL, weights = NULL, offset = NULL, ...) + { + # note that a complicated formula is necessary + formula <- as.formula(paste("y ~ ", paste(colnames(x)[-1], collapse="+"))) # -1 drops intercept + glm(formula=formula, data=as.data.frame(x), family=binomial, start=start, ...) + } > mob1 <- mob(diabetes ~ glucose | mass + age, + data = PimaIndiansDiabetes, fit = logit1) > plot(mob1) > plotmo(mob1, trace=1, SHOWCALL=TRUE) variable importance: glucose mass age stats::predict(modelparty.object, data.frame[3,3], type="response") stats::fitted(object=party_plotmo.object) got model response from model.frame(diabetes ~ glucose + (mass + age), data=call$data, na.action="na.pass") plotmo grid: glucose mass age 117 32 29 > plotmo(mob1, pmethod="partdep", degree1=0, + degree2=c("glucose", "mass"), persp.ticktype="detailed", SHOWCALL=TRUE) calculating partdep for glucose:mass 01234567890 > plotmo(mob1, all1=TRUE, all2=TRUE, SHOWCALL=TRUE) plotmo grid: glucose mass age 117 32 29 > > logit2 <- function(y, x, start = NULL, weights = NULL, offset = NULL, ...) + { + glm(y ~ 0 + x, family = binomial, start = start, ...) + } > mob2 <- mob(diabetes ~ glucose | mass, data = pima, fit = logit2) > expect.err(try(plotmo(mob2)), "The formula in the mob fit function is not supported by plotmo") The following formula in the mob fit function is not supported by plotmo: glm(y ~ 0 + x, family = binomial, start = start, ...) Possible workaround: Replace the fit function with: logit2 <- function (y, x, start = NULL, weights = NULL, offset = NULL, ...) { glm(as.formula(paste("y ~ ", paste(colnames(x)[-1], collapse="+"))), data=x, family = binomial, start = start, ...) } Error : The formula in the mob fit function is not supported by plotmo (see above) This is because predict.mob often fails with newdata and type="response" e.g. example(mob); predict(pid_tree, newdata=PimaIndiansDiabetes[1:3,], type="response") Got expected error from try(plotmo(mob2)) > > logit3 <- function(y, x, start = NULL, weights = NULL, offset = NULL, ...) + { + glm(y ~ 0+x , family = binomial, start = start, ...) + } > mob3 <- mob(diabetes ~ glucose | age, data = pima, fit = logit3) > expect.err(try(plotmo(mob3)), "The formula in the mob fit function is not supported by plotmo") The following formula in the mob fit function is not supported by plotmo: glm(y ~ 0 + x, family = binomial, start = start, ...) Possible workaround: Replace the fit function with: logit3 <- function (y, x, start = NULL, weights = NULL, offset = NULL, ...) { glm(as.formula(paste("y ~ ", paste(colnames(x)[-1], collapse="+"))), data=x, family = binomial, start = start, ...) } Error : The formula in the mob fit function is not supported by plotmo (see above) This is because predict.mob often fails with newdata and type="response" e.g. example(mob); predict(pid_tree, newdata=PimaIndiansDiabetes[1:3,], type="response") Got expected error from try(plotmo(mob3)) > > logit4 <- function(y, x, start = NULL, weights = NULL, offset = NULL, ...) + { + glm(y ~ x - 1, family = binomial, start = start, ...) + } > mob4 <- mob(diabetes ~ glucose | age, data = pima, fit = logit4) > expect.err(try(plotmo(mob4)), "The formula in the mob fit function is not supported by plotmo") The following formula in the mob fit function is not supported by plotmo: glm(y ~ x - 1, family = binomial, start = start, ...) Possible workaround: Replace the fit function with: logit4 <- function (y, x, start = NULL, weights = NULL, offset = NULL, ...) { glm(as.formula(paste("y ~ ", paste(colnames(x)[-1], collapse="+"))), data=x, family = binomial, start = start, ...) } Error : The formula in the mob fit function is not supported by plotmo (see above) This is because predict.mob often fails with newdata and type="response" e.g. example(mob); predict(pid_tree, newdata=PimaIndiansDiabetes[1:3,], type="response") Got expected error from try(plotmo(mob4)) > > logit5 <- function(y, x, start = NULL, weights = NULL, offset = NULL, ...) + { + glm(y~x-1 , family = binomial, start = start, ...) + } > mob5 <- mob(diabetes ~ glucose | age, data = pima, fit = logit5) > expect.err(try(plotmo(mob5)), "The formula in the mob fit function is not supported by plotmo") The following formula in the mob fit function is not supported by plotmo: glm(y ~ x - 1, family = binomial, start = start, ...) Possible workaround: Replace the fit function with: logit5 <- function (y, x, start = NULL, weights = NULL, offset = NULL, ...) { glm(as.formula(paste("y ~ ", paste(colnames(x)[-1], collapse="+"))), data=x, family = binomial, start = start, ...) } Error : The formula in the mob fit function is not supported by plotmo (see above) This is because predict.mob often fails with newdata and type="response" e.g. example(mob); predict(pid_tree, newdata=PimaIndiansDiabetes[1:3,], type="response") Got expected error from try(plotmo(mob5)) > > logit6 <- function (y, x, start = NULL, weights = NULL, offset = NULL, ...) + { + glm(as.formula(paste("y ~ ", paste(colnames(x)[-1], collapse="+"))), + data=data.frame(x), family = binomial, start = start, ...) + } > mob6 <- mob(diabetes ~ glucose | mass + age, data = pima, fit = logit6) > plot(mob6) # tree is just a root (no branches) > plotmo(mob6) plotmo grid: glucose mass age 118.5 31.35 33 > > library(rpart.plot) Loading required package: rpart > rpart.Kyphosis <- rpart(Kyphosis ~ Age + Number + Start, data = kyphosis) > plotmo(rpart.Kyphosis, SHOWCALL=TRUE) plotmo grid: Age Number Start 87 4 13 > party.Kyphosis <- as.party(rpart.Kyphosis) > expect.err(try(plotmo(party.Kyphosis)), "cannot get the original model predictors") Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: object 'Kyphosis' not found (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(plotmo(party.Kyphosis)) > > library(evtree) > ## regression > set.seed(1090) > airq <- subset(airquality, !is.na(Ozone) & complete.cases(airquality)) > ev_air <- evtree(Ozone ~ ., data = airq) > # plot(ev_air) > plotmo(ev_air, SHOWCALL=TRUE) plotmo grid: Solar.R Wind Temp Month Day 207 9.7 79 7 16 > ## classification > ev_iris <- evtree(Species ~ .,data = iris) > # plot(ev_iris) > plotmo(ev_iris, SHOWCALL=TRUE) plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 5.8 3 4.35 1.3 > plotmo(ev_iris, type="prob", nresponse="versicolor", pmethod="apartdep", SHOWCALL=TRUE) calculating apartdep for Petal.Length calculating apartdep for Petal.Width calculating apartdep for Petal.Length:Petal.Width 01234567890 > plotres(ev_iris, type="prob", nresponse="setosa", SHOWCALL=TRUE) > > # cforest > > cforest1 <- cforest(dist ~ speed, data = cars) > plotmo(cforest1, trace=1, SHOWCALL=TRUE) variable importance: speed stats::predict(cforest.object, data.frame[3,1], type="response") stats::fitted(object=cforest.object) got model response from model.frame(dist ~ speed, data=object$data, na.action="na.fail") > plotres(cforest1, trace=1, SHOWCALL=TRUE) variable importance: speed stats::residuals(object=cforest.object, type="response") residuals() was unsuccessful, will use predict() instead stats::predict(cforest.object, data.frame[3,1], type="response") stats::fitted(object=cforest.object) got model response from model.frame(dist ~ speed, data=object$data, na.action="na.fail") training rsq 0.58 > > data("mammoexp", package = "TH.data") > cforest2 <- cforest(ME ~ PB + SYMPT, data = mammoexp, ntree = 5) > plotmo(cforest2, trace=1, SHOWCALL=TRUE, pmethod="apartdep") variable importance: SYMPT PB stats::predict(cforest.object, data.frame[3,2], type="response") stats::fitted(object=cforest.object) got model response from model.frame(ME ~ PB + SYMPT, data=object$data, na.action="na.fail") calculating apartdep for PB calculating apartdep for SYMPT calculating apartdep for PB:SYMPT 01234567890 > plotres(cforest2) > > source("test.epilog.R") plotmo/inst/slowtests/test.plotmo.bat0000755000176200001440000000154514655214117017606 0ustar liggesusers@rem test.plotmo.bat: this does a regression test of plotmo @rem Stephen Milborrow Apr 2007 Petaluma @echo test.plotmo.bat @"C:\PROGRA~1\R\R-4.4.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.unusual.vars.Rout.save0000644000176200001440000023145414567065443022073 0ustar liggesusers> # test.unusual.vars.R: test unusual variable names, and unusual formulas > # > # This file was initially created for plotmo 3.6.0 (Sep 2020) > # ALso tests the naken() func introduced in plotmo 3.6.0 and earth 5.2.0 (Sep 2020) > > source("test.prolog.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix > data(ozone1) > data(etitanic) > options(warn=1) # print warnings as they occur > > check.naken <- function(s, expected, trace=0) + { + nude <- plotmo:::naken.formula.string(s, trace=trace) + printf("%-60.60s %-s\n", s, nude) + stopifnot(nude == expected) + } > printf("=== check naken.formula.string\n") === check naken.formula.string > > # edge cases > check.naken("", "") > check.naken(" ", "") > check.naken("y~", "y ~ ") y~ y ~ > check.naken("y~ ", "y ~ ") y~ y ~ > check.naken("y ~ ", "y ~ ") y ~ y ~ > check.naken("y ~ ", "y ~ ") y ~ y ~ > check.naken(" y ~ ", "y ~ ") y ~ y ~ > check.naken("[", "[", trace=2) naked formula is the same [ [ > check.naken("`", "`", trace=2) naked formula is the same ` ` > # standard formulas > check.naken("x", "x") x x > check.naken("x1", "x1") x1 x1 > check.naken("y ~ x1 : x2 + x3", "y ~ x1 + x2 + x3", trace=2) naked formula is y ~ x1 + x2 + x3 y ~ x1 : x2 + x3 y ~ x1 + x2 + x3 > check.naken("y ~ x1 + x2 - x3", "y ~ x1 + x2 + x3", trace=2) # TODO "-" is treated as a "+" naked formula is y ~ x1 + x2 + x3 y ~ x1 + x2 - x3 y ~ x1 + x2 + x3 > check.naken("y ~ .-x3", "y ~ . + x3") y ~ .-x3 y ~ . + x3 > check.naken("cbind(damage, 6-damage)~temp", "cbind(damage, 6-damage) ~ temp", trace=2) naked formula is the same cbind(damage, 6-damage)~temp cbind(damage, 6-damage) ~ temp > check.naken("depIndex~q_4 + q_2102+q_2104 +q_3105+ q_3106", "depIndex ~ q_4 + q_2102 + q_2104 + q_3105 + q_3106") depIndex~q_4 + q_2102+q_2104 +q_3105+ q_3106 depIndex ~ q_4 + q_2102 + q_2104 + q_3105 + q_3106 > check.naken("doy ~ (vh+wind+humidity)^2", "doy ~ vh + wind + humidity") doy ~ (vh+wind+humidity)^2 doy ~ vh + wind + humidity > check.naken("doy ~ s(wind) + s(humidity,wind) + s(vh)", "doy ~ wind + humidity + vh") doy ~ s(wind) + s(humidity,wind) + s(vh) doy ~ wind + humidity + vh > check.naken("log(doy) ~ I(vh*wind) + I(humidity*temp)+log(doy)", "log(doy) ~ vh + wind + humidity + temp + doy") log(doy) ~ I(vh*wind) + I(humidity*temp)+log(doy) log(doy) ~ vh + wind + humidity + temp + doy > check.naken("log(doy)~vh+wind+humidity+I(wind*humidity)+temp+log(ibh)", "log(doy) ~ vh + wind + humidity + temp + ibh", trace=2) naked formula is log(doy) ~ vh + wind + humidity + temp + ibh log(doy)~vh+wind+humidity+I(wind*humidity)+temp+log(ibh) log(doy) ~ vh + wind + humidity + temp + ibh > check.naken("O3 ~ s(humidity)+s(temp)+s(ibt)+s(temp,ibt)", "O3 ~ humidity + temp + ibt") O3 ~ s(humidity)+s(temp)+s(ibt)+s(temp,ibt) O3 ~ humidity + temp + ibt > check.naken("Ozone^(1/3) ~ lo(Solar.R) + lo(Wind, Temp)", "Ozone^(1/3) ~ Solar.R + Wind + Temp") Ozone^(1/3) ~ lo(Solar.R) + lo(Wind, Temp) Ozone^(1/3) ~ Solar.R + Wind + Temp > check.naken("Volume~(Girth*Height2)-Height", "Volume ~ Girth + Height2 + Height") Volume~(Girth*Height2)-Height Volume ~ Girth + Height2 + Height > check.naken("y ~ s(x) + s(x,z1)", "y ~ x + z1") y ~ s(x) + s(x,z1) y ~ x + z1 > check.naken("y~s(x0,x1,k=12)+s(x2)+s(x3,k=20,fx=20)", "y ~ x0 + x1 + x2 + x3") y~s(x0,x1,k=12)+s(x2)+s(x3,k=20,fx=20) y ~ x0 + x1 + x2 + x3 > check.naken("y~x[,1]+x[,2]", "y ~ x[,1] + x[,2]") y~x[,1]+x[,2] y ~ x[,1] + x[,2] > check.naken("y~x[,1]+x[,my.list$j]", "y ~ x[,1] + x[,my.list$j]") y~x[,1]+x[,my.list$j] y ~ x[,1] + x[,my.list$j] > check.naken("y~x[,i]+x[,2]", "y ~ x[,i] + x[,2]") y~x[,i]+x[,2] y ~ x[,i] + x[,2] > check.naken("Salary~Hitters[,1]", "Salary ~ Hitters[,1]", trace=2) naked formula is the same Salary~Hitters[,1] Salary ~ Hitters[,1] > check.naken("Salary~Hitters[,-1]", "Salary ~ Hitters[,-1]", trace=2) naked formula is the same Salary~Hitters[,-1] Salary ~ Hitters[,-1] > check.naken("Salary~Hitters[,c(1,2)]", "Salary ~ Hitters[,c(1,2)]", trace=2) naked formula is the same Salary~Hitters[,c(1,2)] Salary ~ Hitters[,c(1,2)] > check.naken("Salary~Hitters[,1:2]", "Salary ~ Hitters[,1:2]") Salary~Hitters[,1:2] Salary ~ Hitters[,1:2] > check.naken("Salary~Hitters[,c(1,2)]", "Salary ~ Hitters[,c(1,2)]", trace=2) naked formula is the same Salary~Hitters[,c(1,2)] Salary ~ Hitters[,c(1,2)] > # nested brackets > check.naken("y ~ x1[[2]] + x1[[3]]", "y ~ x1[[2]] + x1[[3]]") y ~ x1[[2]] + x1[[3]] y ~ x1[[2]] + x1[[3]] > check.naken("y[ , 1 ] ~ x1[[2]]", "y[ , 1 ] ~ x1[[2]]") y[ , 1 ] ~ x1[[2]] y[ , 1 ] ~ x1[[2]] > check.naken("y ~ x0[,nonesuch1 + x1[nsuch2^2 + 3 ]]", "y ~ x0[,nonesuch1 + x1[nsuch2^2 + 3 ]]") y ~ x0[,nonesuch1 + x1[nsuch2^2 + 3 ]] y ~ x0[,nonesuch1 + x1[nsuch2^2 + 3 ]] > check.naken("y ~ x0[1,x2[3]] + x4[[5]] + x6[ x7[, 8], x9[ ,x10[11] ], drop=x12[13]]", "y ~ x0[1,x2[3]] + x4[[5]] + x6[ x7[, 8], x9[ ,x10[11] ], drop=x12[13]]") y ~ x0[1,x2[3]] + x4[[5]] + x6[ x7[, 8], x9[ ,x10[11] ], dro y ~ x0[1,x2[3]] + x4[[5]] + x6[ x7[, 8], x9[ ,x10[11] ], drop=x12[13]] > # backquotes > check.naken("y ~ `a b c10` + `def`", "y ~ `a b c10` + `def`") y ~ `a b c10` + `def` y ~ `a b c10` + `def` > check.naken("`y` ~ `a b c10` + `def` + s(sqrt(`x 1`))", "`y` ~ `a b c10` + `def` + `x 1`") `y` ~ `a b c10` + `def` + s(sqrt(`x 1`)) `y` ~ `a b c10` + `def` + `x 1` > # without a response > check.naken("x1 + x[,1] + `x3`", "x1 + x[,1] + `x3`") x1 + x[,1] + `x3` x1 + x[,1] + `x3` > check.naken("Salary~Hitters[,c(1,2)]+sqrt(x)", "Salary ~ Hitters[,c(1,2)] + x") Salary~Hitters[,c(1,2)]+sqrt(x) Salary ~ Hitters[,c(1,2)] + x > check.naken("Salary~Hitters[,c(1,2)]+sqrt(x)+x99", "Salary ~ Hitters[,c(1,2)] + x + x99") Salary~Hitters[,c(1,2)]+sqrt(x)+x99 Salary ~ Hitters[,c(1,2)] + x + x99 > check.naken("Salary~x1+x2+`x6`+x3", "Salary ~ x1 + x2 + `x6` + x3") Salary~x1+x2+`x6`+x3 Salary ~ x1 + x2 + `x6` + x3 > check.naken("x[,c(1,2)] + x[,3]", "x[,c(1,2)] + x[,3]") x[,c(1,2)] + x[,3] x[,c(1,2)] + x[,3] > check.naken("x[,1] + x[,2] + x[,3] + x[,29] + x[,-14]", "x[,1] + x[,2] + x[,3] + x[,29] + x[,-14]") x[,1] + x[,2] + x[,3] + x[,29] + x[,-14] x[,1] + x[,2] + x[,3] + x[,29] + x[,-14] > check.naken("x[,c(1,2)] + x[,3] + x[,5:6] + x[,-1]", "x[,c(1,2)] + x[,3] + x[,5:6] + x[,-1]") x[,c(1,2)] + x[,3] + x[,5:6] + x[,-1] x[,c(1,2)] + x[,3] + x[,5:6] + x[,-1] > check.naken("log(y) ~ x9 + ns(x2,4) + s(x3,x4,df=4) + x5:sqrt(x6)", "log(y) ~ x9 + x2 + x3 + x4 + x5 + x6") log(y) ~ x9 + ns(x2,4) + s(x3,x4,df=4) + x5:sqrt(x6) log(y) ~ x9 + x2 + x3 + x4 + x5 + x6 > check.naken("log(y) ~ x9 + sqrt(x6) + ns(x2,4) + s(x3,x4,df=4) + x5", "log(y) ~ x9 + x6 + x2 + x3 + x4 + x5") log(y) ~ x9 + sqrt(x6) + ns(x2,4) + s(x3,x4,df=4) + x5 log(y) ~ x9 + x6 + x2 + x3 + x4 + x5 > check.naken("x[,1] + sqrt(x2) + 2.34e6 + 1", "x[,1] + x2 + 1") x[,1] + sqrt(x2) + 2.34e6 + 1 x[,1] + x2 + 1 > > printf("\n=== test problem in lm() formula with -nonesuch ===\n") === test problem in lm() formula with -nonesuch === > > # Using "-nonesuch" in a "." formula (where nonesuch is a non-existent variable name) > # causes the following error in stats::terms.formula (called via model.frame.default) > # Error in terms.formula(formula, data = data) : (converted from warning) > # 'varlist' has changed (from nvar=3) to new 4 after EncodeVars() -- should no longer happen! > options(warn=2) # treat warnings as errors > expect.err(try(lm(formula = Volume ~ . - nonesuch, data=trees)), + "'varlist' has changed (from nvar=3) to new 4 after EncodeVars() -- should no longer happen!") Error in terms.formula(formula, data = data) : (converted from warning) 'varlist' has changed (from nvar=3) to new 4 after EncodeVars() -- should no longer happen! Got expected error from try(lm(formula = Volume ~ . - nonesuch, data = trees)) > options(warn=1) # print warnings as they occur > > printf("\n=== test variables names with spaces in them ===\n") === test variables names with spaces in them === > spaced.trees <- trees > stopifnot(colnames(spaced.trees) == c("Girth", "Height", "Volume")) # sanity check > colnames(spaced.trees) <- c("Girth extra", "Height 999", "Volume") # put spaces in the names > > lm.spaced.trees <- lm(Volume~., data=spaced.trees) > options(warn=2) > expect.err(try(plotmo(lm.spaced.trees)), + "Cannot determine which variables to plot in degree2 plots") Error : (converted from warning) Cannot determine which variables to plot in degree2 plots (use all2=TRUE?) Confused by variable name "`Girth extra`" Got expected error from try(plotmo(lm.spaced.trees)) > options(warn=1) > plotmo(lm.spaced.trees) # warning, but still plots (no degree2 plots) Warning: Cannot determine which variables to plot in degree2 plots (use all2=TRUE?) Confused by variable name "`Girth extra`" plotmo grid: Girth extra Height 999 12.9 76 > plotmo(lm.spaced.trees, all2=TRUE) # no warning plotmo grid: Girth extra Height 999 12.9 76 > > earth.spaced.trees <- earth(Volume~. , data=spaced.trees, degree=2) > plotmo(earth.spaced.trees) plotmo grid: Girth extra Height 999 12.9 76 > cat("\nevimp(earth.spaced.trees)\n") evimp(earth.spaced.trees) > print(evimp(earth.spaced.trees)) nsubsets gcv rss `Girth extra` 3 100.0 100.0 `Height 999` 1 10.9 11.9 > > printf("\n=== test non standard variable names and use of earth's bx matrix ===\n") === test non standard variable names and use of earth's bx matrix === > emod <- earth(survived~., data=etitanic, degree=2) > plotmo(emod) plotmo grid: pclass sex age sibsp parch 3rd male 28 0 0 > cat("\nevimp(emod)\n") evimp(emod) > print(evimp(emod)) nsubsets gcv rss sexmale 7 100.0 100.0 pclass3rd 6 56.4 58.4 pclass2nd 5 46.3 48.4 age 4 38.0 40.2 sibsp 3 26.6 29.2 > bx <- emod$bx > bx.df <- as.data.frame(bx[,-1]) # -1 to drop intercept > bx.df$survived <- etitanic$survived > # following gsub make it a bit easier to see what's going on > # because the next call to earth also creates hinge functions > # (so we end up with nested hinge functions) > colnames(bx.df) <- gsub("h(", "H(", colnames(bx.df), fixed=TRUE) > lm.bx <- lm(survived ~ ., data=bx.df) > set.seed(2020) > earth.bx <- earth(survived ~ ., data=bx.df, degree=2) > printf("\nsummary(earth.bx):\n") summary(earth.bx): > print(summary(earth.bx)) Call: earth(formula=survived~., data=bx.df, degree=2) coefficients (Intercept) 2.05782826 sexmale -0.60749103 pclass3rd -1.27902837 pclass2nd * sexmale -0.23995151 pclass3rd * sexmale 0.25312923 h(4-sexmale * H(16-age)) -0.20886491 h(2-pclass3rd * H(4-sibsp)) -0.14508261 pclass3rd * h(5-sexmale * H(16-age)) 0.09290713 h(pclass3rd * H(4-sibsp)-2) * h(1-H(age-32)) 0.07452385 Selected 9 of 17 terms, and 7 of 7 predictors Termination condition: Reached nk 21 Importance: sexmale, pclass3rd, `sexmale*H(16-age)`, `pclass2nd*sexmale`, ... Number of terms at each degree of interaction: 1 6 2 GCV 0.1385367 RSS 139.1493 GRSq 0.4276272 RSq 0.4493265 > printf("\nevimp(earth.bx):\n") evimp(earth.bx): > print(evimp(earth.bx)) nsubsets gcv rss sexmale 8 100.0 100.0 pclass3rd 7 57.5 59.7 `sexmale*H(16-age)` 5 39.5 42.0 `pclass2nd*sexmale` 5 39.5 42.0 `pclass3rd*sexmale` 4 35.7 38.0 `pclass3rd*H(4-sibsp)` 4 30.5 33.3 `H(age-32)` 3 24.9 27.6 > plot(earth.bx, info=TRUE) > plotmo(lm.bx) # Warning: Cannot determine which variables to plot in degree2 plots Warning: Cannot determine which variables to plot in degree2 plots (use all2=TRUE?) Confused by variable name "`sexmale*H(16-age)`" plotmo grid: sexmale pclass3rd sexmale*H(16-age) pclass2nd*sexmale 1 0 0 0 pclass3rd*H(4-sibsp) pclass3rd*sexmale H(age-32) 0 0 0 > plotmo(lm.bx, all2=TRUE, SHOWCALL=TRUE) plotmo grid: sexmale pclass3rd sexmale*H(16-age) pclass2nd*sexmale 1 0 0 0 pclass3rd*H(4-sibsp) pclass3rd*sexmale H(age-32) 0 0 0 > plotmo(earth.bx, pmethod="partdep", trace=2) plotmo trace 2: plotmo(object=earth.bx, pmethod="partdep", trace=2) --get.model.env for object with class earth object call is earth(formula=survived~., data=bx.df, degree=2) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.bx' --plotmo_x for earth object get.object.x: object$x is NULL (and it has no colnames) object call is earth(formula=survived~., data=bx.df, degree=2) get.x.from.model.frame: formula(object) is survived ~ sexmale + pclass3rd + `sexmale*H(16-age)` + `p... naked formula is the same formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) object$data is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names sexmale pclass3rd sexmale*H(16-age) pclass2nd*sexmale pclass3rd*H(4-sibsp) pclass3rd*sexmale H(ag... na.action(object) is "na.fail" stats::model.frame(survived ~ sexmale + pclass3rd + `sex..., data=call$data, na.action="na.fail") x=model.frame[,-1] is usable and has column names sexmale pclass3rd sexmale*H(16-age) pclass2nd*sexmale pclass3rd*H(4-sibsp) pclass3rd*sexmale H(ag... setting check.naked=FALSE because backtick in formula plotmo_x returned[1046,7]: sexmale pclass3rd sexmale*H(16-age) pclass2nd*sexmale pclass3rd*H(4-sibsp) 1 0 0 0.0000 0 0 2 1 0 15.0833 0 0 3 0 0 0.0000 0 0 ... 1 0 0.0000 0 0 1046 1 1 0.0000 0 4 pclass3rd*sexmale H(age-32) 1 0 0 2 0 0 3 0 0 ... 0 0 1046 1 0 ----Metadata: plotmo_predict with nresponse=NULL and newdata=NULL calling predict.earth with NULL newdata stats::predict(earth.object, NULL, type="response") predict returned[1046,1]: survived 1 0.9322034 2 1.1601720 3 0.9322034 ... 0.3247124 1046 0.2025618 predict after processing with nresponse=NULL is [1046,1]: survived 1 0.9322034 2 1.1601720 3 0.9322034 ... 0.3247124 1046 0.2025618 ----Metadata: plotmo_fitted with nresponse=NULL stats::fitted(object=earth.object) fitted(object) returned[1046,1]: survived 1 0.9322034 2 1.1601720 3 0.9322034 ... 0.3247124 1046 0.2025618 fitted(object) after processing with nresponse=NULL is [1046,1]: survived 1 0.9322034 2 1.1601720 3 0.9322034 ... 0.3247124 1046 0.2025618 ----Metadata: plotmo_y with nresponse=NULL --plotmo_y with nresponse=NULL for earth object get.object.y: object$y is NULL (and it has no colnames) object call is earth(formula=survived~., data=bx.df, degree=2) get.y.from.model.frame: formula(object) is survived ~ sexmale + pclass3rd + `sexmale*H(16-age)` + `p... formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) object$data is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names sexmale pclass3rd sexmale*H(16-age) pclass2nd*sexmale pclass3rd*H(4-sibsp) pclass3rd*sexmale H(ag... na.action(object) is "na.fail" stats::model.frame(survived ~ sexmale + pclass3rd + `sex..., data=call$data, na.action="na.fail") y=model.frame[,1] is usable and has column name survived plotmo_y returned[1046,1]: survived 1 1 2 1 3 0 ... 0 1046 0 plotmo_y after processing with nresponse=NULL is [1046,1]: survived 1 1 2 1 3 0 ... 0 1046 0 converted nresponse=NA to nresponse=1 nresponse=1 (was NA) ncol(fitted) 1 ncol(predict) 1 ncol(y) 1 ----Metadata: plotmo_y with nresponse=1 --plotmo_y with nresponse=1 for earth object get.object.y: object$y is NULL (and it has no colnames) object call is earth(formula=survived~., data=bx.df, degree=2) get.y.from.model.frame: formula(object) is survived ~ sexmale + pclass3rd + `sexmale*H(16-age)` + `p... formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) object$data is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names sexmale pclass3rd sexmale*H(16-age) pclass2nd*sexmale pclass3rd*H(4-sibsp) pclass3rd*sexmale H(ag... na.action(object) is "na.fail" stats::model.frame(survived ~ sexmale + pclass3rd + `sex..., data=call$data, na.action="na.fail") y=model.frame[,1] is usable and has column name survived got model response from model.frame(survived ~ sexmale + pclass3rd + `sex..., data=call$data, na.action="na.fail") plotmo_y returned[1046,1]: survived 1 1 2 1 3 0 ... 0 1046 0 plotmo_y after processing with nresponse=1 is [1046,1]: survived 1 1 2 1 3 0 ... 0 1046 0 got response name "survived" from yhat got resp.levs from object$levels response levels: 0 1 ----Metadata: done number of x values: sexmale 2 pclass3rd 2 sexmale*H(16-age) 24 pclass2nd*sexm... ----plotmo_singles for earth object singles: 1 sexmale, 2 pclass3rd, 3 sexmale*H(16-age), 4 pclass2nd*sexmale, 5 pclass3rd*H(4-sibsp), 6 pclass3rd*sexmale ----plotmo_pairs for earth object pairs: [,1] [,2] [1,] "2 pclass3rd" "3 sexmale*H(16-age)" [2,] "5 pclass3rd*H(4-sibsp)" "7 H(age-32)" graphics::par(mfrow=c(3,3), mgp=c(1.5,0.4,0), tcl=-0.3, font.main=2, mar=c(3,2,1.2,0.8), oma=c(0,0,3,0), cex.main=1.2, cex.lab=1, cex.axis=1, cex=0.66) ----Figuring out ylim --get.ylim.by.dummy.plots --plot.degree1(draw.plot=FALSE) degree1 plot1 (pmethod "partdep") variable sexmale calculating partdep for sexmale newdata[2092,7]: sexmale pclass3rd sexmale*H(16-age) pclass2nd*sexmale 1 0 0 0.0000 0 2 0 0 15.0833 0 3 0 0 0.0000 0 ... 0 0 0.0000 0 1046.1 1 1 0.0000 0 pclass3rd*H(4-sibsp) pclass3rd*sexmale H(age-32) 1 0 0 0 2 0 0 0 3 0 0 0 ... 0 0 0 1046.1 4 1 0 stats::predict(earth.object, data.frame[2092,7], type="response") predict returned[2092,1]: survived 1 0.9322034 2 1.7676630 3 0.9322034 ... 0.9322034 2092 0.2025618 predict after processing with nresponse=1 is [2092,1]: survived 1 0.9322034 2 1.7676630 3 0.9322034 ... 0.9322034 2092 0.2025618 Reducing trace level for subsequent degree1 plots degree1 plot2 (pmethod "partdep") variable pclass3rd calculating partdep for pclass3rd degree1 plot3 (pmethod "partdep") variable sexmale*H(16-age) calculating partdep for sexmale*H(16-age) degree1 plot4 (pmethod "partdep") variable pclass2nd*sexmale calculating partdep for pclass2nd*sexmale degree1 plot5 (pmethod "partdep") variable pclass3rd*H(4-sibsp) calculating partdep for pclass3rd*H(4-sibsp) degree1 plot6 (pmethod "partdep") variable pclass3rd*sexmale calculating partdep for pclass3rd*sexmale --plot.degree2(draw.plot=FALSE) degree2 plot1 (pmethod "partdep") variables pclass3rd:sexmale*H(16-age) calculating partdep for pclass3rd:sexmale*H(16-age) 1234newdata[20920,7]: sexmale pclass3rd sexmale*H(16-age) pclass2nd*sexmale 1 0 0 0.0000 0 2 1 0 0.0000 0 3 0 0 0.0000 0 ... 1 0 0.0000 0 1046.19 1 0 15.6667 0 pclass3rd*H(4-sibsp) pclass3rd*sexmale H(age-32) 1 0 0 0 2 0 0 0 3 0 0 0 ... 0 0 0 1046.19 4 1 0 stats::predict(earth.object, data.frame[20920,7], type="response") predict returned[20920,1]: survived 1 0.9322034 2 0.3247124 3 0.9322034 ... 0.3247124 20920 1.8525142 predict after processing with nresponse=1 is [20920,1]: survived 1 0.9322034 2 0.3247124 3 0.9322034 ... 0.3247124 20920 1.8525142 56790 Reducing trace level for subsequent degree2 plots degree2 plot2 (pmethod "partdep") variables pclass3rd*H(4-sibsp):H(age-32) calculating partdep for pclass3rd*H(4-sibsp):H(age-32) 1newdata[20920,7]: sexmale pclass3rd sexmale*H(16-age) pclass2nd*sexmale 1 0 0 0.0000 0 2 1 0 15.0833 0 3 0 0 0.0000 0 ... 1 0 0.0000 0 1046.19 1 1 0.0000 0 pclass3rd*H(4-sibsp) pclass3rd*sexmale H(age-32) 1 0 0 0 2 0 0 0 3 0 0 0 ... 0 0 0 1046.19 0 1 48 stats::predict(earth.object, data.frame[20920,7], type="response") predict returned[20920,1]: survived 1 0.9322034 2 1.1601720 3 0.9322034 ... 0.3247124 20920 -0.2366511 predict after processing with nresponse=1 is [20920,1]: survived 1 0.9322034 2 1.1601720 3 0.9322034 ... 0.3247124 20920 -0.2366511 234567890 --done get.ylim.by.dummy.plots ylim c(-0.04329, 1.607) clip TRUE --plot.degree1(draw.plot=TRUE) graphics::plot.default(x=c(0,0.5,0.5,1), y=c(0.7904,0.7904...), type="n", main="1 sexmale", xlab="", ylab="", xaxt="s", yaxt="s", xlim=c(-0.1,1.1), ylim=c(-0.0433,1.607)) --plot.degree2(draw.plot=TRUE) persp(pclass3rd:sexmale*H(16-age)) theta 55 persp(pclass3rd*H(4-sibsp):H(age-32)) theta 235 > > printf("\n=== put spaces into the column names of bx (for both response and predictors) ===\n") === put spaces into the column names of bx (for both response and predictors) === > spaced.bx <- bx.df > colnames(spaced.bx) <- gsub("-", " - ", colnames(spaced.bx), fixed=TRUE) > colnames(spaced.bx)[colnames(spaced.bx) == "survived"] <- "Survived = YES" > printf("\nhead(spaced.bx):\n") head(spaced.bx): > print(head(spaced.bx)) sexmale pclass3rd sexmale*H(16 - age) pclass2nd*sexmale 1 0 0 0.0000 0 2 1 0 15.0833 0 3 0 0 0.0000 0 4 1 0 0.0000 0 5 0 0 0.0000 0 6 1 0 0.0000 0 pclass3rd*H(4 - sibsp) pclass3rd*sexmale H(age - 32) Survived = YES 1 0 0 0 1 2 0 0 0 1 3 0 0 0 0 4 0 0 0 0 5 0 0 0 0 6 0 0 16 1 > > lm.spaced.bx <- lm(`Survived = YES` ~ ., data=spaced.bx) > > set.seed(2020) > earth.spaced.bx <- earth(`Survived = YES` ~ ., data=spaced.bx, degree=2, trace=.5, + nfold=4, ncross=3, varmod.method="lm", pmethod="cv") Preliminary model with pmethod="backward": GRSq 0.428 RSq 0.449 nterms 9 CV fold 1.1 CVRSq 0.402 n.oof 779 26% n.infold.nz 320 41% n.oof.nz 107 40% CV fold 1.2 CVRSq 0.424 n.oof 785 25% n.infold.nz 320 41% n.oof.nz 107 41% CV fold 1.3 CVRSq 0.418 n.oof 786 25% n.infold.nz 320 41% n.oof.nz 107 41% CV fold 1.4 CVRSq 0.433 n.oof 788 25% n.infold.nz 321 41% n.oof.nz 106 41% CV fold 2.1 CVRSq 0.470 n.oof 784 25% n.infold.nz 320 41% n.oof.nz 107 41% CV fold 2.2 CVRSq 0.417 n.oof 775 26% n.infold.nz 320 41% n.oof.nz 107 39% CV fold 2.3 CVRSq 0.412 n.oof 787 25% n.infold.nz 320 41% n.oof.nz 107 41% CV fold 2.4 CVRSq 0.421 n.oof 792 24% n.infold.nz 321 41% n.oof.nz 106 42% CV fold 3.1 CVRSq 0.385 n.oof 777 26% n.infold.nz 320 41% n.oof.nz 107 40% CV fold 3.2 CVRSq 0.429 n.oof 792 24% n.infold.nz 320 40% n.oof.nz 107 42% CV fold 3.3 CVRSq 0.461 n.oof 780 25% n.infold.nz 320 41% n.oof.nz 107 40% CV fold 3.4 CVRSq 0.377 n.oof 789 25% n.infold.nz 321 41% n.oof.nz 106 41% CV all CVRSq 0.421 n.infold.nz 427 41% Final model with pmethod="cv": GRSq 0.425 RSq 0.452 nterms selected by cv 11 varmod method="lm" rmethod="hc12" lambda=1 exponent=1 conv=1 clamp=0.1 minspan=-3: iter weight.ratio coefchange% (Intercept) `Survived = YES` 1 2.2 0.00 0.31 -0.074 2 3.7 36.00 0.33 -0.122 3 5.3 14.02 0.34 -0.151 4 6.5 6.60 0.35 -0.168 5 7.3 3.21 0.35 -0.176 6 7.8 1.57 0.36 -0.181 7 8.0 0.76 0.36 -0.183 > printf("\nsummary(earth.spaced.bx):\n") summary(earth.spaced.bx): > print(summary(earth.spaced.bx)) Call: earth(formula=`Survived=YES`~., data=spaced.bx, pmethod="cv", trace=0.5, degree=2, nfold=4, ncross=3, varmod.method="lm") coefficients (Intercept) 2.01771627 sexmale -0.56066394 pclass3rd -1.25089642 pclass2nd * sexmale -0.26729133 pclass3rd * sexmale 0.20879448 h(4-sexmale * H(16 - age)) -0.20186359 h(2-pclass3rd * H(4 - sibsp)) -0.13902926 sexmale * h(H(age - 32)-6) -0.00607253 pclass3rd * h(5-sexmale * H(16 - age)) 0.08709723 h(pclass3rd * H(4 - sibsp)-2) * h(H(age - 32)-1) 0.00242931 h(pclass3rd * H(4 - sibsp)-2) * h(1-H(age - 32)) 0.08048994 Selected 11 of 17 terms, and 7 of 7 predictors (pmethod="cv") Termination condition: Reached nk 21 Importance: sexmale, pclass3rd, `sexmale*H(16 - age)`, `pclass2nd*sexmale`, ... Number of terms at each degree of interaction: 1 6 4 GRSq 0.4251614 RSq 0.4523366 mean.oof.RSq 0.4245627 (sd 0.0258) pmethod="backward" would have selected: 9 terms 7 preds, GRSq 0.4276272 RSq 0.4493265 mean.oof.RSq 0.4224044 varmod: method "lm" min.sd 0.0354 iter.rsq 0.070 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) 0.4476988 0.0176523 4 Survived = YES -0.2293581 0.0258681 11 mean smallest largest ratio 95% prediction interval 1.387928 0.6949522 1.966296 2.829398 68% 80% 90% 95% response values in prediction interval 69 75< 84< 93< > printf("\nevimp(earth.spaced.bx):\n") evimp(earth.spaced.bx): > print(evimp(earth.spaced.bx)) nsubsets gcv rss sexmale 10 100.0 100.0 pclass3rd 9 57.2 60.0 `sexmale*H(16 - age)` 7 38.8 42.6 `pclass2nd*sexmale` 7 38.8 42.6 `pclass3rd*sexmale` 6 35.0 38.7 `pclass3rd*H(4 - sibsp)` 6 29.7 34.2 `H(age - 32)` 5 23.8 28.7 > > set.seed(2020) > earth.glm.spaced.bx <- earth(`Survived = YES` ~ ., data=spaced.bx, degree=2, trace=.5, + glm=list(family="binomial"), + nfold=4, ncross=3, varmod.method="lm", pmethod="cv") Preliminary model with pmethod="backward": GRSq 0.428 RSq 0.449 nterms 9 CV fold 1.1 CVRSq 0.402 n.oof 779 26% n.infold.nz 320 41% n.oof.nz 107 40% CV fold 1.2 CVRSq 0.424 n.oof 785 25% n.infold.nz 320 41% n.oof.nz 107 41% CV fold 1.3 CVRSq 0.418 n.oof 786 25% n.infold.nz 320 41% n.oof.nz 107 41% CV fold 1.4 CVRSq 0.433 n.oof 788 25% n.infold.nz 321 41% n.oof.nz 106 41% CV fold 2.1 CVRSq 0.470 n.oof 784 25% n.infold.nz 320 41% n.oof.nz 107 41% CV fold 2.2 CVRSq 0.417 n.oof 775 26% n.infold.nz 320 41% n.oof.nz 107 39% CV fold 2.3 CVRSq 0.412 n.oof 787 25% n.infold.nz 320 41% n.oof.nz 107 41% CV fold 2.4 CVRSq 0.421 n.oof 792 24% n.infold.nz 321 41% n.oof.nz 106 42% CV fold 3.1 CVRSq 0.385 n.oof 777 26% n.infold.nz 320 41% n.oof.nz 107 40% CV fold 3.2 CVRSq 0.429 n.oof 792 24% n.infold.nz 320 40% n.oof.nz 107 42% CV fold 3.3 CVRSq 0.461 n.oof 780 25% n.infold.nz 320 41% n.oof.nz 107 40% CV fold 3.4 CVRSq 0.377 n.oof 789 25% n.infold.nz 321 41% n.oof.nz 106 41% CV all CVRSq 0.421 n.infold.nz 427 41% Final model with pmethod="cv": GRSq 0.425 RSq 0.452 nterms selected by cv 11 varmod method="lm" rmethod="hc12" lambda=1 exponent=1 conv=1 clamp=0.1 minspan=-3: iter weight.ratio coefchange% (Intercept) `Survived = YES` 1 2.2 0.00 0.31 -0.074 2 3.7 36.00 0.33 -0.122 3 5.3 14.02 0.34 -0.151 4 6.5 6.60 0.35 -0.168 5 7.3 3.21 0.35 -0.176 6 7.8 1.57 0.36 -0.181 7 8.0 0.76 0.36 -0.183 > printf("\nsummary(earth.glm.spaced.bx):\n") summary(earth.glm.spaced.bx): > print(summary(earth.glm.spaced.bx)) Call: earth(formula=`Survived=YES`~., data=spaced.bx, pmethod="cv", trace=0.5, glm=list(family="binomial"), degree=2, nfold=4, ncross=3, varmod.method="lm") GLM coefficients `Survived = YES` (Intercept) 9.8189944 sexmale -3.0197582 pclass3rd -8.5391964 pclass2nd * sexmale -1.9328478 pclass3rd * sexmale 1.2008915 h(4-sexmale * H(16 - age)) -1.4278190 h(2-pclass3rd * H(4 - sibsp)) -0.7433398 sexmale * h(H(age - 32)-6) -0.0441700 pclass3rd * h(5-sexmale * H(16 - age)) 0.7564144 h(pclass3rd * H(4 - sibsp)-2) * h(H(age - 32)-1) 0.0091406 h(pclass3rd * H(4 - sibsp)-2) * h(1-H(age - 32)) 0.5068265 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 1414.62 1045 873.999 1035 0.382 896 6 1 Earth selected 11 of 17 terms, and 7 of 7 predictors (pmethod="cv") Termination condition: Reached nk 21 Importance: sexmale, pclass3rd, `sexmale*H(16 - age)`, `pclass2nd*sexmale`, ... Number of terms at each degree of interaction: 1 6 4 Earth GRSq 0.4251614 RSq 0.4523366 mean.oof.RSq 0.4245627 (sd 0.0258) pmethod="backward" would have selected: 9 terms 7 preds, GRSq 0.4276272 RSq 0.4493265 mean.oof.RSq 0.4224044 varmod: method "lm" min.sd 0.0354 iter.rsq 0.070 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) 0.4476988 0.0176523 4 Survived = YES -0.2293581 0.0258681 11 mean smallest largest ratio 95% prediction interval 1.387928 0.6949522 1.966296 2.829398 68% 80% 90% 95% response values in prediction interval 69 75< 84< 93< > printf("\nevimp(earth.glm.spaced.bx):\n") evimp(earth.glm.spaced.bx): > print(evimp(earth.glm.spaced.bx)) nsubsets gcv rss sexmale 10 100.0 100.0 pclass3rd 9 57.2 60.0 `sexmale*H(16 - age)` 7 38.8 42.6 `pclass2nd*sexmale` 7 38.8 42.6 `pclass3rd*sexmale` 6 35.0 38.7 `pclass3rd*H(4 - sibsp)` 6 29.7 34.2 `H(age - 32)` 5 23.8 28.7 > > options(warn=2) > expect.err(try(plotmo(lm.spaced.bx)), + "Cannot determine which variables to plot in degree2 plots") Error : (converted from warning) Cannot determine which variables to plot in degree2 plots (use all2=TRUE?) Confused by variable name "`sexmale*H(16 - age)`" Got expected error from try(plotmo(lm.spaced.bx)) > options(warn=1) > > plotmo(lm.spaced.bx, do.par=2, SHOWCALL=TRUE) Warning: Cannot determine which variables to plot in degree2 plots (use all2=TRUE?) Confused by variable name "`sexmale*H(16 - age)`" plotmo grid: sexmale pclass3rd sexmale*H(16 - age) pclass2nd*sexmale 1 0 0 0 pclass3rd*H(4 - sibsp) pclass3rd*sexmale H(age - 32) 0 0 0 > plotres(lm.spaced.bx, do.par=0, which=c(1, 3)) > par(org.par) > > plotmo(earth.spaced.bx, degree1="sexmale", do.par=2, level=.8, SHOWCALL=TRUE) plotmo grid: sexmale pclass3rd sexmale*H(16 - age) pclass2nd*sexmale 1 0 0 0 pclass3rd*H(4 - sibsp) pclass3rd*sexmale H(age - 32) 0 0 0 > plot(earth.spaced.bx, do.par=0, which=c(1, 3), info=TRUE, level=.8, type="earth") > par(org.par) > > plot(earth.spaced.bx, versus="b:", info=TRUE, level=.8, type="earth", SHOWCALL=TRUE) > > # following should be the same as previous page (since type="earth") > plotmo(earth.glm.spaced.bx, degree1="sexmale", do.par=2, level=.8, type="earth", SHOWCALL=TRUE) plotmo grid: sexmale pclass3rd sexmale*H(16 - age) pclass2nd*sexmale 1 0 0 0 pclass3rd*H(4 - sibsp) pclass3rd*sexmale H(age - 32) 0 0 0 > plot(earth.glm.spaced.bx, do.par=0, which=1, info=TRUE, level=.8, type="earth") > # $$ TODO Following shouldn't cause Warning: Internal inconsistency: p$fit - fitted != 0 > # No warning if don't use glm=list(family="binomial") in call to earth > options(warn=2) > expect.err(try(plot(earth.glm.spaced.bx, do.par=0, which=3, info=TRUE, level=.8, type="earth")), + "Internal inconsistency: p$fit != fitted") Error : (converted from warning) Internal inconsistency: p$fit != fitted Workaround: no 'glm' arg in call to earth, or no 'level' arg n call to plotres Got expected error from try(plot(earth.glm.spaced.bx, do.par = 0, which = 3, info = TRUE, level = 0.8, type = "earth")) > options(warn=1) > plot(earth.glm.spaced.bx, do.par=0, which=3, info=TRUE, level=.8, type="earth") Warning: Internal inconsistency: p$fit != fitted Workaround: no 'glm' arg in call to earth, or no 'level' arg n call to plotres > par(org.par) > > expect.err(try(plotmo(earth.glm.spaced.bx, level=.8)), + "predict.earth: with earth-glm models, use type=\"earth\" when using the interval argument") plotmo grid: sexmale pclass3rd sexmale*H(16 - age) pclass2nd*sexmale 1 0 0 0 pclass3rd*H(4 - sibsp) pclass3rd*sexmale H(age - 32) 0 0 0 Error : predict.earth: with earth-glm models, use type="earth" when using the interval argument Got expected error from try(plotmo(earth.glm.spaced.bx, level = 0.8)) > > plotmo(earth.glm.spaced.bx, degree1="sexmale", do.par=2, SHOWCALL=TRUE) plotmo grid: sexmale pclass3rd sexmale*H(16 - age) pclass2nd*sexmale 1 0 0 0 pclass3rd*H(4 - sibsp) pclass3rd*sexmale H(age - 32) 0 0 0 > plot(earth.glm.spaced.bx, do.par=0, which=c(1, 3), info=TRUE) > par(org.par) > > printf("\n=== test combinations of variables in formula ===\n") === test combinations of variables in formula === > > vdata <- data.frame( + resp = 1:13, + bool = c(F, F, F, F, F, T, T, T, T, T, T, T, T), + ord = ordered(c("ORD1", "ORD1", "ORD1", + "ORD1", "ORD1", "ORD1", + "ORD3", "ORD3", "ORD3", + "ORD2", "ORD2", "ORD2", "ORD2"), + levels=c("ORD1", "ORD3", "ORD2")), + fac = as.factor(c("FAC1", "FAC1", "FAC1", + "FAC2", "FAC2", "FAC2", + "FAC3", "FAC3", "FAC3", + "FAC1", "FAC2", "FAC3", "FAC3")), + str = c("STR1", "STR1", "STR1", # WILL BE TREATED LIKE A FACTOR + "STR2", "STR2", "STR2", + "STR3", "STR3", "STR3", + "STR3", "STR3", "STR3", "STR3"), + num = c(1, 3, 2, 3, 4, 5, 6, 4, 5, 6.5, 3, 6, 5), # 7 unique values (but one is non integral) + sqrt_num = sqrt(c(1, 3, 2, 3, 4, 5, 6, 4, 5, 6.5, 3, 6, 5)), + int = c(1L, 1L, 3L, 3L, 4L, 4L, 3L, 5L, 3L, 6L, 7L, 8L, 10L), # 8 unique values + date = as.Date( + c("2018-08-01", "2018-08-02", "2018-08-03", + "2018-08-04", "2018-08-05", "2018-08-06", + "2018-08-07", "2018-08-08", "2018-08-08", + "2018-08-08", "2018-08-10", "2018-08-11", "2018-08-11")), + date_num = as.numeric(as.Date( + c("2018-08-01", "2018-08-02", "2018-08-03", + "2018-08-04", "2018-08-05", "2018-08-06", + "2018-08-07", "2018-08-08", "2018-08-08", + "2018-08-08", "2018-08-10", "2018-08-11", "2018-08-11")))) > > vdata$off <- (1:nrow(vdata)) / nrow(vdata) > > resp2 <- 13:1 > > vweights <- rep(1, length.out=nrow(vdata)) > vweights[1] <- 2 > > set.seed(2020) > lognum.bool.ord.off <- earth(resp ~ log(num) + bool + ord + offset(off), degree=2, weights=vweights, + data=vdata, pmethod="none", varmod.method="lm", + nfold=2, ncross=3, + trace=1) x[13,4] with colnames log(num) boolTRUE ord.L ord.Q y[13,1] with colname resp, and values 0.9231, 1.846, 2.769, 3.692, ... weights[13]: 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 Forward pass term 1, 2, 4, 6, 8 GRSq -Inf at 7 terms, 5 terms used After forward pass GRSq -in RSq 0.966 Prune none penalty 3 nprune null: selected 5 of 5 terms, and 3 of 4 preds After pruning pass GRSq -0.732 RSq 0.952 CV fold 1.1 CVRSq -0.476 n.oof 6 54% n.infold.nz 6 100% n.oof.nz 7 100% CV fold 1.2 CVRSq 0.823 n.oof 7 46% n.infold.nz 7 100% n.oof.nz 6 100% CV fold 2.1 CVRSq -0.622 n.oof 6 54% n.infold.nz 6 100% n.oof.nz 7 100% CV fold 2.2 CVRSq 0.816 n.oof 7 46% n.infold.nz 7 100% n.oof.nz 6 100% CV fold 3.1 CVRSq 0.559 n.oof 6 54% n.infold.nz 6 100% n.oof.nz 7 100% CV fold 3.2 CVRSq 0.698 n.oof 7 46% n.infold.nz 7 100% n.oof.nz 6 100% CV all CVRSq 0.300 n.infold.nz 13 100% varmod method="lm" rmethod="hc12" lambda=1 exponent=1 conv=1 clamp=0.1 minspan=-3: iter weight.ratio coefchange% (Intercept) resp 1 1.6 0.00 1.76 0.045 2 2.2 39.64 1.55 0.076 3 2.9 19.19 1.40 0.098 4 3.5 12.21 1.29 0.115 5 4.1 8.66 1.21 0.127 6 4.6 6.50 1.15 0.137 7 5.0 5.05 1.10 0.145 8 5.5 4.02 1.06 0.152 9 5.8 3.25 1.03 0.157 10 6.1 2.66 1.00 0.162 11 6.4 2.19 0.98 0.165 12 6.7 1.82 0.97 0.168 13 6.9 1.52 0.95 0.171 14 7.1 1.28 0.94 0.173 15 7.3 1.08 0.93 0.175 16 7.4 0.91 0.92 0.176 > > printf("summary(lognum.bool.ord.off)\n") summary(lognum.bool.ord.off) > print(summary(lognum.bool.ord.off)) Call: earth(formula=resp~log(num)+bool+ord+offset(off), data=vdata, weights=vweights, pmethod="none", trace=1, degree=2, nfold=2, ncross=3, varmod.method="lm") coefficients (Intercept) 6.273213 boolTRUE 1.111403 h(-7.85046e-17-ord.L) -7.600147 h(ord.L- -7.85046e-17) 4.568998 log(num) * h(-7.85046e-17-ord.L) 3.100021 Selected 5 of 5 terms, and 3 of 4 predictors (pmethod="none") Termination condition: GRSq -Inf at 5 terms Importance: ord.L, log(num), boolTRUE, ord.Q-unused Offset: off with values 0.07692308, 0.1538462, 0.2307692, 0.3076923, 0.3... Weights: 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 Number of terms at each degree of interaction: 1 3 1 GCV 28.70012 RSS 8.830806 GRSq -0.7319038 RSq 0.9518916 CVRSq 0.2995745 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 2.33 sd 0.52 nvars 1.00 sd 0.00 CVRSq sd MaxErr sd 0.3 0.666 -6 3.53 varmod: method "lm" min.sd 0.27 iter.rsq 0.204 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) 1.151190 0.759983 66 resp 0.220811 0.131375 59 mean smallest largest ratio 95% prediction interval 10.57312 5.357389 14.56643 2.718942 68% 80% 90% 95% response values in prediction interval 100 100 100 100 > cat("\nevimp(lognum.bool.ord.off)\n") evimp(lognum.bool.ord.off) > print(evimp(lognum.bool.ord.off)) nsubsets gcv rss ord.L 4 -73.4 100.0 log(num) 2 -98.7 30.8 boolTRUE 1 -100.0 6.6 > > plotmo(lognum.bool.ord.off, do.par=2, level=.8, SHOWCALL=TRUE) Note: the offset in the formula is not plotted (use all1=TRUE to plot the offset, or use trace=-1 to silence this message) plotmo grid: num bool ord off 4 TRUE ORD1 0.5384615 > plot(lognum.bool.ord.off, which=1, do.par=0) > par(org.par) > > num.fac.sqrt.num.ord.bool <- earth(resp ~ num + int + fac + offset(off) + sqrt(num) + ord:bool - int, + data=vdata, pmethod="none", trace=1) x[13,10] with colnames num facFAC2 facFAC3 sqrt(num) ordORD1:boolFALSE ordORD3:b... y[13,1] with colname resp, and values 0.9231, 1.846, 2.769, 3.692, ... Forward pass term 1, 2, 4, 6, 8, 10 GRSq -Inf at 9 terms, 6 terms used After forward pass GRSq -in RSq 0.979 Prune none penalty 2 nprune null: selected 6 of 6 terms, and 4 of 10 preds After pruning pass GRSq 0.045 RSq 0.973 > plotmo(num.fac.sqrt.num.ord.bool, SHOWCALL=TRUE) Note: the offset in the formula is not plotted (use all1=TRUE to plot the offset, or use trace=-1 to silence this message) plotmo grid: num int fac off ord bool 4 4 FAC3 0.5384615 ORD1 TRUE > cat("\nevimp(num.fac.sqrt.num.ord.bool)\n") evimp(num.fac.sqrt.num.ord.bool) > print(evimp(num.fac.sqrt.num.ord.bool)) nsubsets gcv rss ordORD1:boolFALSE 4 25.3 100.0 ordORD2:boolTRUE 4 -87.6 52.9 num 3 -100.0 30.0 facFAC3 3 -100.0 30.0 > > printf("\n=== unusual formulas, compare to lm ===\n") === unusual formulas, compare to lm === > > lm1 <- lm(resp~ord+sqrt(as.numeric(fac)) + num+sqrt(num / 2)+I(2 * int)+date, data = vdata) > > # same formula terms as lm1 but in different order > earth1 <- earth(resp~sqrt(as.numeric(fac)) + ord + date + num + sqrt(.5 * num)+I(int / .5), + data = vdata, linpreds=TRUE, thresh=0, penalty=-1) > cat("\nevimp(earth1)\n") evimp(earth1) > print(evimp(earth1)) nsubsets gcv rss date 7 100.0 100.0 sqrt(as.numeric(fac)) 5 10.8 10.8 ord.L 5 5.3 5.3 num 4 3.6 3.6 I(int/0.5) 4 3.6 3.6 ord.Q 2 0.0 0.0 sqrt(0.5 * num) 1 0.0 0.0 > plotmo(lm1, SHOWCALL=TRUE) plotmo grid: ord fac num int date ORD1 FAC3 4 4 2018-08-07 > plotmo(earth1, SHOWCALL=TRUE) plotmo grid: fac ord date num int FAC3 ORD1 2018-08-07 4 4 > stopifnot(max(abs(sort(lm1$coef) - sort(earth1$coef))) < 1e-10) > stopifnot((summary(lm1)$r.squared - earth1$rsq) < 1e-10) > stopifnot(max(abs(predict(lm1, newdata=vdata[5,,drop=FALSE]) - predict(earth1, newdata=vdata[5,,drop=FALSE]))) < 1e-10) > > fac.sqrt <- earth(resp~sqrt(num)+fac, data = vdata, linpreds=TRUE, thresh=0, penalty=-1) > fac.sqrt_ <- earth(resp~sqrt_num+fac, data = vdata, linpreds=TRUE, thresh=0, penalty=-1) > cat("\nevimp(fac.sqrt)\n") evimp(fac.sqrt) > print(evimp(fac.sqrt)) nsubsets gcv rss sqrt(num) 3 100.0 100.0 facFAC3 2 37.4 37.4 facFAC2 1 18.4 18.4 > cat("\nevimp(fac.sqrt_)\n") evimp(fac.sqrt_) > print(evimp(fac.sqrt_)) nsubsets gcv rss sqrt_num 3 100.0 100.0 facFAC3 2 37.4 37.4 facFAC2 1 18.4 18.4 > # as.vector to remove names (which are slightly different: sqrt(num) vs sqrt_num > stopifnot(identical(as.vector(fac.sqrt$coef), as.vector(fac.sqrt_$coef))) > > newdata.extra <- vdata[3:5,] # extra variables unused in the model > newdata.extra$extra <- sqrt(newdata.extra[,1]) > cat("\ncolnames(newdata.extra):", paste(colnames(newdata.extra)), "\n") colnames(newdata.extra): resp bool ord fac str num sqrt_num int date date_num off extra > > newd <- vdata[3:5,c("num", "fac")] # only variables used in the formula model > newd_ <- vdata[3:5,c("num", "sqrt_num", "fac")] # only variables used in the xy model > > stopifnot(identical(predict(fac.sqrt, newdata=newdata.extra), predict(fac.sqrt_, newdata=newd_))) > stopifnot(identical(predict(fac.sqrt, newdata=newd), predict(fac.sqrt_, newdata=newd_))) > stopifnot(identical(predict(fac.sqrt, newdata=newd), predict(fac.sqrt_, newdata=newd_))) > stopifnot(identical(predict(fac.sqrt, newdata=newd), predict(fac.sqrt_, newdata=newd_))) > > stopifnot(max(abs(predict(fac.sqrt, newdata=newdata.extra) - predict(fac.sqrt_, newdata=newdata.extra))) < 1e-10) > stopifnot(max(abs(predict(fac.sqrt, newdata=newdata.extra) - predict(fac.sqrt_, newdata=newdata.extra))) < 1e-10) > > printf("\n=== two response model ===\n") === two response model === > > vdata.2resp <- vdata > resp2 <- 13:1 > vdata.2resp$resp2 <- resp2 > > earth.2resp <- earth(resp+resp2~num+sqrt(num), data=vdata.2resp, weights=vweights, trace=1, + linpreds=TRUE, thresh=0, penalty=-1) Using class "Formula" because lhs of formula has terms separated by "+" x[13,2] with colnames num sqrt(num) y[13,2] with colnames resp resp2 weights[13]: 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 Forward pass term 1, 2, 4, 6 No new term increases RSq (perhaps reached numerical limits) at 5 terms, 3 terms used After forward pass GRSq 0.584 RSq 0.584 Prune backward penalty -1 nprune null: selected 3 of 3 terms, and 2 of 2 preds After pruning pass GRSq 0.584 RSq 0.584 > printf("\nsummary(earth.2resp)\n") summary(earth.2resp) > print(summary(earth.2resp)) Call: earth(formula=resp+resp2~num+sqrt(num), data=vdata.2resp, weights=vweights, trace=1, linpreds=TRUE, thresh=0, penalty=-1) resp resp2 (Intercept) -6.0874826 20.0874826 num -0.3162815 0.3162815 sqrt(num) 7.2649780 -7.2649780 Selected 3 of 3 terms, and 2 of 2 predictors Termination condition: No new term increases RSq at 3 terms Importance: sqrt(num), num Weights: 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 Number of terms at each degree of interaction: 1 2 (additive model) GCV RSS GRSq RSq resp 6.899683 89.69588 0.5836398 0.5836398 resp2 6.899683 89.69588 0.5836398 0.5836398 All 13.799366 179.39176 0.5836398 0.5836398 > cat("\nevimp(earth.2resp)\n") evimp(earth.2resp) > print(evimp(earth.2resp)) nsubsets gcv rss sqrt(num) 2 100.0 100.0 num 1 2.4 2.4 > par(mfrow = c(2, 2), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0), oma=c(0,0,4,0)) > # for formula models, plotmo plots a sinle plot for the effect of num > plotmo(earth.2resp, nresp=1, do.par=0, main="earth.2resp nresp1") > title <- paste( + "two-response model: resp+resp2~num+sqrt(num)\n", + "the top row is for earth.formula models: the combined effect of num and sqrt(num) is plotted together\n", + "the bottom row is for an earth.default model: num and sqrt(num) are plotted separately") > title(title, outer=TRUE, cex=.6) > plotmo(earth.2resp, nresp=2, do.par=0, main="earth.2resp nresp2") > > # put two response data mats into matrix form for earth.default and for lm > xmat <- vdata[,c("num", "sqrt_num"), drop=FALSE] > colnames(xmat) <- c("num", "sqrt(num)") > xmat <- as.matrix(xmat) > ymat <- vdata[, "resp", drop=FALSE] > ymat$resp2 <- resp2 > ymat <- as.matrix(ymat) > earthxy.2resp <- earth(xmat, ymat, weights=vweights, trace=1, + linpreds=TRUE, thresh=0, penalty=-1) x[13,2] with colnames num sqrt(num) y[13,2] with colnames resp resp2 weights[13]: 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 Forward pass term 1, 2, 4, 6 No new term increases RSq (perhaps reached numerical limits) at 5 terms, 3 terms used After forward pass GRSq 0.584 RSq 0.584 Prune backward penalty -1 nprune null: selected 3 of 3 terms, and 2 of 2 preds After pruning pass GRSq 0.584 RSq 0.584 > printf("\nsummary(earthxy.2resp)\n") summary(earthxy.2resp) > print(summary(earthxy.2resp)) Call: earth(x=xmat, y=ymat, weights=vweights, trace=1, linpreds=TRUE, thresh=0, penalty=-1) resp resp2 (Intercept) -6.0874826 20.0874826 num -0.3162815 0.3162815 sqrt(num) 7.2649780 -7.2649780 Selected 3 of 3 terms, and 2 of 2 predictors Termination condition: No new term increases RSq at 3 terms Importance: sqrt(num), num Weights: 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 Number of terms at each degree of interaction: 1 2 (additive model) GCV RSS GRSq RSq resp 6.899683 89.69588 0.5836398 0.5836398 resp2 6.899683 89.69588 0.5836398 0.5836398 All 13.799366 179.39176 0.5836398 0.5836398 > cat("\nevimp(earthxy.2resp)\n") evimp(earthxy.2resp) > print(evimp(earthxy.2resp)) nsubsets gcv rss sqrt(num) 2 100.0 100.0 num 1 2.4 2.4 > # for xy models, plotmo plots a separate plots for the effect of num and sqrt(num) > plotmo(earthxy.2resp, nresp=1, do.par=0) plotmo grid: num sqrt(num) 4 2 > # plotmo(earthxy.2resp, nresp=2, do.par=0) > stopifnot(identical(earth.2resp$coeff, earthxy.2resp$coeff)) > > lm.2resp <- lm(ymat~xmat, weights=vweights) > printf("\nsummary(lm.2resp)\n") summary(lm.2resp) > print(summary(lm.2resp)) Response resp : Call: lm(formula = resp ~ xmat, weights = vweights) Weighted Residuals: Min 1Q Median 3Q Max -3.5470 -2.1773 -0.3788 0.8227 5.4530 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) -6.0875 10.4903 -0.580 0.575 xmatnum -0.3163 3.4983 -0.090 0.930 xmatsqrt(num) 7.2650 12.4500 0.584 0.572 Residual standard error: 2.995 on 10 degrees of freedom Multiple R-squared: 0.5836, Adjusted R-squared: 0.5004 F-statistic: 7.009 on 2 and 10 DF, p-value: 0.01251 Response resp2 : Call: lm(formula = resp2 ~ xmat, weights = vweights) Weighted Residuals: Min 1Q Median 3Q Max -5.4530 -0.8227 0.3788 2.1773 3.5470 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 20.0875 10.4903 1.915 0.0845 . xmatnum 0.3163 3.4983 0.090 0.9297 xmatsqrt(num) -7.2650 12.4500 -0.584 0.5725 --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 2.995 on 10 degrees of freedom Multiple R-squared: 0.5836, Adjusted R-squared: 0.5004 F-statistic: 7.009 on 2 and 10 DF, p-value: 0.01251 > options(warn=2) # treat warnings as errors > expect.err(try(plotmo(lm.2resp, nresp=1)), + "the variable on the right side of the formula is a matrix or data.frame") Error : (converted from warning) the variable on the right side of the formula is a matrix or data.frame plotmo often cannot process such variables Got expected error from try(plotmo(lm.2resp, nresp = 1)) > options(warn=1) # print warnings as they occur > > # check that lm and earth coeffs are the same > # need order() below because coeffs appear in different row order in the coeff mat > earth.2resp.order <- order(earth.2resp$coeff[,1]) > lm.order <- order(lm.2resp$coeff[,1]) > stopifnot(max(abs(earth.2resp$coeff[earth.2resp.order] - lm.2resp$coeff[lm.order])) < 1e-10) > > printf("\n=== test glm() with spaced.bx ===\n") === test glm() with spaced.bx === > > # glm requires response to be a factor (or two columns) > spaced.bx.fac <- spaced.bx > spaced.bx.fac$`surv fac` <- factor(ifelse(spaced.bx$`Survived = YES`, "yes", "no"), levels = c("yes", "no")) > spaced.bx.fac$`Survived = YES` <- NULL > glm.spaced.bx <- glm(`surv fac` ~ ., data=spaced.bx.fac, family="binomial") > printf("summary(glm.spaced.bx):\n") summary(glm.spaced.bx): > print(summary(glm.spaced.bx)) Call: glm(formula = `surv fac` ~ ., family = "binomial", data = spaced.bx.fac) Coefficients: Estimate Std. Error z value Pr(>|z|) (Intercept) -2.91353 0.28320 -10.288 < 2e-16 *** sexmale 3.18562 0.31478 10.120 < 2e-16 *** pclass3rd 5.03006 0.56669 8.876 < 2e-16 *** `sexmale*H(16 - age)` -0.24181 0.03646 -6.632 3.31e-11 *** `pclass2nd*sexmale` 1.76809 0.32676 5.411 6.27e-08 *** `pclass3rd*H(4 - sibsp)` -0.61865 0.13506 -4.581 4.64e-06 *** `pclass3rd*sexmale` -1.22270 0.39291 -3.112 0.00186 ** `H(age - 32)` 0.03757 0.01178 3.189 0.00143 ** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 (Dispersion parameter for binomial family taken to be 1) Null deviance: 1414.62 on 1045 degrees of freedom Residual deviance: 892.79 on 1038 degrees of freedom AIC: 908.79 Number of Fisher Scoring iterations: 5 > plotmo(glm.spaced.bx, do.par=2) Warning: Cannot determine which variables to plot in degree2 plots (use all2=TRUE?) Confused by variable name "`sexmale*H(16 - age)`" plotmo grid: sexmale pclass3rd sexmale*H(16 - age) pclass2nd*sexmale 1 0 0 0 pclass3rd*H(4 - sibsp) pclass3rd*sexmale H(age - 32) 0 0 0 > plotres(glm.spaced.bx, which=3, do.par=0, info=TRUE, main="plotres(glm.spaced.bx,which=3") > # TODO why is Residuals-Vs-Fitted plot different for plotres and plot for glm models? > plot(glm.spaced.bx, which=1, caption="plot(glm.spaced.bx, which=1)") > par(org.par) > plotmo(glm.spaced.bx, all2=TRUE, degree2=c("sexmale", "pclass"), SHOW.CALL=TRUE, do.par=2) plotmo grid: sexmale pclass3rd sexmale*H(16 - age) pclass2nd*sexmale 1 0 0 0 pclass3rd*H(4 - sibsp) pclass3rd*sexmale H(age - 32) 0 0 0 > plotmo(glm.spaced.bx, degree1=0, all2=TRUE, degree2=c("sexmale", "age"), do.par=0) > par(org.par) # TODO I think plot(glm.spaced.bx) doesn't restore the graphics params? > > printf("\n=== test formulas which have a rhs variable which a matrix ===\n") === test formulas which have a rhs variable which a matrix === > # This also tests that earth's naming of variables is the same as lm for such rhs variables > # > # TODO plotmo fails when rhs variable is a matrix --- would be nice to fix that > > x_ <- etitanic[,"age",drop=FALSE] > x_$pclass <- etitanic$pclass > x_$pclass <- as.numeric(etitanic$pclass) > x_ <- as.matrix(x_) > y_ <- as.matrix(as.numeric(etitanic[,"survived"])) > > earthxy.rhs.mat <- earth(x_, y_, degree=2, trace=1) x[1046,2] with colnames age pclass y[1046,1] with colname y_, and values 1, 1, 0, 0, 0, 1, 1, 0, 1, 0,... Forward pass term 1, 2, 4, 6, 8, 10 RSq changed by less than 0.001 at 9 terms (DeltaRSq 0.00055) After forward pass GRSq 0.120 RSq 0.162 Prune backward penalty 3 nprune null: selected 6 of 9 terms, and 2 of 2 preds After pruning pass GRSq 0.137 RSq 0.158 > print(summary(earthxy.rhs.mat)) Call: earth(x=x_, y=y_, trace=1, degree=2) coefficients (Intercept) 0.47789359 h(18-age) 0.03051719 h(age-18) -0.00609975 h(2-pclass) 0.28092736 h(pclass-2) -0.16376873 h(23-age) * h(pclass-2) -0.01570789 Selected 6 of 9 terms, and 2 of 2 predictors Termination condition: RSq changed by less than 0.001 at 9 terms Importance: pclass, age Number of terms at each degree of interaction: 1 4 1 GCV 0.2088003 RSS 212.8039 GRSq 0.1373292 RSq 0.1578438 > cat("\nevimp(earthxy.rhs.mat)\n") evimp(earthxy.rhs.mat) > print(evimp(earthxy.rhs.mat)) nsubsets gcv rss pclass 5 100.0 100.0 age 4 66.0 69.3 > cat("\nearthxy.rhs.mat$modvars\n") earthxy.rhs.mat$modvars > print(earthxy.rhs.mat$modvars) age pclass age 1 0 pclass 0 1 > plotmo(earthxy.rhs.mat, SHOWCALL=TRUE) # ok plotmo grid: age pclass 28 2 > > earth.rhs.mat <- earth(y_ ~ x_, degree=2, trace=1) x[1046,2] with colnames x_age x_pclass y[1046,1] with colname y_, and values 1, 1, 0, 0, 0, 1, 1, 0, 1, 0,... Forward pass term 1, 2, 4, 6, 8, 10 RSq changed by less than 0.001 at 9 terms (DeltaRSq 0.00055) After forward pass GRSq 0.120 RSq 0.162 Prune backward penalty 3 nprune null: selected 6 of 9 terms, and 2 of 2 preds After pruning pass GRSq 0.137 RSq 0.158 > print(summary(earth.rhs.mat)) Call: earth(formula=y_~x_, trace=1, degree=2) coefficients (Intercept) 0.47789359 h(18-x_age) 0.03051719 h(x_age-18) -0.00609975 h(2-x_pclass) 0.28092736 h(x_pclass-2) -0.16376873 h(23-x_age) * h(x_pclass-2) -0.01570789 Selected 6 of 9 terms, and 2 of 2 predictors Termination condition: RSq changed by less than 0.001 at 9 terms Importance: x_pclass, x_age Number of terms at each degree of interaction: 1 4 1 GCV 0.2088003 RSS 212.8039 GRSq 0.1373292 RSq 0.1578438 > cat("\nevimp(earth.rhs.mat)\n") evimp(earth.rhs.mat) > print(evimp(earth.rhs.mat)) nsubsets gcv rss x_pclass 5 100.0 100.0 x_age 4 66.0 69.3 > cat("\nearth.rhs.mat$modvars\n") earth.rhs.mat$modvars > print(earth.rhs.mat$modvars) x_age x_pclass x_ 1 1 > stopifnot(max(abs(earthxy.rhs.mat$coeff - earth.rhs.mat$coeff)) < 1e-15) > expect.err(try(plotmo(earth.rhs.mat)), # Warning: the variable on the right side of the formula is a matrix or data.frame + "model.frame.default could not interpret the data passed to get.earth.x from model.matrix.earth from predict.earth") Warning: the variable on the right side of the formula is a matrix or data.frame plotmo often cannot process such variables Warning: Cannot determine which variables to plot (use all1=TRUE?) single.names=c(x_,x_,x_,x_) colnames(x)=c(age,pclass) stats::predict(earth.object, data.frame[50,2], type="response") Error : model.frame.default could not interpret the data passed to get.earth.x from model.matrix.earth from predict.earth (actual.nrows=1046 expected.nrows=50 fitted.nrows=1046) Got expected error from try(plotmo(earth.rhs.mat)) > expect.err(try(plotmo(earth.rhs.mat, all1=TRUE)), # still fails + "model.frame.default could not interpret the data passed to get.earth.x from model.matrix.earth from predict.earth") Warning: the variable on the right side of the formula is a matrix or data.frame plotmo often cannot process such variables stats::predict(earth.object, data.frame[50,2], type="response") Error : model.frame.default could not interpret the data passed to get.earth.x from model.matrix.earth from predict.earth (actual.nrows=1046 expected.nrows=50 fitted.nrows=1046) Got expected error from try(plotmo(earth.rhs.mat, all1 = TRUE)) > > lm.rhs.mat <- lm(y_ ~ x_) > print(summary(lm.rhs.mat)) Call: lm(formula = y_ ~ x_) Residuals: Min 1Q Median 3Q Max -0.9113 -0.3505 -0.1995 0.4395 1.0350 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 1.167193 0.062574 18.653 < 2e-16 *** x_age -0.007626 0.001070 -7.125 1.94e-12 *** x_pclass -0.240589 0.018334 -13.123 < 2e-16 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 0.4553 on 1043 degrees of freedom Multiple R-squared: 0.1444, Adjusted R-squared: 0.1427 F-statistic: 87.98 on 2 and 1043 DF, p-value: < 2.2e-16 > expect.err(try(plotmo(lm.rhs.mat)), # Warning: the variable on the right side of the formula is a matrix or data.frame + "predict returned the wrong length (got 1046 but expected 50)") Warning: the variable on the right side of the formula is a matrix or data.frame plotmo often cannot process such variables Warning: 'newdata' had 50 rows but variables found have 1046 rows Error : predict returned the wrong length (got 1046 but expected 50) Got expected error from try(plotmo(lm.rhs.mat)) > expect.err(try(plotmo(lm.rhs.mat, all1=TRUE)), # still fails + "predict returned the wrong length (got 1046 but expected 50)") Warning: the variable on the right side of the formula is a matrix or data.frame plotmo often cannot process such variables Warning: 'newdata' had 50 rows but variables found have 1046 rows Error : predict returned the wrong length (got 1046 but expected 50) Got expected error from try(plotmo(lm.rhs.mat, all1 = TRUE)) > earth1.rhs.mat <- earth(y_ ~ x_, linpreds=TRUE, thresh=0, penalty=-1) # degree1 > cat("\nevimp(earth1.rhs.mat)\n") evimp(earth1.rhs.mat) > print(evimp(earth1.rhs.mat)) nsubsets gcv rss x_pclass 2 100.0 100.0 x_age 1 53.7 53.7 > options(warn=2) > expect.err(try(plotmo(earth.rhs.mat)), + "the variable on the right side of the formula is a matrix or data.frame") Error : (converted from warning) the variable on the right side of the formula is a matrix or data.frame plotmo often cannot process such variables Got expected error from try(plotmo(earth.rhs.mat)) > expect.err(try(plotmo(earth.rhs.mat, all1=TRUE)), # still fails + "the variable on the right side of the formula is a matrix or data.frame") Error : (converted from warning) the variable on the right side of the formula is a matrix or data.frame plotmo often cannot process such variables Got expected error from try(plotmo(earth.rhs.mat, all1 = TRUE)) > options(warn=1) > stopifnot(max(abs(sort(lm.rhs.mat$coeff) - sort(earth1.rhs.mat$coeff))) < 1e-12) > stopifnot(sort(rownames(lm.rhs.mat$coeff)) == sort(rownames(earth1.rhs.mat$coeff))) > > x_nonames <- x_ > colnames(x_nonames) <- NULL > lm.rhs.nonames <- lm(y_ ~ x_nonames) > print(summary(lm.rhs.nonames)) Call: lm(formula = y_ ~ x_nonames) Residuals: Min 1Q Median 3Q Max -0.9113 -0.3505 -0.1995 0.4395 1.0350 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 1.167193 0.062574 18.653 < 2e-16 *** x_nonames1 -0.007626 0.001070 -7.125 1.94e-12 *** x_nonames2 -0.240589 0.018334 -13.123 < 2e-16 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 0.4553 on 1043 degrees of freedom Multiple R-squared: 0.1444, Adjusted R-squared: 0.1427 F-statistic: 87.98 on 2 and 1043 DF, p-value: < 2.2e-16 > expect.err(try(plotmo(lm.rhs.nonames)), # Warning: the variable on the right side of the formula is a matrix or data.frame + "predict returned the wrong length (got 1046 but expected 50)") Warning: the variable on the right side of the formula is a matrix or data.frame plotmo often cannot process such variables Warning: 'newdata' had 50 rows but variables found have 1046 rows Error : predict returned the wrong length (got 1046 but expected 50) Got expected error from try(plotmo(lm.rhs.nonames)) > expect.err(try(plotmo(lm.rhs.nonames, all1=TRUE)), # still fails + "predict returned the wrong length (got 1046 but expected 50)") Warning: the variable on the right side of the formula is a matrix or data.frame plotmo often cannot process such variables Warning: 'newdata' had 50 rows but variables found have 1046 rows Error : predict returned the wrong length (got 1046 but expected 50) Got expected error from try(plotmo(lm.rhs.nonames, all1 = TRUE)) > earth1.rhs.nonames <- earth(y_ ~ x_nonames, linpreds=TRUE, thresh=0, penalty=-1) # degree1 > print(summary(earth1.rhs.nonames)) Call: earth(formula=y_~x_nonames, linpreds=TRUE, thresh=0, penalty=-1) coefficients (Intercept) 1.16719336 x_nonames1 -0.00762624 x_nonames2 -0.24058942 Selected 3 of 3 terms, and 2 of 2 predictors Termination condition: No new term increases RSq at 3 terms Importance: x_nonames2, x_nonames1 Number of terms at each degree of interaction: 1 2 (additive model) GCV 0.2067034 RSS 216.2118 GRSq 0.1443571 RSq 0.1443571 > cat("\nevimp(earth1.rhs.nonames)\n") evimp(earth1.rhs.nonames) > print(evimp(earth1.rhs.nonames)) nsubsets gcv rss x_nonames2 2 100.0 100.0 x_nonames1 1 53.7 53.7 > options(warn=2) > expect.err(try(plotmo(earth1.rhs.nonames)), # Warning: the variable on the right side of the formula is a matrix or data.frame + "the variable on the right side of the formula is a matrix or data.frame") Error : (converted from warning) the variable on the right side of the formula is a matrix or data.frame plotmo often cannot process such variables Got expected error from try(plotmo(earth1.rhs.nonames)) > expect.err(try(plotmo(earth1.rhs.nonames, all1=TRUE)), # still fails + "the variable on the right side of the formula is a matrix or data.frame") Error : (converted from warning) the variable on the right side of the formula is a matrix or data.frame plotmo often cannot process such variables Got expected error from try(plotmo(earth1.rhs.nonames, all1 = TRUE)) > options(warn=1) > stopifnot(max(abs(sort(lm.rhs.nonames$coeff) - sort(earth1.rhs.nonames$coeff))) < 1e-12) > stopifnot(sort(rownames(lm.rhs.nonames$coeff)) == sort(rownames(earth1.rhs.nonames$coeff))) > > printf("\n=== test handling consecutive '-' in formula ===\n") === test handling consecutive '-' in formula === > > options(warn=2) > lm.consec.minus <- lm(Volume~.--Girth, data=trees) # note double -- > expect.err(try(plotmo(lm.consec.minus)), + "Consecutive '-' in formula may cause problems") Error : (converted from warning) Consecutive '-' in formula may cause problems Formula: (Girth + Height) - -Girth Got expected error from try(plotmo(lm.consec.minus)) > earth.consec.minus <- earth(Volume~.--Girth, data=trees) # note double -- > cat("\nsummary(earth.consec.minus)\n") summary(earth.consec.minus) > print(summary(earth.consec.minus)) Call: earth(formula=Volume~.--Girth, data=trees) coefficients (Intercept) 29.0599535 h(14.2-Girth) -3.4198062 h(Girth-14.2) 6.2295143 h(Height-75) 0.5813644 Selected 4 of 5 terms, and 2 of 2 predictors Termination condition: RSq changed by less than 0.001 at 5 terms Importance: Girth, Height Number of terms at each degree of interaction: 1 3 (additive model) GCV 11.25439 RSS 209.1139 GRSq 0.959692 RSq 0.9742029 > cat("\nevimp(earth.consec.minus)\n") evimp(earth.consec.minus) > print(evimp(earth.consec.minus)) nsubsets gcv rss Girth 3 100.0 100.0 Height 1 10.7 11.5 > expect.err(try(plotmo(earth.consec.minus)), + "Consecutive '-' in formula may cause problems") Error : (converted from warning) Consecutive '-' in formula may cause problems Formula: (Girth + Height) - -Girth Got expected error from try(plotmo(earth.consec.minus)) > options(warn=1) > > printf("\n=== test rpart() with spaced.bx ===\n") === test rpart() with spaced.bx === > > library(rpart.plot) Loading required package: rpart > rpart.mod <- rpart(`Survived = YES` ~ ., data=spaced.bx) > printf("\nprint(rpart.rules(rpart.mod))\n") print(rpart.rules(rpart.mod)) > print(rpart.rules(rpart.mod)) Survived = YES 0.062 when sexmale is 1 & pclass3rd is 1 & sexmale*H(16 - age) >= 6.5 & pclass3rd*H(4 - sibsp) < 2 0.082 when sexmale is 1 & sexmale*H(16 - age) < 6.5 & pclass2nd*sexmale is 1 0.150 when sexmale is 1 & pclass3rd is 1 & sexmale*H(16 - age) < 6.5 & pclass2nd*sexmale is 0 0.338 when sexmale is 1 & pclass3rd is 0 & sexmale*H(16 - age) < 6.5 & pclass2nd*sexmale is 0 0.474 when sexmale is 0 & pclass3rd is 1 0.769 when sexmale is 1 & pclass3rd is 1 & sexmale*H(16 - age) >= 6.5 & pclass3rd*H(4 - sibsp) >= 2 0.932 when sexmale is 0 & pclass3rd is 0 1.000 when sexmale is 1 & pclass3rd is 0 & sexmale*H(16 - age) >= 6.5 > set.seed(2020) > plotmo(rpart.mod, do.par=2, degree1=c("sexmale", "pclass3rd"), degree2=2, pt.col="red") plotmo grid: sexmale pclass3rd sexmale*H(16 - age) pclass2nd*sexmale 1 0 0 0 pclass3rd*H(4 - sibsp) pclass3rd*sexmale H(age - 32) 0 0 0 > plotres(rpart.mod, do.par=0, which=c(1,3)) > par(org.par) > > printf("\n=== tibble, class \"Date\", and ndiscrete ===\n") === tibble, class "Date", and ndiscrete === > > library(tibble) > library(lubridate) Attaching package: 'lubridate' The following objects are masked from 'package:base': date, intersect, setdiff, union > tib1 <- tibble(y = c(1, 1, 2, 3), # even number of variables + bool = c(F, F, F, T), + date = c(ymd('2018-08-01'), ymd('2018-08-02'), ymd('2018-08-03'), + ymd('2018-08-03'))) > cat("class tib1$date: ", class(tib1$date), "\n") class tib1$date: Date > mod.tib1 <- lm(y ~ ., data = tib1) > plotmo(mod.tib1, col.response=2, all2=TRUE, ticktype="d", do.par=2, caption="mod.tib1: Dates ndiscrete=default 5") plotmo grid: bool date FALSE 2018-08-02 > plotmo(mod.tib1, col.response=2, degree1=0, all2=TRUE, ticktype="d", do.par=0, theta=-45) > par(org.par) > > plotmo(mod.tib1, col.response=2, all2=TRUE, ticktype="d", do.par=2, ndiscrete=2, caption="mod.tib1: Dates ndiscrete=2") plotmo grid: bool date FALSE 2018-08-02 > plotmo(mod.tib1, col.response=2, degree1=0, all2=TRUE, ticktype="d", do.par=0, theta=-45, ndiscrete=2) > par(org.par) > > plotmo(mod.tib1, col.response=2, all2=TRUE, ticktype="d", do.par=2, ndiscr=1, caption="mod.tib1: Dates ndiscrete=1") plotmo grid: bool date FALSE 2018-08-02 > plotmo(mod.tib1, col.response=2, degree1=0, all2=TRUE, ticktype="d", do.par=0, theta=-45, ndiscrete=2) > par(org.par) > > tib2 <- tibble(y = c(1, 1, 2, 3, 4), # odd number of variables + bool = c(F, F, F, T, T), + date = c(ymd('2018-08-01'), ymd('2018-08-02'), ymd('2018-08-03'), + ymd('2018-08-03'), ymd('2018-08-04'))) > mod.tib2 <- lm(y ~ ., data = tib2) > plotmo(mod.tib2, col.response=2, all2=TRUE, ticktype="d", do.par=2, caption="mod.tib2: Dates ndiscrete=default 5") plotmo grid: bool date FALSE 2018-08-03 > plotmo(mod.tib2, col.response=2, degree1=0, all2=TRUE, ticktype="d", do.par=0, theta=-45) > par(org.par) > > plotmo(mod.tib2, col.response=2, all2=TRUE, ticktype="d", do.par=2, ndiscrete=2, caption="mod.tib2: Dates ndiscrete=2") plotmo grid: bool date FALSE 2018-08-03 > plotmo(mod.tib2, col.response=2, degree1=0, all2=TRUE, ticktype="d", do.par=0, theta=-45, ndiscrete=2) > par(org.par) > > plotmo(mod.tib2, col.response=2, all2=TRUE, ticktype="d", do.par=2, ndiscr=1, caption="mod.tib2: Dates ndiscrete=1") plotmo grid: bool date FALSE 2018-08-03 > plotmo(mod.tib2, col.response=2, degree1=0, all2=TRUE, ticktype="d", do.par=0, theta=-45, ndiscrete=2) > par(org.par) > > source("test.epilog.R") plotmo/inst/slowtests/test.unusual.vars.R0000644000176200001440000005576513737416673020422 0ustar liggesusers# test.unusual.vars.R: test unusual variable names, and unusual formulas # # This file was initially created for plotmo 3.6.0 (Sep 2020) # ALso tests the naken() func introduced in plotmo 3.6.0 and earth 5.2.0 (Sep 2020) source("test.prolog.R") library(earth) data(ozone1) data(etitanic) options(warn=1) # print warnings as they occur check.naken <- function(s, expected, trace=0) { nude <- plotmo:::naken.formula.string(s, trace=trace) printf("%-60.60s %-s\n", s, nude) stopifnot(nude == expected) } printf("=== check naken.formula.string\n") # edge cases check.naken("", "") check.naken(" ", "") check.naken("y~", "y ~ ") check.naken("y~ ", "y ~ ") check.naken("y ~ ", "y ~ ") check.naken("y ~ ", "y ~ ") check.naken(" y ~ ", "y ~ ") check.naken("[", "[", trace=2) check.naken("`", "`", trace=2) # standard formulas check.naken("x", "x") check.naken("x1", "x1") check.naken("y ~ x1 : x2 + x3", "y ~ x1 + x2 + x3", trace=2) check.naken("y ~ x1 + x2 - x3", "y ~ x1 + x2 + x3", trace=2) # TODO "-" is treated as a "+" check.naken("y ~ .-x3", "y ~ . + x3") check.naken("cbind(damage, 6-damage)~temp", "cbind(damage, 6-damage) ~ temp", trace=2) check.naken("depIndex~q_4 + q_2102+q_2104 +q_3105+ q_3106", "depIndex ~ q_4 + q_2102 + q_2104 + q_3105 + q_3106") check.naken("doy ~ (vh+wind+humidity)^2", "doy ~ vh + wind + humidity") check.naken("doy ~ s(wind) + s(humidity,wind) + s(vh)", "doy ~ wind + humidity + vh") check.naken("log(doy) ~ I(vh*wind) + I(humidity*temp)+log(doy)", "log(doy) ~ vh + wind + humidity + temp + doy") check.naken("log(doy)~vh+wind+humidity+I(wind*humidity)+temp+log(ibh)", "log(doy) ~ vh + wind + humidity + temp + ibh", trace=2) check.naken("O3 ~ s(humidity)+s(temp)+s(ibt)+s(temp,ibt)", "O3 ~ humidity + temp + ibt") check.naken("Ozone^(1/3) ~ lo(Solar.R) + lo(Wind, Temp)", "Ozone^(1/3) ~ Solar.R + Wind + Temp") check.naken("Volume~(Girth*Height2)-Height", "Volume ~ Girth + Height2 + Height") check.naken("y ~ s(x) + s(x,z1)", "y ~ x + z1") check.naken("y~s(x0,x1,k=12)+s(x2)+s(x3,k=20,fx=20)", "y ~ x0 + x1 + x2 + x3") check.naken("y~x[,1]+x[,2]", "y ~ x[,1] + x[,2]") check.naken("y~x[,1]+x[,my.list$j]", "y ~ x[,1] + x[,my.list$j]") check.naken("y~x[,i]+x[,2]", "y ~ x[,i] + x[,2]") check.naken("Salary~Hitters[,1]", "Salary ~ Hitters[,1]", trace=2) check.naken("Salary~Hitters[,-1]", "Salary ~ Hitters[,-1]", trace=2) check.naken("Salary~Hitters[,c(1,2)]", "Salary ~ Hitters[,c(1,2)]", trace=2) check.naken("Salary~Hitters[,1:2]", "Salary ~ Hitters[,1:2]") check.naken("Salary~Hitters[,c(1,2)]", "Salary ~ Hitters[,c(1,2)]", trace=2) # nested brackets check.naken("y ~ x1[[2]] + x1[[3]]", "y ~ x1[[2]] + x1[[3]]") check.naken("y[ , 1 ] ~ x1[[2]]", "y[ , 1 ] ~ x1[[2]]") check.naken("y ~ x0[,nonesuch1 + x1[nsuch2^2 + 3 ]]", "y ~ x0[,nonesuch1 + x1[nsuch2^2 + 3 ]]") check.naken("y ~ x0[1,x2[3]] + x4[[5]] + x6[ x7[, 8], x9[ ,x10[11] ], drop=x12[13]]", "y ~ x0[1,x2[3]] + x4[[5]] + x6[ x7[, 8], x9[ ,x10[11] ], drop=x12[13]]") # backquotes check.naken("y ~ `a b c10` + `def`", "y ~ `a b c10` + `def`") check.naken("`y` ~ `a b c10` + `def` + s(sqrt(`x 1`))", "`y` ~ `a b c10` + `def` + `x 1`") # without a response check.naken("x1 + x[,1] + `x3`", "x1 + x[,1] + `x3`") check.naken("Salary~Hitters[,c(1,2)]+sqrt(x)", "Salary ~ Hitters[,c(1,2)] + x") check.naken("Salary~Hitters[,c(1,2)]+sqrt(x)+x99", "Salary ~ Hitters[,c(1,2)] + x + x99") check.naken("Salary~x1+x2+`x6`+x3", "Salary ~ x1 + x2 + `x6` + x3") check.naken("x[,c(1,2)] + x[,3]", "x[,c(1,2)] + x[,3]") check.naken("x[,1] + x[,2] + x[,3] + x[,29] + x[,-14]", "x[,1] + x[,2] + x[,3] + x[,29] + x[,-14]") check.naken("x[,c(1,2)] + x[,3] + x[,5:6] + x[,-1]", "x[,c(1,2)] + x[,3] + x[,5:6] + x[,-1]") check.naken("log(y) ~ x9 + ns(x2,4) + s(x3,x4,df=4) + x5:sqrt(x6)", "log(y) ~ x9 + x2 + x3 + x4 + x5 + x6") check.naken("log(y) ~ x9 + sqrt(x6) + ns(x2,4) + s(x3,x4,df=4) + x5", "log(y) ~ x9 + x6 + x2 + x3 + x4 + x5") check.naken("x[,1] + sqrt(x2) + 2.34e6 + 1", "x[,1] + x2 + 1") printf("\n=== test problem in lm() formula with -nonesuch ===\n") # Using "-nonesuch" in a "." formula (where nonesuch is a non-existent variable name) # causes the following error in stats::terms.formula (called via model.frame.default) # Error in terms.formula(formula, data = data) : (converted from warning) # 'varlist' has changed (from nvar=3) to new 4 after EncodeVars() -- should no longer happen! options(warn=2) # treat warnings as errors expect.err(try(lm(formula = Volume ~ . - nonesuch, data=trees)), "'varlist' has changed (from nvar=3) to new 4 after EncodeVars() -- should no longer happen!") options(warn=1) # print warnings as they occur printf("\n=== test variables names with spaces in them ===\n") spaced.trees <- trees stopifnot(colnames(spaced.trees) == c("Girth", "Height", "Volume")) # sanity check colnames(spaced.trees) <- c("Girth extra", "Height 999", "Volume") # put spaces in the names lm.spaced.trees <- lm(Volume~., data=spaced.trees) options(warn=2) expect.err(try(plotmo(lm.spaced.trees)), "Cannot determine which variables to plot in degree2 plots") options(warn=1) plotmo(lm.spaced.trees) # warning, but still plots (no degree2 plots) plotmo(lm.spaced.trees, all2=TRUE) # no warning earth.spaced.trees <- earth(Volume~. , data=spaced.trees, degree=2) plotmo(earth.spaced.trees) cat("\nevimp(earth.spaced.trees)\n") print(evimp(earth.spaced.trees)) printf("\n=== test non standard variable names and use of earth's bx matrix ===\n") emod <- earth(survived~., data=etitanic, degree=2) plotmo(emod) cat("\nevimp(emod)\n") print(evimp(emod)) bx <- emod$bx bx.df <- as.data.frame(bx[,-1]) # -1 to drop intercept bx.df$survived <- etitanic$survived # following gsub make it a bit easier to see what's going on # because the next call to earth also creates hinge functions # (so we end up with nested hinge functions) colnames(bx.df) <- gsub("h(", "H(", colnames(bx.df), fixed=TRUE) lm.bx <- lm(survived ~ ., data=bx.df) set.seed(2020) earth.bx <- earth(survived ~ ., data=bx.df, degree=2) printf("\nsummary(earth.bx):\n") print(summary(earth.bx)) printf("\nevimp(earth.bx):\n") print(evimp(earth.bx)) plot(earth.bx, info=TRUE) plotmo(lm.bx) # Warning: Cannot determine which variables to plot in degree2 plots plotmo(lm.bx, all2=TRUE, SHOWCALL=TRUE) plotmo(earth.bx, pmethod="partdep", trace=2) printf("\n=== put spaces into the column names of bx (for both response and predictors) ===\n") spaced.bx <- bx.df colnames(spaced.bx) <- gsub("-", " - ", colnames(spaced.bx), fixed=TRUE) colnames(spaced.bx)[colnames(spaced.bx) == "survived"] <- "Survived = YES" printf("\nhead(spaced.bx):\n") print(head(spaced.bx)) lm.spaced.bx <- lm(`Survived = YES` ~ ., data=spaced.bx) set.seed(2020) earth.spaced.bx <- earth(`Survived = YES` ~ ., data=spaced.bx, degree=2, trace=.5, nfold=4, ncross=3, varmod.method="lm", pmethod="cv") printf("\nsummary(earth.spaced.bx):\n") print(summary(earth.spaced.bx)) printf("\nevimp(earth.spaced.bx):\n") print(evimp(earth.spaced.bx)) set.seed(2020) earth.glm.spaced.bx <- earth(`Survived = YES` ~ ., data=spaced.bx, degree=2, trace=.5, glm=list(family="binomial"), nfold=4, ncross=3, varmod.method="lm", pmethod="cv") printf("\nsummary(earth.glm.spaced.bx):\n") print(summary(earth.glm.spaced.bx)) printf("\nevimp(earth.glm.spaced.bx):\n") print(evimp(earth.glm.spaced.bx)) options(warn=2) expect.err(try(plotmo(lm.spaced.bx)), "Cannot determine which variables to plot in degree2 plots") options(warn=1) plotmo(lm.spaced.bx, do.par=2, SHOWCALL=TRUE) plotres(lm.spaced.bx, do.par=0, which=c(1, 3)) par(org.par) plotmo(earth.spaced.bx, degree1="sexmale", do.par=2, level=.8, SHOWCALL=TRUE) plot(earth.spaced.bx, do.par=0, which=c(1, 3), info=TRUE, level=.8, type="earth") par(org.par) plot(earth.spaced.bx, versus="b:", info=TRUE, level=.8, type="earth", SHOWCALL=TRUE) # following should be the same as previous page (since type="earth") plotmo(earth.glm.spaced.bx, degree1="sexmale", do.par=2, level=.8, type="earth", SHOWCALL=TRUE) plot(earth.glm.spaced.bx, do.par=0, which=1, info=TRUE, level=.8, type="earth") # $$ TODO Following shouldn't cause Warning: Internal inconsistency: p$fit - fitted != 0 # No warning if don't use glm=list(family="binomial") in call to earth options(warn=2) expect.err(try(plot(earth.glm.spaced.bx, do.par=0, which=3, info=TRUE, level=.8, type="earth")), "Internal inconsistency: p$fit != fitted") options(warn=1) plot(earth.glm.spaced.bx, do.par=0, which=3, info=TRUE, level=.8, type="earth") par(org.par) expect.err(try(plotmo(earth.glm.spaced.bx, level=.8)), "predict.earth: with earth-glm models, use type=\"earth\" when using the interval argument") plotmo(earth.glm.spaced.bx, degree1="sexmale", do.par=2, SHOWCALL=TRUE) plot(earth.glm.spaced.bx, do.par=0, which=c(1, 3), info=TRUE) par(org.par) printf("\n=== test combinations of variables in formula ===\n") vdata <- data.frame( resp = 1:13, bool = c(F, F, F, F, F, T, T, T, T, T, T, T, T), ord = ordered(c("ORD1", "ORD1", "ORD1", "ORD1", "ORD1", "ORD1", "ORD3", "ORD3", "ORD3", "ORD2", "ORD2", "ORD2", "ORD2"), levels=c("ORD1", "ORD3", "ORD2")), fac = as.factor(c("FAC1", "FAC1", "FAC1", "FAC2", "FAC2", "FAC2", "FAC3", "FAC3", "FAC3", "FAC1", "FAC2", "FAC3", "FAC3")), str = c("STR1", "STR1", "STR1", # WILL BE TREATED LIKE A FACTOR "STR2", "STR2", "STR2", "STR3", "STR3", "STR3", "STR3", "STR3", "STR3", "STR3"), num = c(1, 3, 2, 3, 4, 5, 6, 4, 5, 6.5, 3, 6, 5), # 7 unique values (but one is non integral) sqrt_num = sqrt(c(1, 3, 2, 3, 4, 5, 6, 4, 5, 6.5, 3, 6, 5)), int = c(1L, 1L, 3L, 3L, 4L, 4L, 3L, 5L, 3L, 6L, 7L, 8L, 10L), # 8 unique values date = as.Date( c("2018-08-01", "2018-08-02", "2018-08-03", "2018-08-04", "2018-08-05", "2018-08-06", "2018-08-07", "2018-08-08", "2018-08-08", "2018-08-08", "2018-08-10", "2018-08-11", "2018-08-11")), date_num = as.numeric(as.Date( c("2018-08-01", "2018-08-02", "2018-08-03", "2018-08-04", "2018-08-05", "2018-08-06", "2018-08-07", "2018-08-08", "2018-08-08", "2018-08-08", "2018-08-10", "2018-08-11", "2018-08-11")))) vdata$off <- (1:nrow(vdata)) / nrow(vdata) resp2 <- 13:1 vweights <- rep(1, length.out=nrow(vdata)) vweights[1] <- 2 set.seed(2020) lognum.bool.ord.off <- earth(resp ~ log(num) + bool + ord + offset(off), degree=2, weights=vweights, data=vdata, pmethod="none", varmod.method="lm", nfold=2, ncross=3, trace=1) printf("summary(lognum.bool.ord.off)\n") print(summary(lognum.bool.ord.off)) cat("\nevimp(lognum.bool.ord.off)\n") print(evimp(lognum.bool.ord.off)) plotmo(lognum.bool.ord.off, do.par=2, level=.8, SHOWCALL=TRUE) plot(lognum.bool.ord.off, which=1, do.par=0) par(org.par) num.fac.sqrt.num.ord.bool <- earth(resp ~ num + int + fac + offset(off) + sqrt(num) + ord:bool - int, data=vdata, pmethod="none", trace=1) plotmo(num.fac.sqrt.num.ord.bool, SHOWCALL=TRUE) cat("\nevimp(num.fac.sqrt.num.ord.bool)\n") print(evimp(num.fac.sqrt.num.ord.bool)) printf("\n=== unusual formulas, compare to lm ===\n") lm1 <- lm(resp~ord+sqrt(as.numeric(fac)) + num+sqrt(num / 2)+I(2 * int)+date, data = vdata) # same formula terms as lm1 but in different order earth1 <- earth(resp~sqrt(as.numeric(fac)) + ord + date + num + sqrt(.5 * num)+I(int / .5), data = vdata, linpreds=TRUE, thresh=0, penalty=-1) cat("\nevimp(earth1)\n") print(evimp(earth1)) plotmo(lm1, SHOWCALL=TRUE) plotmo(earth1, SHOWCALL=TRUE) stopifnot(max(abs(sort(lm1$coef) - sort(earth1$coef))) < 1e-10) stopifnot((summary(lm1)$r.squared - earth1$rsq) < 1e-10) stopifnot(max(abs(predict(lm1, newdata=vdata[5,,drop=FALSE]) - predict(earth1, newdata=vdata[5,,drop=FALSE]))) < 1e-10) fac.sqrt <- earth(resp~sqrt(num)+fac, data = vdata, linpreds=TRUE, thresh=0, penalty=-1) fac.sqrt_ <- earth(resp~sqrt_num+fac, data = vdata, linpreds=TRUE, thresh=0, penalty=-1) cat("\nevimp(fac.sqrt)\n") print(evimp(fac.sqrt)) cat("\nevimp(fac.sqrt_)\n") print(evimp(fac.sqrt_)) # as.vector to remove names (which are slightly different: sqrt(num) vs sqrt_num stopifnot(identical(as.vector(fac.sqrt$coef), as.vector(fac.sqrt_$coef))) newdata.extra <- vdata[3:5,] # extra variables unused in the model newdata.extra$extra <- sqrt(newdata.extra[,1]) cat("\ncolnames(newdata.extra):", paste(colnames(newdata.extra)), "\n") newd <- vdata[3:5,c("num", "fac")] # only variables used in the formula model newd_ <- vdata[3:5,c("num", "sqrt_num", "fac")] # only variables used in the xy model stopifnot(identical(predict(fac.sqrt, newdata=newdata.extra), predict(fac.sqrt_, newdata=newd_))) stopifnot(identical(predict(fac.sqrt, newdata=newd), predict(fac.sqrt_, newdata=newd_))) stopifnot(identical(predict(fac.sqrt, newdata=newd), predict(fac.sqrt_, newdata=newd_))) stopifnot(identical(predict(fac.sqrt, newdata=newd), predict(fac.sqrt_, newdata=newd_))) stopifnot(max(abs(predict(fac.sqrt, newdata=newdata.extra) - predict(fac.sqrt_, newdata=newdata.extra))) < 1e-10) stopifnot(max(abs(predict(fac.sqrt, newdata=newdata.extra) - predict(fac.sqrt_, newdata=newdata.extra))) < 1e-10) printf("\n=== two response model ===\n") vdata.2resp <- vdata resp2 <- 13:1 vdata.2resp$resp2 <- resp2 earth.2resp <- earth(resp+resp2~num+sqrt(num), data=vdata.2resp, weights=vweights, trace=1, linpreds=TRUE, thresh=0, penalty=-1) printf("\nsummary(earth.2resp)\n") print(summary(earth.2resp)) cat("\nevimp(earth.2resp)\n") print(evimp(earth.2resp)) par(mfrow = c(2, 2), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0), oma=c(0,0,4,0)) # for formula models, plotmo plots a sinle plot for the effect of num plotmo(earth.2resp, nresp=1, do.par=0, main="earth.2resp nresp1") title <- paste( "two-response model: resp+resp2~num+sqrt(num)\n", "the top row is for earth.formula models: the combined effect of num and sqrt(num) is plotted together\n", "the bottom row is for an earth.default model: num and sqrt(num) are plotted separately") title(title, outer=TRUE, cex=.6) plotmo(earth.2resp, nresp=2, do.par=0, main="earth.2resp nresp2") # put two response data mats into matrix form for earth.default and for lm xmat <- vdata[,c("num", "sqrt_num"), drop=FALSE] colnames(xmat) <- c("num", "sqrt(num)") xmat <- as.matrix(xmat) ymat <- vdata[, "resp", drop=FALSE] ymat$resp2 <- resp2 ymat <- as.matrix(ymat) earthxy.2resp <- earth(xmat, ymat, weights=vweights, trace=1, linpreds=TRUE, thresh=0, penalty=-1) printf("\nsummary(earthxy.2resp)\n") print(summary(earthxy.2resp)) cat("\nevimp(earthxy.2resp)\n") print(evimp(earthxy.2resp)) # for xy models, plotmo plots a separate plots for the effect of num and sqrt(num) plotmo(earthxy.2resp, nresp=1, do.par=0) # plotmo(earthxy.2resp, nresp=2, do.par=0) stopifnot(identical(earth.2resp$coeff, earthxy.2resp$coeff)) lm.2resp <- lm(ymat~xmat, weights=vweights) printf("\nsummary(lm.2resp)\n") print(summary(lm.2resp)) options(warn=2) # treat warnings as errors expect.err(try(plotmo(lm.2resp, nresp=1)), "the variable on the right side of the formula is a matrix or data.frame") options(warn=1) # print warnings as they occur # check that lm and earth coeffs are the same # need order() below because coeffs appear in different row order in the coeff mat earth.2resp.order <- order(earth.2resp$coeff[,1]) lm.order <- order(lm.2resp$coeff[,1]) stopifnot(max(abs(earth.2resp$coeff[earth.2resp.order] - lm.2resp$coeff[lm.order])) < 1e-10) printf("\n=== test glm() with spaced.bx ===\n") # glm requires response to be a factor (or two columns) spaced.bx.fac <- spaced.bx spaced.bx.fac$`surv fac` <- factor(ifelse(spaced.bx$`Survived = YES`, "yes", "no"), levels = c("yes", "no")) spaced.bx.fac$`Survived = YES` <- NULL glm.spaced.bx <- glm(`surv fac` ~ ., data=spaced.bx.fac, family="binomial") printf("summary(glm.spaced.bx):\n") print(summary(glm.spaced.bx)) plotmo(glm.spaced.bx, do.par=2) plotres(glm.spaced.bx, which=3, do.par=0, info=TRUE, main="plotres(glm.spaced.bx,which=3") # TODO why is Residuals-Vs-Fitted plot different for plotres and plot for glm models? plot(glm.spaced.bx, which=1, caption="plot(glm.spaced.bx, which=1)") par(org.par) plotmo(glm.spaced.bx, all2=TRUE, degree2=c("sexmale", "pclass"), SHOW.CALL=TRUE, do.par=2) plotmo(glm.spaced.bx, degree1=0, all2=TRUE, degree2=c("sexmale", "age"), do.par=0) par(org.par) # TODO I think plot(glm.spaced.bx) doesn't restore the graphics params? printf("\n=== test formulas which have a rhs variable which a matrix ===\n") # This also tests that earth's naming of variables is the same as lm for such rhs variables # # TODO plotmo fails when rhs variable is a matrix --- would be nice to fix that x_ <- etitanic[,"age",drop=FALSE] x_$pclass <- etitanic$pclass x_$pclass <- as.numeric(etitanic$pclass) x_ <- as.matrix(x_) y_ <- as.matrix(as.numeric(etitanic[,"survived"])) earthxy.rhs.mat <- earth(x_, y_, degree=2, trace=1) print(summary(earthxy.rhs.mat)) cat("\nevimp(earthxy.rhs.mat)\n") print(evimp(earthxy.rhs.mat)) cat("\nearthxy.rhs.mat$modvars\n") print(earthxy.rhs.mat$modvars) plotmo(earthxy.rhs.mat, SHOWCALL=TRUE) # ok earth.rhs.mat <- earth(y_ ~ x_, degree=2, trace=1) print(summary(earth.rhs.mat)) cat("\nevimp(earth.rhs.mat)\n") print(evimp(earth.rhs.mat)) cat("\nearth.rhs.mat$modvars\n") print(earth.rhs.mat$modvars) stopifnot(max(abs(earthxy.rhs.mat$coeff - earth.rhs.mat$coeff)) < 1e-15) expect.err(try(plotmo(earth.rhs.mat)), # Warning: the variable on the right side of the formula is a matrix or data.frame "model.frame.default could not interpret the data passed to get.earth.x from model.matrix.earth from predict.earth") expect.err(try(plotmo(earth.rhs.mat, all1=TRUE)), # still fails "model.frame.default could not interpret the data passed to get.earth.x from model.matrix.earth from predict.earth") lm.rhs.mat <- lm(y_ ~ x_) print(summary(lm.rhs.mat)) expect.err(try(plotmo(lm.rhs.mat)), # Warning: the variable on the right side of the formula is a matrix or data.frame "predict returned the wrong length (got 1046 but expected 50)") expect.err(try(plotmo(lm.rhs.mat, all1=TRUE)), # still fails "predict returned the wrong length (got 1046 but expected 50)") earth1.rhs.mat <- earth(y_ ~ x_, linpreds=TRUE, thresh=0, penalty=-1) # degree1 cat("\nevimp(earth1.rhs.mat)\n") print(evimp(earth1.rhs.mat)) options(warn=2) expect.err(try(plotmo(earth.rhs.mat)), "the variable on the right side of the formula is a matrix or data.frame") expect.err(try(plotmo(earth.rhs.mat, all1=TRUE)), # still fails "the variable on the right side of the formula is a matrix or data.frame") options(warn=1) stopifnot(max(abs(sort(lm.rhs.mat$coeff) - sort(earth1.rhs.mat$coeff))) < 1e-12) stopifnot(sort(rownames(lm.rhs.mat$coeff)) == sort(rownames(earth1.rhs.mat$coeff))) x_nonames <- x_ colnames(x_nonames) <- NULL lm.rhs.nonames <- lm(y_ ~ x_nonames) print(summary(lm.rhs.nonames)) expect.err(try(plotmo(lm.rhs.nonames)), # Warning: the variable on the right side of the formula is a matrix or data.frame "predict returned the wrong length (got 1046 but expected 50)") expect.err(try(plotmo(lm.rhs.nonames, all1=TRUE)), # still fails "predict returned the wrong length (got 1046 but expected 50)") earth1.rhs.nonames <- earth(y_ ~ x_nonames, linpreds=TRUE, thresh=0, penalty=-1) # degree1 print(summary(earth1.rhs.nonames)) cat("\nevimp(earth1.rhs.nonames)\n") print(evimp(earth1.rhs.nonames)) options(warn=2) expect.err(try(plotmo(earth1.rhs.nonames)), # Warning: the variable on the right side of the formula is a matrix or data.frame "the variable on the right side of the formula is a matrix or data.frame") expect.err(try(plotmo(earth1.rhs.nonames, all1=TRUE)), # still fails "the variable on the right side of the formula is a matrix or data.frame") options(warn=1) stopifnot(max(abs(sort(lm.rhs.nonames$coeff) - sort(earth1.rhs.nonames$coeff))) < 1e-12) stopifnot(sort(rownames(lm.rhs.nonames$coeff)) == sort(rownames(earth1.rhs.nonames$coeff))) printf("\n=== test handling consecutive '-' in formula ===\n") options(warn=2) lm.consec.minus <- lm(Volume~.--Girth, data=trees) # note double -- expect.err(try(plotmo(lm.consec.minus)), "Consecutive '-' in formula may cause problems") earth.consec.minus <- earth(Volume~.--Girth, data=trees) # note double -- cat("\nsummary(earth.consec.minus)\n") print(summary(earth.consec.minus)) cat("\nevimp(earth.consec.minus)\n") print(evimp(earth.consec.minus)) expect.err(try(plotmo(earth.consec.minus)), "Consecutive '-' in formula may cause problems") options(warn=1) printf("\n=== test rpart() with spaced.bx ===\n") library(rpart.plot) rpart.mod <- rpart(`Survived = YES` ~ ., data=spaced.bx) printf("\nprint(rpart.rules(rpart.mod))\n") print(rpart.rules(rpart.mod)) set.seed(2020) plotmo(rpart.mod, do.par=2, degree1=c("sexmale", "pclass3rd"), degree2=2, pt.col="red") plotres(rpart.mod, do.par=0, which=c(1,3)) par(org.par) printf("\n=== tibble, class \"Date\", and ndiscrete ===\n") library(tibble) library(lubridate) tib1 <- tibble(y = c(1, 1, 2, 3), # even number of variables bool = c(F, F, F, T), date = c(ymd('2018-08-01'), ymd('2018-08-02'), ymd('2018-08-03'), ymd('2018-08-03'))) cat("class tib1$date: ", class(tib1$date), "\n") mod.tib1 <- lm(y ~ ., data = tib1) plotmo(mod.tib1, col.response=2, all2=TRUE, ticktype="d", do.par=2, caption="mod.tib1: Dates ndiscrete=default 5") plotmo(mod.tib1, col.response=2, degree1=0, all2=TRUE, ticktype="d", do.par=0, theta=-45) par(org.par) plotmo(mod.tib1, col.response=2, all2=TRUE, ticktype="d", do.par=2, ndiscrete=2, caption="mod.tib1: Dates ndiscrete=2") plotmo(mod.tib1, col.response=2, degree1=0, all2=TRUE, ticktype="d", do.par=0, theta=-45, ndiscrete=2) par(org.par) plotmo(mod.tib1, col.response=2, all2=TRUE, ticktype="d", do.par=2, ndiscr=1, caption="mod.tib1: Dates ndiscrete=1") plotmo(mod.tib1, col.response=2, degree1=0, all2=TRUE, ticktype="d", do.par=0, theta=-45, ndiscrete=2) par(org.par) tib2 <- tibble(y = c(1, 1, 2, 3, 4), # odd number of variables bool = c(F, F, F, T, T), date = c(ymd('2018-08-01'), ymd('2018-08-02'), ymd('2018-08-03'), ymd('2018-08-03'), ymd('2018-08-04'))) mod.tib2 <- lm(y ~ ., data = tib2) plotmo(mod.tib2, col.response=2, all2=TRUE, ticktype="d", do.par=2, caption="mod.tib2: Dates ndiscrete=default 5") plotmo(mod.tib2, col.response=2, degree1=0, all2=TRUE, ticktype="d", do.par=0, theta=-45) par(org.par) plotmo(mod.tib2, col.response=2, all2=TRUE, ticktype="d", do.par=2, ndiscrete=2, caption="mod.tib2: Dates ndiscrete=2") plotmo(mod.tib2, col.response=2, degree1=0, all2=TRUE, ticktype="d", do.par=0, theta=-45, ndiscrete=2) par(org.par) plotmo(mod.tib2, col.response=2, all2=TRUE, ticktype="d", do.par=2, ndiscr=1, caption="mod.tib2: Dates ndiscrete=1") plotmo(mod.tib2, col.response=2, degree1=0, all2=TRUE, ticktype="d", do.par=0, theta=-45, ndiscrete=2) par(org.par) source("test.epilog.R") plotmo/inst/slowtests/test.parsnip.R0000644000176200001440000002740614564116107017403 0ustar liggesusers# test.parsnip.R: test the parsnip package with earth and other models # Stephen Milborrow Sep 2020 Petaluma source("test.prolog.R") options(warn=1) # print warnings as they occur library(earth) cat("loading parsnip libraries\n") # these libraries take several seconds to load library(tidymodels, quietly=TRUE, verbose=FALSE) library(timetk) library(lubridate) cat("loaded parsnip libraries\n") cat("parsnip version:", as.character(packageVersion("parsnip")[[1]]), "\n") vdata <- data.frame( resp = 1:23, bool = c(F, F, F, F, F, T, T, T, T, T, T, T, T, F, F, T, T, T, T, T, T, T, T), ord = ordered(c("ORD1", "ORD1", "ORD1", "ORD1", "ORD1", "ORD1", "ORD1", "ORD3", "ORD1", "ORD2", "ORD2", "ORD2", "ORD2", "ORD2", "ORD2", "ORD2", "ORD3", "ORD3", "ORD3", "ORD2", "ORD2", "ORD2", "ORD2"), levels=c("ORD1", "ORD3", "ORD2")), fac = as.factor(c("FAC1", "FAC1", "FAC1", "FAC2", "FAC2", "FAC2", "FAC3", "FAC1", "FAC1", "FAC1", "FAC2", "FAC2", "FAC2", "FAC2", "FAC2", "FAC2", "FAC3", "FAC3", "FAC3", "FAC1", "FAC3", "FAC3", "FAC3")), str = c("STR1", "STR1", "STR1", # WILL BE TREATED LIKE A FACTOR "STR1", "STR1", "STR1", "STR2", "STR2", "STR2", "STR3", "STR3", "STR2", "STR3", "STR2", "STR3", "STR2", "STR3", "STR3", "STR3", "STR3", "STR3", "STR3", "STR3"), num = c(1, 9, 2, 3, 14, 5, 6, 4, 5, 6.5, 3, 6, 5, 3, 4, 5, 6, 4, 5, 16.5, 3, 16, 15), sqrt_num = sqrt( c(1, 9, 2, 3, 14, 5, 6, 4, 5, 6.5, 3, 6, 5, 3, 4, 5, 6, 4, 5, 16.5, 3, 16, 15)), int = c(1L, 1L, 3L, 3L, 4L, 4L, 3L, 5L, 3L, 6L, 7L, 8L, 10L, 13L, 14L, 3L, 13L, 5L, 13L, 16L, 17L, 18L, 11L), date = as.Date( c("2018-08-01", "2018-08-02", "2018-08-03", "2018-08-04", "2018-08-05", "2018-08-06", "2018-08-07", "2018-08-08", "2018-08-08", "2018-08-10", "2018-08-10", "2018-08-11", "2018-08-11", "2018-08-11", "2018-08-12", "2018-08-13", "2018-08-10", "2018-08-15", "2018-08-17", "2018-08-04", "2018-08-19", "2018-08-03", "2018-08-18")), date_num = as.numeric(as.Date( c("2018-08-01", "2018-08-02", "2018-08-03", "2018-08-04", "2018-08-05", "2018-08-06", "2018-08-07", "2018-08-08", "2018-08-08", "2018-08-10", "2018-08-10", "2018-08-11", "2018-08-11", "2018-08-11", "2018-08-12", "2018-08-13", "2018-08-10", "2018-08-15", "2018-08-17", "2018-08-04", "2018-08-19", "2018-08-03", "2018-08-18")))) set.seed(2020) splits <- initial_time_split(vdata, prop=.9) #--- lm ---------------------------------------------------------------------- lm1 <- lm(resp~num+fac:int+date+ord+str, data=training(splits)) cat("lm1:\n") print(summary(lm1)) set.seed(2020) lmpar <- linear_reg(mode = "regression") %>% set_engine("lm") %>% fit(resp~num+fac:int+date+ord+str, data = training(splits)) stopifnot(identical(lm1$coeff, lmpar$fit$coeff)) predict.lm1 <- predict(lm1, testing(splits)) predict.lmpar <- lmpar %>% predict(testing(splits)) stopifnot(all(predict.lm1 == predict.lmpar)) par(mfrow = c(3, 3), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) plotmo(lm1, do.par=2, SHOWCALL=TRUE) plotres(lm1, which=c(3,1), do.par=FALSE) plotmo(lmpar, do.par=2, SHOWCALL=TRUE) plotres(lmpar, which=c(3,1), do.par=FALSE) plotmo(lmpar$fit, do.par=2, SHOWCALL=TRUE) plotres(lmpar$fit, which=c(3,1), do.par=FALSE) par(org.par) lmpar.sqrtnum <- linear_reg(mode = "regression") %>% set_engine("lm") %>% fit(resp~sqrt(num), data = training(splits)) #$$ TODO # expect.err(try(plotmo(lmpar.sqrtnum)), # "cannot get the original model predictors") #--- earth ------------------------------------------------------------------- # note that sqrt(num) is ok, unlike parsnip models for lm and rpart earth1 <- earth(resp~sqrt(num)+int+ord:bool+fac+str+date, degree=2, data=training(splits), pmethod="none") cat("earth1:\n") print(summary(earth1)) set.seed(2020) earthpar <- mars(mode = "regression", prune_method="none", prod_degree=2) %>% set_engine("earth") %>% fit(resp~sqrt(num)+int+ord:bool+fac+str+date, data = training(splits)) cat("earthpar:\n") print(earthpar) cat("summary(earthpar$fit)\n") print(summary(earthpar$fit)) stopifnot(identical(earth1$coeff, earthpar$fit$coeff)) predict.earth1 <- predict(earth1, testing(splits)) predict.earthpar <- earthpar %>% predict(testing(splits)) stopifnot(all(predict.earth1 == predict.earthpar)) par(mfrow = c(3, 3), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) plotmo(earth1, do.par=2, pt.col=3, SHOWCALL=TRUE) set.seed(2020) plotres(earth1, which=c(1,3), do.par=FALSE, pt.col=3, legend.pos="topleft") par(org.par) par(mfrow = c(3, 3), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) plotmo(earthpar, do.par=2, pt.col=3, SHOWCALL=TRUE) set.seed(2020) plotres(earthpar, which=c(1,3), do.par=FALSE, pt.col=3, legend.pos="topleft") par(org.par) par(mfrow = c(3, 3), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) plotmo(earthpar$fit, do.par=2, pt.col=3, SHOWCALL=TRUE) set.seed(2020) plotres(earthpar$fit, which=c(1,3), do.par=FALSE, pt.col=3, legend.pos="topleft") par(org.par) #--- rpart ------------------------------------------------------------------- library(rpart) library(rpart.plot) rpart1 <- rpart(resp~num+fac+int+date+ord+str, data=training(splits), control=rpart.control(minsplit=1, cp=.0001)) cat("\nrpart.rules(rpart1)\n") print(rpart.rules(rpart1)) set.seed(2020) # TODO note need of model=TRUE below (needed only for further processing with e.g. plotmo) rpartpar <- decision_tree(mode = "regression", min_n=1, cost_complexity=.0001) %>% set_engine("rpart", model=TRUE) %>% fit(resp~num+fac+int+date+ord+str, data = training(splits)) cat("\nrpart.rules(rpartpar$fit)\n") print(rpart.rules(rpartpar$fit)) predict.rpart1 <- predict(rpart1, testing(splits)) predict.rpartpar <- rpartpar %>% predict(testing(splits)) stopifnot(all(predict.rpart1 == predict.rpartpar)) par(mfrow = c(3, 3), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) plotmo(rpart1, do.par=2, SHOWCALL=TRUE, trace=0) plotres(rpart1, which=c(3,1), do.par=FALSE) plotmo(rpartpar, do.par=2, SHOWCALL=TRUE, trace=0) plotres(rpartpar, which=c(3,1), do.par=FALSE) plotmo(rpartpar$fit, do.par=2, SHOWCALL=TRUE) plotres(rpartpar$fit, which=c(3,1), do.par=FALSE) par(org.par) # TODO note that this differs from the above rpart model in that we don't use model=TRUE rpartpar.nosavemodel <- decision_tree(mode = "regression", min_n=1, cost_complexity=.0001) %>% set_engine("rpart") %>% fit(resp~num+fac+int+date+str, data = training(splits)) cat("\nrpart.rules(rpartpar.nosavemodel$fit)\n") options(warn=2) expect.err(try(rpart.rules(rpartpar.nosavemodel$fit)), "Cannot retrieve the data used to build the model") options(warn=1) expect.err(try(plotmo(rpartpar.nosavemodel)), "Cannot plot parsnip rpart model: need model=TRUE in call to rpart") rpart.sqrtnum <- decision_tree(mode = "regression", min_n=1, cost_complexity=.0001) %>% set_engine("rpart", model=TRUE) %>% fit(resp~sqrt(num)+fac+int+date+ord+str, data = training(splits)) cat("\nrpart.rules(rpart.sqrtnum$fit)\n") print(rpart.rules(rpart.sqrtnum$fit)) # ok #$$ TODO # expect.err(try(plotmo(rpart.sqrtnum)), # "cannot get the original model predictors") #----------------------------------------------------------------------------------- # Test fix for github bug report https://github.com/tidymodels/parsnip/issues/341 # (fixed Sep 2020) cat("===m750a first example===\n") set.seed(2020) m750a <- m4_monthly %>% filter(id == "M750") %>% select(-id) print(m750a) # a tibble set.seed(2020) splits_a <- initial_time_split(m750a, prop = 0.9) earth_m750a <- earth(log(value) ~ as.numeric(date) + month(date, label = TRUE), data = training(splits_a), degree=2) print(summary(earth_m750a)) set.seed(2020) model_m750a <- mars(mode = "regression", prod_degree=2) %>% set_engine("earth") %>% fit(log(value) ~ as.numeric(date) + month(date, label = TRUE), data = training(splits_a)) print(summary(model_m750a$fit)) stopifnot(identical(earth_m750a$coeff, model_m750a$fit$coeff)) predict_earth_m750a <- predict(earth_m750a, newdata=testing(splits_a)[1:3,]) predict_m750a <- model_m750a %>% predict(testing(splits_a)[1:3,]) stopifnot(max(c(9.238049628, 9.240535151, 9.232361834) - predict_m750a) < 1e-8) stopifnot(max(predict_earth_m750a - predict_m750a) < 1e-20) par(mfrow = c(2, 2), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) set.seed(2020) plotmo(model_m750a, trace=2, do.par=FALSE, pt.col="green", main="model_m750a", SHOWCALL=TRUE) set.seed(2020) plotmo(model_m750a$fit, trace=1, do.par=FALSE, pt.col="green", main="model_m750a$fit", SHOWCALL=TRUE) set.seed(2020) plotmo(earth_m750a, trace=1, do.par=FALSE, pt.col="green", main="earth_m750a", SHOWCALL=TRUE) par(org.par) cat("===m750a second example===\n") set.seed(2020) m750b <- m4_monthly %>% filter(id == "M750") %>% select(-id) %>% rename(date2 = date) print(m750b) # tibble set.seed(2020) splits_b <- initial_time_split(m750b, prop = 0.9) set.seed(2020) model_m750b <- mars(mode = "regression") %>% set_engine("earth") %>% fit(log(value) ~ as.numeric(date2) + month(date2, label = TRUE), data = training(splits_b)) # new data that only contains the feature "date" as a predictor future_data <- m750b %>% future_frame(date2, .length_out = "3 years") print(future_data) # a tibble with a single column of class "Date" stopifnot(class(future_data[,1,drop=TRUE]) == "Date") predict_m750a <- model_m750b %>% predict(new_data = future_data) par(mfrow = c(2, 2), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) set.seed(2020) plotmo(model_m750b, trace=2, do.par=FALSE, pt.col="green", main="model_m750b", SHOWCALL=TRUE) set.seed(2020) plotmo(model_m750b$fit, trace=1, do.par=FALSE, pt.col="green", main="model_m750b$fit", SHOWCALL=TRUE) par(org.par) #----------------------------------------------------------------------------------- # multiple response earth model data(etitanic) etit <- etitanic etit$survived <- factor(ifelse(etitanic$survived == 1, "yes", "no"), levels = c("yes", "no")) etit$notsurvived <- factor(ifelse(etitanic$survived == 0, "notsurvived", "survived"), levels = c("notsurvived", "survived")) set.seed(2020) earth_tworesp <- earth(survived + notsurvived ~ ., data=etit, degree=2) print(summary(earth_tworesp)) # TODO following commented out because parsnip (version 0.1.5) says "'+' not meaningful for factors" # set.seed(2020) # mars_tworesp <- mars(mode = "regression", prod_degree=2) %>% # set_engine("earth") %>% # fit(survived + notsurvived~., data=etit) # print(summary(mars_tworesp)) # print(summary(mars_tworesp$fit)) # # stopifnot(identical(earth_tworesp$coeff, mars_tworesp$fit$coeff)) # # predict.earth_tworesp <- predict(earth_tworesp, etit[3:6,]) # predict.mars_tworesp <- mars_tworesp %>% predict(etit[3:6,]) # stopifnot(all(predict.earth_tworesp == predict.mars_tworesp)) # # plotmo(earth_tworesp, trace=0, nresponse=1, SHOWCALL=TRUE) # plotmo(mars_tworesp, trace=0, nresponse=1, SHOWCALL=TRUE) # plotmo(mars_tworesp, trace=0, nresponse=2, SHOWCALL=TRUE) source("test.epilog.R") plotmo/inst/slowtests/test.modguide.R0000644000176200001440000003323113725307664017525 0ustar liggesusers# test.modguide.bat: test model1 and model2 (linmod examples) in modguide.pdf source("test.prolog.R") options(warn=1) # print warnings as they occur almost.equal <- function(x, y, max=1e-8) { stopifnot(max >= 0 && max < .01) length(x) == length(y) && max(abs(x - y)) < max } # check that fit model matches ref lm model in all essential details check.lm <- function(fit, ref, newdata=trees[3:5,], check.coef.names=TRUE, check.casenames=TRUE, check.newdata=TRUE) { check.names <- function(fit.names, ref.names) { if(check.casenames && # lm always adds rownames even if "1", "2", "3" # this seems wasteful of resources, so linmod doesn't do this !is.null(fit.names) && !identical(fit.names, ref.names)) { print(fit.names) print(ref.names) stop(deparse(substitute(fit.names)), " != ", deparse(substitute(ref.names))) } } cat("check ", deparse(substitute(fit)), " vs ", deparse(substitute(ref)), "\n", sep="") stopifnot(coef(fit) == coef(ref)) if(check.coef.names) stopifnot(identical(names(coef(fit)), names(coef(ref)))) stopifnot(identical(dim(fit$coefficients), dim(ref$coefficients))) stopifnot(length(fit$coefficients) == length(ref$coefficients)) stopifnot(almost.equal(fit$coefficients, ref$coefficients)) stopifnot(identical(dim(fit$residuals), dim(ref$residuals))) stopifnot(length(fit$residuals) == length(ref$residuals)) stopifnot(almost.equal(fit$residuals, ref$residuals)) stopifnot(identical(dim(fit$fitted.values), dim(ref$fitted.values))) stopifnot(length(fit$fitted.values) == length(ref$fitted.values)) stopifnot(almost.equal(fit$fitted.values, ref$fitted.values)) if(!is.null(fit$vcov) && !is.null(ref$vcov)) { stopifnot(identical(dim(fit$vcov), dim(ref$vcov))) stopifnot(length(fit$vcov) == length(ref$vcov)) stopifnot(almost.equal(fit$vcov, ref$vcov)) } ref.sigma <- ref$sigma if(is.null(ref.sigma)) # in lm models, sigma is only available from summary() ref.sigma <- summary(ref)$sigma stopifnot(almost.equal(fit$sigma, ref.sigma)) stopifnot(almost.equal(fit$df, ref$df)) stopifnot(almost.equal(fitted(fit), fitted(ref))) check.names(names(fitted(fit)), names(fitted(ref))) stopifnot(almost.equal(residuals(fit), residuals(ref))) check.names(names(residuals(fit)), names(residuals(ref))) stopifnot(almost.equal(predict(fit), predict(ref))) check.names(names(predict(fit)), names(predict(ref))) if(check.newdata) { stopifnot(almost.equal(predict(fit, newdata=newdata), predict(ref, newdata=newdata))) check.names(names(predict(fit, newdata=newdata)), names(predict(ref, newdata=newdata))) } } ### Model 1: original code from Friedrich Leisch tutorial source("modguide.model1.R") cat("==example issues with predict with functions in the tutorial\n") data(trees) tr <- trees # trees data but with rownames rownames(tr) <- paste("tree", 1:nrow(trees), sep="") fit1 <- linmod(Volume~., data=tr) expect.err(try(predict(fit1, newdata=data.frame(Girth=10, Height=80))), "object 'Volume' not found") expect.err(try(predict(fit1, newdata=as.matrix(tr[1:3,]))), "'data' must be a data.frame, not a matrix or an array") library(plotmo) expect.err(try(plotmo(fit1)), "object 'Volume' not found") fit2 <- linmod(cbind(1, tr[,1:2]), tr[,3]) stopifnot(coef(fit1) == coef(fit2)) # following fail because newdata is a data.frame not a matrix expect.err(try(predict(fit2, newdata=tr[,1:2])), "requires numeric/complex matrix/vector arguments") expect.err(try(predict(fit2, newdata=data.frame(Girth=10, Height=80))), "requires numeric/complex matrix/vector arguments") expect.err(try(predict(fit2, newdata=as.matrix(data.frame(Girth=10, Height=80)))), "non-conformable arguments") expect.err(try(plotmo(fit2)), "requires numeric/complex matrix/vector arguments") cat("==a plotmo method function can deal with the issues\n") plotmo.predict.linmod <- function(object, newdata, ...) { if(is.null(object$formula)) # x,y interface? plotmo:::plotmo.predict.defaultm(object, newdata, ...) # pass matrix not data.frame else { # add dummy response column to newdata newdata[[as.character(as.list(object$formula)[[2]])]] <- 1 plotmo:::plotmo.predict.default(object, newdata, ...) } } plotmo(fit1, pt.col=2, caption="fit1 with original tutorial code and plotmo.predict.linmod") plotmo(fit2, pt.col=2, caption="fit2 with original tutorial code and plotmo.predict.linmod") remove(plotmo.predict.linmod) ### Model 2: minimal changes version for vignette "Guidelines for S3 Regression Models" source("modguide.model2.R") cat("==check that example issues with functions in the tutorial have gone\n") fit1.form <- linmod(Volume~., data=tr) cat("==print(summary(fit1.form))\n") print(summary(fit1.form)) stopifnot(abs(predict(fit1.form, newdata=data.frame(Girth=10, Height=80)) - 16.234045) < 1e-5) stopifnot(sum(abs(predict(fit1.form, newdata=as.matrix(tr[1:3,])) - c(4.8376597, 4.5538516, 4.8169813))) < 1e-5) lm.tr <- lm(Volume~., data=tr) check.lm(fit1.form, lm.tr) fit1.mat <- linmod(tr[,1:2], tr[,3]) # note no need for intercept term cat("==print(summary(fit1.mat))\n") print(summary(fit1.mat)) stopifnot(abs(predict(fit1.mat, newdata=data.frame(Girth=10, Height=80)) - 16.234045) < 1e-5) stopifnot(sum(abs(predict(fit1.mat, newdata=tr[1:3,1:2]) - c(4.8376597, 4.5538516, 4.8169813))) < 1e-5) stopifnot(abs(predict(fit1.mat, newdata=as.matrix(data.frame(Girth=10, Height=80))) - 16.234045) < 1e-5) check.lm(fit1.mat, lm.tr, newdata=trees[3:5,1:2]) cat("==example plots\n") library(plotmo) data(trees) fit1.form <- linmod(Volume~., data=trees) print(fit1.form) print(summary(fit1.form)) fit1.mat <- linmod(trees[,1:2], trees[,3]) print(fit1.mat) print(summary(fit1.mat)) plotmo(fit1.form) plotmo(fit1.mat) plotres(fit1.form) plotres(fit1.mat) cat("==test model building with different numeric args\n") x <- tr[,1:2] y <- tr[,3] fit2.mat <- linmod(x, y) check.lm(fit2.mat, lm.tr, newdata=trees[3:5,1:2]) # check consistency with lm expect.err(try(linmod(y~x)), "invalid type (list) for variable 'x'") expect.err(try(lm(y~x)), "invalid type (list) for variable 'x'") fit3.mat <- linmod(as.matrix(x), as.matrix(y)) check.lm(fit3.mat, lm.tr, newdata=trees[3:5,1:2]) fit4.form <- linmod(y ~ as.matrix(x)) lm4 <- linmod(y ~ as.matrix(x)) check.lm(fit4.form, lm4) stopifnot(coef(fit4.form) == coef(lm.tr), gsub("as.matrix(x)", "", names(coef(fit4.form)), fixed=TRUE) == names(coef(lm.tr))) xm <- as.matrix(x) fit5.form <- linmod(y ~ xm) lm5 <- linmod(y ~ xm) check.lm(fit5.form, lm5) stopifnot(coef(fit5.form) == coef(lm.tr), gsub("xm", "", names(coef(fit5.form)), fixed=TRUE) == names(coef(lm.tr))) cat("==test correct use of global x1 and y1\n") x1 <- tr[,1] y1 <- tr[,3] linmod1 <- linmod(y1~x1) fit6.mat <- linmod(x1, y1) check.lm(fit6.mat, linmod1, newdata=x1[3:5], check.newdata=FALSE, # TODO needed because linmod1 ignores newdata(!) check.coef.names=FALSE, check.casenames=FALSE) print(predict(fit6.mat, newdata=x1[3:5])) stopifnot(almost.equal(predict(fit6.mat, newdata=x1[3]), 7.63607739644657)) # production version only: # stopifnot(coef(fit6.mat) == coef(linmod1), # names(coef(fit6.mat)) == c("(Intercept)", "V1")) # names(coef(linmod1) are "(Intercept)" "x1" fit6.form <- linmod(y1~x1) check.lm(fit6.form, linmod1) cat("==check integer input (sibsp is an integer) \n") library(earth) # for etitanic data data(etitanic) tit <- etitanic[seq(1, nrow(etitanic), by=60), ] # small set of data for tests (18 cases) tit$survived <- tit$survived != 0 # convert to logical rownames(tit) <- paste("pas", 1:nrow(tit), sep="") cat(paste(colnames(tit), "=", sapply(tit, class), sep="", collapse=", "), "\n") fit7.mat <- linmod(tit$age, tit$sibsp) lm7 <- lm.fit(cbind(1, tit$age), tit$sibsp) stopifnot(coef(fit7.mat) == coef(lm7)) # coef names will differ fit7.form <- linmod(sibsp~age, data=tit) lm7.form <- lm(sibsp~age, data=tit) check.lm(fit7.form, lm7.form, newdata=tit[3:5,]) fit8.mat <- linmod(tit$sibsp, tit$age) lm8 <- lm.fit(cbind(1, tit$sibsp), tit$age) stopifnot(coef(fit8.mat) == coef(lm8)) # coef names will differ fit8.form <- linmod(age~sibsp, data=tit) lm8.form <- lm(age~sibsp, data=tit) check.lm(fit8.form, lm8.form, newdata=tit[3:5,]) # drop=FALSE so response is a data frame fit1a.mat <- linmod(trees[,1:2], trees[, 3, drop=FALSE]) print(fit1a.mat) print(summary(fit1.mat)) plotres(fit1a.mat) # plot caption shows response name "Volume" cat("==test model building with different non numeric args\n") library(earth) # for etitanic data data(etitanic) tit <- etitanic[seq(1, nrow(etitanic), by=60), ] # small set of data for tests (18 cases) tit$survived <- tit$survived != 0 # convert to logical rownames(tit) <- paste("pas", 1:nrow(tit), sep="") cat(paste(colnames(tit), "=", sapply(tit, class), sep="", collapse=", "), "\n") lm9 <- lm(survived~., data=tit) fit9.form <- linmod(survived~., data=tit) check.lm(fit9.form, lm9, newdata=tit[3:5,]) options(warn=2) # treat warnings as errors # factors in x expect.err(try(linmod(tit[,c(1,3,4,5,6)], tit[,"survived"])), "NAs introduced by coercion") options(warn=1) # print warnings as they occur expect.err(try(linmod(tit[,c(1,3,4,5,6)], tit[,"survived"])), "NA/NaN/Inf in foreign function call (arg 1)") options(warn=2) # treat warnings as errors expect.err(try(lm(pclass~., data=tit)), "using type = \"numeric\" with a factor response will be ignored") # minimal version expect.err(try(linmod(pclass~., data=tit)), "(converted from warning) NAs introduced by coercion") expect.err(try(linmod(tit$pclass, tit$survived)), "(converted from warning) NAs introduced by coercion") # # production version # expect.err(try(linmod(pclass~., data=tit)), "'y' is not numeric or logical") options(warn=1) lm10 <- lm(pclass~., data=tit) # will give warnings fit10.form <- linmod(as.numeric(pclass)~., data=tit) stopifnot(coef(fit10.form) == coef(lm10)) stopifnot(names(coef(fit10.form)) == names(coef(lm10))) # check.lm(fit10.form, lm10) # fails because lm10 fitted is all NA # production version: (minimal version just gives warnings and builds lousy model) # expect.err(try(linmod(pclass~., data=tit)), "'y' is not numeric or logical") # expect.err(try(linmod(tit[,-1], tit[,1])), "'y' is not numeric or logical") # expect.err(try(linmod(1:10, paste(1:10))), "'y' is not numeric or logical") fit10a.form <- linmod(survived~pclass, data=tit) lm10a <- lm(survived~pclass, data=tit) check.lm(fit10a.form, lm10a, newdata=tit[3:5,]) expect.err(try(linmod(paste(1:10), 1:10)), "requires numeric/complex matrix/vector arguments") lm11 <- lm(as.numeric(pclass)~., data=tit) fit11.form <- linmod(as.numeric(pclass)~., data=tit) check.lm(fit11.form, lm11, newdata=tit[3:5,]) cat("==data.frame with strings\n") df.with.string <- data.frame(1:5, c(1,2,-1,4,5), c("a", "b", "a", "a", "b"), stringsAsFactors=FALSE) colnames(df.with.string) <- c("num1", "num2", "string") fit30.form <- linmod(num1~num2, df.with.string) lm30 <- lm(num1~num2, df.with.string) check.lm(fit30.form, lm30, check.newdata=FALSE) fit31.form <- linmod(num1~., df.with.string) lm31 <- lm(num1~., df.with.string) check.lm(fit31.form, lm31, check.newdata=FALSE) expect.err(try(linmod(string~., df.with.string)), "non-numeric argument to binary operator") # production version # expect.err(try(linmod(string~., df.with.string)), "'y' is not numeric or logical") vec <- c(1,2,3,4,3) options(warn=2) # treat warnings as errors expect.err(try(linmod(df.with.string, vec)), "NAs introduced by coercion") options(warn=1) # minimal version expect.err(try(linmod(df.with.string, vec)), "NA/NaN/Inf in foreign function call (arg 1)") # production version # expect.err(try(linmod(df.with.string, vec)), "NA in 'x'") options(warn=2) # treat warnings as errors expect.err(try(linmod(df.with.string, vec)), "NAs introduced by coercion") options(warn=1) # minimal version expect.err(try(linmod(df.with.string, vec)), "NA/NaN/Inf in foreign function call (arg 1)") # production version # expect.err(try(linmod(df.with.string, vec)), "NA in 'x'") cat("==more variables than cases\n") set.seed(1) x2 <- matrix(rnorm(6), nrow=2) y2 <- c(1,2) # production version # expect.err(try(linmod(y2~x2)), "more variables than cases") # minimal version expect.err(try(linmod(y2~x2)), "'size' cannot exceed nrow(x) = 2") x3 <- matrix(1:10, ncol=2) y3 <- c(1,2,9,4,5) # production version will give a better error message expect.err(try(linmod(y3~x3)), "singular matrix 'a' in 'solve'") cat("==nrow(x) does not match length(y)\n") # note that the production version gives better error messages x4 <- matrix(1:10, ncol=2) y4 <- c(1,2,9,4) expect.err(try(linmod(x4, y4)), "singular matrix 'a' in 'solve'") x5 <- matrix(1:10, ncol=2) y5 <- c(1,2,9,4,5,9) expect.err(try(linmod(x5, y5)), "singular matrix 'a' in 'solve'") cat("==y has multiple columns\n") vec <- c(1,2,3,4,3) y2 <- cbind(c(1,2,3,4,9), vec^2) expect.err(try(linmod(vec, y2)), "'qr' and 'y' must have the same number of rows") # following does not issue any error message, it should # expect.err(try(linmod(y2~vec)), "error message") ### Model 3: production version of linmod is tested in test.linmod.R source("test.epilog.R") plotmo/inst/slowtests/test.degree.R0000644000176200001440000001057013727235376017166 0ustar liggesusers# test.pre.R: test the degree1 and degree2 and related args source("test.prolog.R") library(earth) library(plotmo) # test character degree1 and degree2 (added in plotmo version 1.3-0) data(ozone1) a80 <- earth(O3~., data=ozone1, degree=2) plotmo(a80, degree1="i", degree2="t", caption='degree1="i", degree2="t"') plotmo(a80, degree1="^temp$", degree2="^dpg$", caption='degree1="^temp$", degree2="^dpg$"') # Expect Warning: "nonesuch1" in degree1 does not regex-match any variables, ditto for degree2 plotmo(a80, degree1=c("temp", "nonesuch1"), degree2="vis", caption='degree1=c("temp", "nonesuch1"), degree2="vis")') # Expect above warnings and also Warning: nothing to plot plotmo(a80, degree1="nonesuch1", degree2="nonesuch2") # tests for plotmo version 3.3.7 (degree1 and degree2 handling changed) data(etitanic) a81 <- earth(survived~., data=etitanic, degree=2) options(warn=1) # print warnings as they occur plotmo(a81) # degree1 tests par(mfrow=c(3,3), mar=c(1,2.5,2,1), oma=c(0,0,4,0)) plotmo(a81, do.par=FALSE, degree1="pclass", degree2=0, main='degree1="pclass"', caption="test degree1 with strings") options(warn=2) # treat warnings as errors expect.err(try(plotmo(a81, do.par=FALSE, degree1="survived", degree2=0)), '"survived" in degree1 does not regex-match any names') options(warn=1) # print warnings as they occur plotmo(a81, do.par=FALSE, degree1="sibsp", degree2=0, main='degree1="sibsp"') # parch does not appear in the standard degree1 plotmo plots, but we can still specify it explictly plotmo(a81, do.par=FALSE, degree1="parch", degree2=0, trace=0, main='degree1="parch"') plotmo(a81, do.par=FALSE, degree1=c("sibsp", "pclass"), degree2=0, main='degree1=c("sibsp", "pclass")') par(org.par) # degree2 tests par(mfrow=c(3,3), mar=c(1,2.5,2,1), oma=c(0,0,4,0)) plotmo(a81, do.par=FALSE, degree1=0, degree2="pclass", main='degree2="pclass"', caption="test degree2 with two strings") plotmo(a81, do.par=FALSE, degree1=0, degree2=c("age", "se"), persp.theta=-35, main='degree2=c("age", "se")\npersp.theta=-35') plotmo(a81, do.par=FALSE, degree1=0, degree2="ag", main='degree2="ag"') plotmo(a81, do.par=FALSE, degree1=0, degree2=c("sex", "sibsp"), main='degree2=c("sex", "sibsp"') plotmo(a81, do.par=FALSE, degree1=0, degree2=c("sibsp", "sex"), main='degree2=c("sibsp", "sex")') options(warn=2) # treat warnings as errors expect.err(try(plotmo(a81, do.par=FALSE, degree1=0, degree2=c("pclass", "nonesuch"))), "\"nonesuch\" in degree2 does not regex-match any names") expect.err(try(plotmo(a81, do.par=FALSE, degree1=0, degree2=c("nonesuch1", "nonesuch2"))), "\"nonesuch1\" in degree2 does not regex-match any names") expect.err(try(plotmo(a81, do.par=FALSE, degree1=0, degree2=c("nonesuch", "pclass"))), "\"nonesuch\" in degree2 does not regex-match any names") options(warn=1) # print warnings as they occur par(org.par) par(mfrow=c(2,2), mar=c(1,2.5,2,1), oma=c(0,0,4,0)) # check that order of strings in two string degree2 is observed cat('\n\ndegree2=c("age", "se"):\n') plotmo(a81, do.par=FALSE, degree1=0, degree2=c("age", "se"), main='degree2=c("age", "se")') cat('\n\ndegree2=c("se", "age"):\n') plotmo(a81, do.par=FALSE, degree1=0, degree2=c("se", "age"), main='degree2=c("se", "age")') # check handling of bad strings in two string degree2 cat('\n\ndegree2=c("nonesuch", "age"):\n') try(plotmo(a81, do.par=FALSE, degree1=0, degree2=c("nonesuch", "age"), main='degree2=c("nonesuch", "age")')) cat('\n\ndegree2=c("age", "nonesuch"):\n') try(plotmo(a81, do.par=FALSE, degree1=0, degree2=c("age", "nonesuch"), main='degree2=c("age", "nonesuch")')) cat('\n\ndegree2=c("nevermore", "nonesuch"):\n') try(plotmo(a81, do.par=FALSE, degree1=0, degree2=c("nevermore", "nonesuch"), main='degree2=c("nevermore", "nonesuch")')) # follow should still plot the degree1 plot even though degree2 spec is wrong cat('\n\ndegree1=1, degree2=c("nevermore", "nonesuch"):\n') try(plotmo(a81, do.par=FALSE, degree1=1, degree2=c("nevermore", "nonesuch"), main='degree1=1\ndegree2=c("nevermore", "nonesuch")')) # expect warning: both elements of degree2 are the same cat('\n\ndegree2=c("sex", "sex"):\n') try(plotmo(a81, do.par=FALSE, degree1=0, degree2=c("sex", "sex"), main='degree1=1\ndegree2=c("sex", "sex")')) par(org.par) source("test.epilog.R") plotmo/inst/slowtests/test.glmnet.bat0000755000176200001440000000147214655214117017561 0ustar liggesusers@rem test.glmnet.bat: glmnet tests for plotmo and plotres @echo test.glmnet.bat @"C:\PROGRA~1\R\R-4.4.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.dots.Rout.save0000644000176200001440000016256614563606220020373 0ustar liggesusers> # test.dots.R > > source("test.prolog.R") > > cat0("=== test dotindex\n") === test dotindex > > test.dotindex <- function(expected, ARGNAME, ..., EX=FALSE) + { + dotindex <- plotmo:::dotindex(ARGNAME=ARGNAME, EX=EX, ...) + stopifnot(all.equal(dotindex, expected)) + } > test.dotindex(NA, "x") # empty dots > test.dotindex(NA, "x", a=10, b=20) > test.dotindex(1, "a", a=10, b=20) > test.dotindex(2, "b", a=10, b=20) > test.dotindex(1, "a1", a=10, b=20) > test.dotindex(NA, "a", a1=10, a2=20) > expect.err(try(test.dotindex(1, nonesuch, a=10, a=20)), "object 'nonesuch' not found") Error : object 'nonesuch' not found Got expected error from try(test.dotindex(1, nonesuch, a = 10, a = 20)) > expect.err(try(test.dotindex(1, "a1", a=10, a=20)), "argument 'a' for test.dotindex() is duplicated") Error : argument 'a' for test.dotindex() is duplicated Got expected error from try(test.dotindex(1, "a1", a = 10, a = 20)) > expect.err(try(test.dotindex(1, "aa1", a=10, aa=20)), "arguments 'a' and 'aa' both match 'aa1' in test.dotindex") Error : arguments 'a' and 'aa' both match 'aa1' in test.dotindex Got expected error from try(test.dotindex(1, "aa1", a = 10, aa = 20)) > stopifnot(is.na(plotmo:::dotindex("a", EX=1, a1=10, a2=20))) > stopifnot(plotmo:::dotindex("a2", EX=1, a1=10, a2=20) == 2) > > # multiple argnames > test.dotindex(NA, c("a", "b")) # empty dots > test.dotindex(1, c("a", "b"), a=2, c=3) > test.dotindex(1, c("a", "b"), a=5, b=6) > test.dotindex(2, c("a", "b"), x=1, a=5, b=6) > test.dotindex(3, c("b,a"), x=1, a=5, b=6) > test.dotindex(1, c("a b"), b=3, c=4) > test.dotindex(2, c(" a b "), c=3, b=4) > test.dotindex(NA, c("a", "b"), c=3) > stopifnot(plotmo:::dotindex(c("x", "a1"), EX=1, a1=10, a2=20) == 1) > > test.dota <- function(expected, ARGNAME, ..., DEF=NA, EX=FALSE) + { + if(is.na(DEF)) + dot <- plotmo:::dota(ARGNAME, EX=EX, ...) + else + dot <- plotmo:::dota(ARGNAME, EX=EX, DEF=DEF, ...) + stopifnot(all.equal(dot, expected)) + } > cat0("=== test dot\n") === test dot > test.dota(NA, "x") # empty dots > test.dota(NA, "x", a=10, b=20) > test.dota(10, "a", a=10, b=20) > test.dota(20, "b", a=10, b=20) > test.dota(99, DEF=99, "nonesuch", a=10, b=20) > test.dota(NA, "a", a1=10, a2=20) > expect.err(try(test.dota(1, "a1", a=10, a=20)), "argument 'a' for test.dota() is duplicated") Error : argument 'a' for test.dota() is duplicated Got expected error from try(test.dota(1, "a1", a = 10, a = 20)) > expect.err(try(test.dota(1, 99, a=10, a=20)), "is.character(argname) is not TRUE") Error in process.argname(ARGNAME) : is.character(argname) is not TRUE Got expected error from try(test.dota(1, 99, a = 10, a = 20)) > expect.err(try(test.dota(1, test.dota, a=10, a=20)), "is.character(argname) is not TRUE") Error in process.argname(ARGNAME) : is.character(argname) is not TRUE Got expected error from try(test.dota(1, test.dota, a = 10, a = 20)) > expect.err(try(test.dota(1, "", a=10, a=20)), "empty string in ARGNAME") Error : empty string in ARGNAME Got expected error from try(test.dota(1, "", a = 10, a = 20)) > expect.err(try(test.dota(1, "x^x", a=10, a=20)), "illegal character \"^\" in ARGNAME") Error : illegal character "^" in ARGNAME = "x^x" Got expected error from try(test.dota(1, "x^x", a = 10, a = 20)) > > test.dota(10, "abc", EX=T, abc=10) > test.dota(NA, "a", EX=T, a1=10, a2=20) > expect.err(try(test.dota(1, "a1", a1=10, a1=20)), "argument 'a1' for test.dota() is duplicated") Error : argument 'a1' for test.dota() is duplicated Got expected error from try(test.dota(1, "a1", a1 = 10, a1 = 20)) > > stopifnot(is.na(plotmo:::dota("a", EX=1, a1=1, a2=2))) > stopifnot(plotmo:::dota("a2", EX=1, a1=10, a2=20, a3=30) == 20) > > foo <- function(func, x) func(x) > foo(mean, 33) [1] 33 > foo(function(...) plotmo:::dota("x", ...), 33) [1] NA > foo(function(...) plotmo:::dota("x99", ...), 33) [1] NA > foo(function(...) { plotmo:::dota("nonesuch", ...) }, 33) [1] NA > > test.dota(1, "a", EX=T, a=1) > test.dota(2, "b", EX=T, a=1, b=2, c=3) > test.dota(NA, "x", EX=T, a=1, b=2, c=3) > test.dota(2, "a", EX=T, ab=1, a=2) > test.dota(2, "a", EX=T, aa=1, a=2) > test.dota(NA, "a", EX=T, aa=1, ab=2) > expect.err(try(test.dota(2, "a", EX=T, aa=1, a=2, a=3)), "argument 'a' for test.dota() is duplicated") Error : argument 'a' for test.dota() is duplicated Got expected error from try(test.dota(2, "a", EX = T, aa = 1, a = 2, a = 3)) > > expect.err(try(test.dota(2, "a", EX=T, a=none.such)), "cannot evaluate 'a'") Error : object 'none.such' not found Error : cannot evaluate 'a' Got expected error from try(test.dota(2, "a", EX = T, a = none.such)) > > # multiple argnames > test.dota(2, c("a", "b"), a=2, c=3) > test.dota(5, c("a", "b"), a=5, b=6) > test.dota(5, c("a", "b"), x=1, a=5, b=6) > test.dota(3, c("a", "b"), b=3, c=4) > test.dota(4, c("a", "b"), c=3, b=4) > test.dota(NA, c("a", "b"), c=3) > expect.err(try(test.dota(1, c("b", "aa1"), a=10, aa=20)), "arguments 'a' and 'aa' both match 'aa1' in test.dota") Error : arguments 'a' and 'aa' both match 'aa1' in test.dota Got expected error from try(test.dota(1, c("b", "aa1"), a = 10, aa = 20)) > expect.err(try(test.dota(1, c("x", ""), a=10, b=20)), "empty string in ARGNAME") Error : empty string in ARGNAME Got expected error from try(test.dota(1, c("x", ""), a = 10, b = 20)) > stopifnot(plotmo:::dota(c("x", "a2", "y"), EX=1, a1=10, a2=20, a3=30) == 20) > > test.dota(NA, c("a", "b"), aa=2, cc=3, EX=T) > test.dota(2, c("aa", "b"), aa=2, cc=3, EX=T) > test.dota(3, c("bb", "b"), bb=3, cc=4, EX=T) > test.dota(NA, c("a", "b"), c=3, EX=T) > > foo.x <- function(...) { plotmo:::dota("x", ..., DEF="default", EX=FALSE) } > stopifnot(foo.x(x=3) == 3) > stopifnot(foo.x(y=3) == "default") > > foo2 <- function(funcarg, ...) funcarg(...) > stopifnot(is.na(foo2(function(...) plotmo:::dota("x", ...), 3))) # 3 is unnamed > stopifnot(foo2(function(...) plotmo:::dota("x", EX=0, ...), x=3) == 3) > stopifnot(foo2(function(...) plotmo:::dota("x99", EX=0, ...), x=3) == 3) > stopifnot(foo2(function(...) { plotmo:::dota("x", DEF="default", EX=FALSE, ...) }, x=3) == 3) > stopifnot(foo2(function(...) { plotmo:::dota("y", DEF="default", EX=FALSE, ...) }, x=3) == "default") > # expect.err(try(foo2(function(...) { plotmo:::dota("y", DEF="default", EX=FALSE, ...) }, 3)), "unnamed arguments in ... are not allowed for funcarg()") > > stopifnot(foo2(foo.x, x=3) == 3) > stopifnot(foo2(foo.x, y=3) == "default") > > test.is.dot <- function(expected, ARGNAME, ...) + { + present <- plotmo:::is.dot(ARGNAME, ...) + stopifnot(all.equal(present, expected)) + } > cat0("=== test is.dot\n") === test is.dot > test.is.dot(FALSE, "x") # empty dots > test.is.dot(FALSE, "x", EX=0, a=10, b=20) > test.is.dot(TRUE, "a", EX=0, a=10, b=20) > test.is.dot(TRUE, "b", EX=0, a=10, b=20) > test.is.dot(TRUE, "a1", EX=0, a=10, b=20) > test.is.dot(FALSE, "a", EX=0, a1=10, a2=20) > expect.err(try(test.is.dot(TRUE, "a1", EX=0, a=10, a=20)), "argument 'a' for test.is.dot() is duplicated") Error : argument 'a' for test.is.dot() is duplicated Got expected error from try(test.is.dot(TRUE, "a1", EX = 0, a = 10, a = 20)) > expect.err(try(test.is.dot(TRUE, "a", EX=0, a=10, a=20)), "argument 'a' for test.is.dot() is duplicated") Error : argument 'a' for test.is.dot() is duplicated Got expected error from try(test.is.dot(TRUE, "a", EX = 0, a = 10, a = 20)) > stopifnot(plotmo:::is.dot("a", EX=1, a1=10, a2=20, a3=30) == FALSE) > stopifnot(plotmo:::is.dot("x", EX=1, a1=10, a2=20, a3=30) == FALSE) > stopifnot(plotmo:::is.dot("a3", EX=1, a1=10, a2=20, a3=30) == TRUE) > > # multiple argnames > test.is.dot(TRUE, EX=0, c("a1", "b1"), a=2, c=3) > test.is.dot(TRUE, EX=0, c("a1", "b1"), b=3, c=4) > test.is.dot(TRUE, EX=0, c("a1", "b1"), c=3, b=4) > test.is.dot(FALSE, EX=0, c("a1", "b1"), c=3) > expect.err(try(test.is.dot(FALSE, c("aa1", "b"), EX=0, a=10, aa=20)), "arguments 'a' and 'aa' both match 'aa1' in test.is.dot") Error : arguments 'a' and 'aa' both match 'aa1' in test.is.dot Got expected error from try(test.is.dot(FALSE, c("aa1", "b"), EX = 0, a = 10, aa = 20)) > stopifnot(plotmo:::is.dot(c("x", "a", "y"), EX=1, a1=10, a2=20, a3=30) == FALSE) > stopifnot(plotmo:::is.dot(c("x", "a2", "y"), EX=1, a1=10, a2=20, a3=30) == TRUE) > > cat0("=== test expand.drop\n") === test expand.drop > > # nchar is used an example func, it has formals "x", "type", "allowNA" > > stopifnot(is.null(plotmo:::expand.drop(NULL, prefix="prefix.", func=nchar))) > > stopifnot(plotmo:::expand.drop("a", prefix="prefix.", func=nchar) == ">PREFIX|>EXPLICIT|^a") > > stopifnot(plotmo:::expand.drop("a", prefix="prefix.", func=nchar, include.standard.prefixes=TRUE) == ">STANDARDPREFIXES|^force\\.|^def\\.|^drop\\.|>PREFIX|^prefix\\.|>EXPLICIT|^a") > > stopifnot(plotmo:::expand.drop("FORMALS", prefix="prefix.", func=base::nchar) == ">FORMALS|^x|^type|^allowNA|^keepNA|>PREFIX|>EXPLICIT") > > stopifnot(plotmo:::expand.drop("FORMALS", prefix="prefix.", func=base::nchar, include.standard.prefixes=TRUE) == ">FORMALS|^x|^type|^allowNA|^keepNA|>STANDARDPREFIXES|^force\\.|^def\\.|^drop\\.|>PREFIX|^prefix\\.|>EXPLICIT") > > expect.err(try(plotmo:::expand.drop("FORMALS", prefix="prefix.", func=NULL)), "\"FORMALS\" specified in DROP, but FUNC is NULL") Error : "FORMALS" specified in DROP, but FUNC is NULL Got expected error from try(plotmo:::expand.drop("FORMALS", prefix = "prefix.", func = NULL)) > > expect.err(try(plotmo:::expand.drop("FORMALS", prefix="prefix.", func=base::c)), "\"FORMALS\" specified but formals(FUNC) returned no formal arguments") Error : "FORMALS" specified but formals(FUNC) returned no formal arguments Got expected error from try(plotmo:::expand.drop("FORMALS", prefix = "prefix.", func = base::c)) > > foo99 <- function(...) NULL > expect.err(try(plotmo:::expand.drop("FORMALS", prefix="prefix.", func=foo99)), "\"FORMALS\" specified but formals(FUNC) returned only \"...\"") Error : "FORMALS" specified but formals(FUNC) returned only "..." Got expected error from try(plotmo:::expand.drop("FORMALS", prefix = "prefix.", func = foo99)) > > stopifnot(plotmo:::expand.drop("a,FORMALS", prefix="prefix.", func=base::nchar) == ">FORMALS|^x|^type|^allowNA|^keepNA|>PREFIX|>EXPLICIT|^a") > > stopifnot(plotmo:::expand.drop("a,FORMALS", prefix="prefix.", func=base::nchar, include.standard.prefixes=TRUE) == ">FORMALS|^x|^type|^allowNA|^keepNA|>STANDARDPREFIXES|^force\\.|^def\\.|^drop\\.|>PREFIX|^prefix\\.|>EXPLICIT|^a") > > expect.err(try(plotmo:::expand.drop("", prefix="prefix.", func=base::nchar)), "DROP is an empty string") Error : DROP is an empty string Got expected error from try(plotmo:::expand.drop("", prefix = "prefix.", func = base::nchar)) > > stopifnot(plotmo:::expand.drop("a", prefix="lines.", func=base::nchar) == ">PREFIX|>EXPLICIT|^a") > > stopifnot(plotmo:::expand.drop("a", "lines.a", prefix="lines.", func=base::nchar, include.standard.prefixes=TRUE) == ">STANDARDPREFIXES|^force\\.|^def\\.|^drop\\.|>PREFIX|^lines\\.|>EXPLICIT|^a") > > stopifnot(plotmo:::expand.drop("a*", prefix="lines.", func=base::nchar) == ">PREFIX|>EXPLICIT|^a.*") > > stopifnot(plotmo:::expand.drop("a.*", prefix="lines.", func=base::nchar) == ">PREFIX|>EXPLICIT|^a\\..*") > > stopifnot(plotmo:::expand.drop("a$", prefix="lines.", func=base::nchar) == ">PREFIX|>EXPLICIT|^a$") > > stopifnot(plotmo:::expand.drop("a$,b*,c*$", prefix="lines.", func=base::nchar) == ">PREFIX|>EXPLICIT|^a$|^b.*|^c.*$") > > stopifnot(plotmo:::expand.drop(c("a", "b,c", " d e$ f ", "g h$, i"), prefix="lines.", func=base::nchar) == + ">PREFIX|>EXPLICIT|^a|^b|^c|^d|^e$|^f|^g|^h$|^i") > > stopifnot(plotmo:::expand.drop("PLOT.ARGS", prefix="lines.", func=base::nchar) == + ">PREFIX|>EXPLICIT|>PLOT_ARGS|^add$|^adj$|^bty$|^cex$|^cex\\.axis$|^cex\\.lab$|^cex\\.main$|^cex\\.sub$|^col$|^col\\.axis$|^col\\.lab$|^col\\.main$|^col\\.sub$|^crt$|^family$|^font$|^font$|^font\\.axis$|^font\\.lab$|^font\\.main$|^font\\.sub$|^lend$|^ljoin$|^lmitre$|^lty$|^lwd$|^main$|^pch$|^srt$|^xaxp$|^xaxs$|^xaxt$|^xlab$|^xlim$|^xlog$|^xpd$|^yaxp$|^yaxs$|^yaxt$|^ylab$|^ylim$|^ylog$") > > stopifnot(plotmo:::expand.drop("abc,PLOT.ARGS", prefix="lines.", func=base::nchar) == + ">PREFIX|>EXPLICIT|^abc|>PLOT_ARGS|^add$|^adj$|^bty$|^cex$|^cex\\.axis$|^cex\\.lab$|^cex\\.main$|^cex\\.sub$|^col$|^col\\.axis$|^col\\.lab$|^col\\.main$|^col\\.sub$|^crt$|^family$|^font$|^font$|^font\\.axis$|^font\\.lab$|^font\\.main$|^font\\.sub$|^lend$|^ljoin$|^lmitre$|^lty$|^lwd$|^main$|^pch$|^srt$|^xaxp$|^xaxs$|^xaxt$|^xlab$|^xlim$|^xlog$|^xpd$|^yaxp$|^yaxs$|^yaxt$|^ylab$|^ylim$|^ylog$") > > stopifnot(plotmo:::expand.drop("abc,FORMALS,PLOT.ARGS", prefix="lines.", func=base::nchar) == + ">FORMALS|^x|^type|^allowNA|^keepNA|>PREFIX|>EXPLICIT|^abc|>PLOT_ARGS|^add$|^adj$|^bty$|^cex$|^cex\\.axis$|^cex\\.lab$|^cex\\.main$|^cex\\.sub$|^col$|^col\\.axis$|^col\\.lab$|^col\\.main$|^col\\.sub$|^crt$|^family$|^font$|^font$|^font\\.axis$|^font\\.lab$|^font\\.main$|^font\\.sub$|^lend$|^ljoin$|^lmitre$|^lty$|^lwd$|^main$|^pch$|^srt$|^xaxp$|^xaxs$|^xaxt$|^xlab$|^xlim$|^xlog$|^xpd$|^yaxp$|^yaxs$|^yaxt$|^ylab$|^ylim$|^ylog$") > > stopifnot(plotmo:::expand.drop("abc,FORMALS,PAR.ARGS", prefix="lines.", func=base::nchar) == + ">FORMALS|^x|^type|^allowNA|^keepNA|>PREFIX|>EXPLICIT|^abc|>PAR_ARGS|^adj$|^ann$|^ask$|^bg$|^bty$|^cex$|^cex\\.axis$|^cex\\.lab$|^cex\\.main$|^cex\\.sub$|^col\\.axis$|^col\\.lab$|^col\\.main$|^col\\.sub$|^crt$|^err$|^family$|^fg$|^fig$|^fin$|^font$|^font\\.axis$|^font\\.lab$|^font\\.main$|^font\\.sub$|^lab$|^las$|^lend$|^lheight$|^ljoin$|^lmitre$|^lty$|^mai$|^mar$|^mex$|^mfcol$|^mfg$|^mfrow$|^mgp$|^mkh$|^new$|^oma$|^omd$|^omi$|^pch$|^pin$|^plt$|^ps$|^pty$|^srt$|^tck$|^tcl$|^usr$|^xaxp$|^xaxs$|^xaxt$|^xlog$|^xpd$|^yaxp$|^yaxs$|^yaxt$|^ylbias$|^ylog$") > > stopifnot(plotmo:::expand.drop("abc,FORMALS,PLOTMO.ARGS", prefix="lines.", func=base::nchar) == + ">FORMALS|^x|^type|^allowNA|^keepNA|>PREFIX|>EXPLICIT|^abc|>PLOTMO_ARGS|^caption\\.|^cex\\.|^col\\.|^contour\\.|^cum\\.|^degree1\\.|^degree2\\.|^density\\.|^filled\\.contour\\.|^font\\.|^func\\.|^grid\\.|^heatmap\\.|^image\\.|^jitter\\.|^legend\\.|^label\\.|^level\\.|^line\\.|^lines\\.|^lty\\.|^lty\\.|^lwd\\.|^main\\.|^mtext\\.|^nresiduals|^par\\.|^pch\\.|^persp\\.|^plot\\.|^plotmath\\.|^prednames\\.|^qq\\.|^qqline\\.|^pt\\.|^response\\.|^rug\\.|^smooth\\.|^text\\.|^title\\.|^vfont\\.") > > test.deprefix <- function(expected, ..., FNAME="test.deprefix", KEEP=NULL) + { + args <- plotmo:::deprefix(..., FNAME=FNAME, KEEP=KEEP, CALLARGS="") + # can't use all.equal because it complains about names + # cat("args:\n") + # print(args) + # cat("expected:\n") + # print(expected) + stopifnot(length(args) == length(expected)) + for(i in seq_len(length(expected))) { + stopifnot(names(args)[i] == names(expected)[i]) + stopifnot(args[[i]] == expected[[i]]) + } + } > cat0("=== test deprefix\n") === test deprefix > > test.deprefix( + expected=list(a=1, b=2), DROP="*", + PREFIX="predict.", def.a=1, predict.b=2, c=3) > > test.deprefix(TRACE=2, + expected=list(b="predict.b", d="def.d", c="predict.c", e="predict.e"), + PREFIX="predict.", DROP="*", + a="a", b="b", c="c", w1.xlab="xlab", + def.b="def.b", def.d="def.d", + predict.b="predict.b", predict.c="predict.c", predict.e="predict.e") TRACE higher.caller.to.deprefix called higher.caller.to.deprefix(test.deprefix, FNAME="test.deprefix", a="a", b="b", c="c", w1.xlab="xlab", def.b="def.b", def.d="def.d", predict.b="predict.b", predict.c="predict.c", predict.e="predict.e") PREFIX predict. DROP .* KEEP ^force.|^def.|^predict. input dotnames a b c w1.xlab def.b def.d predict.b predict.c predict.e after DROP and KEEP def.b def.d predict.b predict.c predict.e return dotnames b d c e > > test.deprefix(TRACE=2, + expected=list(b="predict.b", d="def.d", a="a", c="predict.c", e="predict.e"), + KEEP=NULL, PREFIX="predict.", DROP="w1.", + a="a", b="b", c="c", w1.xlab="xlab", + def.b="def.b", def.d="def.d", + predict.b="predict.b", predict.c="predict.c", predict.e="predict.e") TRACE higher.caller.to.deprefix called higher.caller.to.deprefix(test.deprefix, FNAME="test.deprefix", a="a", b="b", c="c", w1.xlab="xlab", def.b="def.b", def.d="def.d", predict.b="predict.b", predict.c="predict.c", predict.e="predict.e") PREFIX predict. DROP >PREFIX >EXPLICIT|^w1\. KEEP ^force.|^def.|^predict. input dotnames a b c w1.xlab def.b def.d predict.b predict.c predict.e after DROP and KEEP a b c def.b def.d predict.b predict.c predict.e return dotnames b d a c e > > test.deprefix( + expected=list(a="predict.a"), + KEEP=NULL, PREFIX="predict.", DROP="w1.", + a="plain.a", predict.a="predict.a") > > test.deprefix(expected=list(a="aa1"), + KEEP=NULL, PREFIX="predict.", a="aa1") > > test.deprefix(expected=list(a="aa2"), + KEEP=NULL, PREFIX="predict.", def.a="aa2") > > test.deprefix(expected=list(a="aa3", b="bb3"), + KEEP=NULL, PREFIX="predict.", def.a="aa3", b="bb3") > > test.deprefix(expected=list(10, 20), TRACE=2, + KEEP=NULL, DROP="w1.,persp.,xlab.", + PREFIX="predict.", + force.anon2=20, force.anon1=10) TRACE higher.caller.to.deprefix called higher.caller.to.deprefix(test.deprefix, FNAME="test.deprefix", force.anon2=20, force.anon1=10) PREFIX predict. DROP >PREFIX >EXPLICIT|^w1\.|^persp\.|^xlab\. KEEP ^force.|^def.|^predict. input dotnames force.anon2 force.anon1 after DROP and KEEP force.anon2 force.anon1 return dotnames anon1 anon2 > > test.deprefix(expected=list(10, 20, a=3), TRACE=2, + KEEP=NULL, DROP="w1.,persp.,xlab.", + PREFIX="predict.", + force.anon2=20, force.anon1=10, + a=3) TRACE higher.caller.to.deprefix called higher.caller.to.deprefix(test.deprefix, FNAME="test.deprefix", force.anon2=20, force.anon1=10, a=3) PREFIX predict. DROP >PREFIX >EXPLICIT|^w1\.|^persp\.|^xlab\. KEEP ^force.|^def.|^predict. input dotnames force.anon2 force.anon1 a after DROP and KEEP force.anon2 force.anon1 a return dotnames anon1 anon2 a > > expect.err(try(test.deprefix(expected=list(10, 20, a=4), + KEEP=NULL, DROP="w1.,persp.,xlab.", + PREFIX="predict.", + force.anon=10, force.anon=20, + a=3, predict.a=4)), + "argument 'force.anon' for test.deprefix() is duplicated") Error : argument 'force.anon' for test.deprefix() is duplicated Got expected error from try(test.deprefix(expected = list(10, 20, a = 4), KEEP = NULL, DROP = "w1.,persp.,xlab.", PREFIX = "predict.", force.anon = 10, force.anon = 20, a = 3, predict.a = 4)) > > expect.err(try(test.deprefix(expected=list(10, 20, a=4), + KEEP=NULL, DROP="w1.,persp.,xlab.", + PREFIX="predict.", FNAME="foobar", + force.anon=10, force.anon=20, + a=3, predict.a=4)), + "argument 'force.anon' for foobar() is duplicated") Error : argument 'force.anon' for foobar() is duplicated Got expected error from try(test.deprefix(expected = list(10, 20, a = 4), KEEP = NULL, DROP = "w1.,persp.,xlab.", PREFIX = "predict.", FNAME = "foobar", force.anon = 10, force.anon = 20, a = 3, predict.a = 4)) > > test.deprefix(expected=list(10, 20, a=4), + KEEP=NULL, DROP="w1.,persp.,xlab.", + PREFIX="predict.", + force.anon1=10, force.anon2=20, + a=3, predict.a=4) > > test.deprefix(expected=list(10, 20, b=3, a=4), + KEEP=NULL, DROP="w1.,persp.,xlab.", + PREFIX="predict.", + force.anon1=10, force.anon2=20, def.b=3, + a=3, predict.a=4) > > test.deprefix(expected=list(10, 20, b=5, a=3), + KEEP=NULL, DROP="w1.,persp.,xlab.", + PREFIX="predict.", + force.anon1=10, force.anon2=20, def.b=3, + a=3, predict.b=5) > > test.deprefix(expected=list(10, 20, b=6, a=3), + KEEP=NULL, DROP="w1.,persp.,xlab.", + PREFIX="predict.", + force.anon1=10, force.anon2=20, def.b=3, + a=3, b=6) > > expect.err(try(test.deprefix(expected=NULL, KEEP=NULL, PREFIX="predict.", DROP="w1\\.")), "illegal character \"\\\" in DROP = \"w1\\.\"") Error : illegal character "\" in DROP = "w1\." Got expected error from try(test.deprefix(expected = NULL, KEEP = NULL, PREFIX = "predict.", DROP = "w1\\.")) > > test.deprefix(expected=list(b="predict.b", d="def.d", a="a", c="predict.c", w1.xl="xlab2", e="predict.e"), + PREFIX="predict.", DROP="w1.xlab$", + a="a", b="b", c="c", + w1.xlab="xlab1", # will be dropped (exact match) + w1.xl="xlab2", # will be kept (not an exact match) + def.b="def.b", def.d="def.d", + predict.b="predict.b", predict.c="predict.c", predict.e="predict.e") > > # expect.err(try(plotmo:::deprefix(FNAME="test.deprefix", PREFIX="predict.", UPPER.CASE123=99, > # def.a=1, predict.b=2, c=3)), > # "uppercase argument names like \"UPPER.CASE123\" are not allowed for test.deprefix()") > > test.expand.dotnames <- function(expected, PREFIX, FUNC=NULL, + FNAME="test.expand.dotnames", FORMALS=NULL, ...) + { + dots <- as.list(match.call(expand.dots=FALSE)$...) + args <- plotmo:::expand.dotnames(dots, PREFIX, FUNC, FNAME, FORMALS) + # can't use all.equal because it complains about named list versus unnamed list + stopifnot(length(args) == length(expected)) + for(i in seq_len(length(expected))) { + stopifnot(names(args)[i] == names(expected)[i]) + stopifnot(eval(args[[i]]) == expected[[i]]) + } + } > cat0("=== test expand.dotnames\n") === test expand.dotnames > > test.expand.dotnames(expected=list(x=9, persp.shade=3), + "persp.", graphics:::persp.default, "persp.default", x=9, persp.sh=3) > > test.expand.dotnames(expected=list(x=9, persp.shade=3, persp.nonesuch=4), + "persp.", graphics:::persp.default, "persp.default", x=9, persp.sh=3, persp.nonesuch=4) > > test.expand.dotnames(expected=list(x=9, persp.col=3), + "persp.", graphics:::persp.default, "persp.default", x=9, persp.c=3) > > # TODO not sure why this works as it does > test.expand.dotnames(expected=list(x=9, persp.x=3), + "persp.", graphics:::persp.default, "persp.default", x=9, persp.x=3) > > expect.err(try(test.expand.dotnames(expected=NULL, + "persp.", graphics:::persp.default, "persp.default", x=9, persp.l=3)), + "'l' matches both the 'ltheta' and 'lphi' arguments of persp.default()") Error : 'l' matches both the 'ltheta' and 'lphi' arguments of persp.default() Got expected error from try(test.expand.dotnames(expected = NULL, "persp.", graphics:::persp.default, "persp.default", x = 9, persp.l = 3)) > > test.expand.dotnames(expected=list(x=9, plot.foo=3, plot.xlim=c(1,2)), + "plot.", graphics:::plot.default, "plot.default", x=9, plot.foo=3, plot.xlim=c(1,2)) > > test.expand.dotnames(expected=list(x=9, plot.foo=3, plot.xlim=c(1,2)), + "plot.", graphics:::plot.default, "plot.default", x=9, plot.foo=3, plot.xli=c(1,2)) > > expect.err(try(test.expand.dotnames(expected=NULL, + "plot.", graphics:::plot.default, "plot.default", x=9, plot.foo=3, plot.xl=c(1,2))), + "'xl' matches both the 'xlim' and 'xlab' arguments of plot.default()") Error : 'xl' matches both the 'xlim' and 'xlab' arguments of plot.default() Got expected error from try(test.expand.dotnames(expected = NULL, "plot.", graphics:::plot.default, "plot.default", x = 9, plot.foo = 3, plot.xl = c(1, 2))) > > foo3 <- function(aaa=1, aa=2, bb=3, bba=4, cca=5, ccb=6, def=7) + cat0("foo3: aaa=", aaa, " aa=", aa, ", bb=", bb, " bba=", bba, + " cca=", cca, " ccb=", ccb, " def=", def, "\n") > > # --- above tests again but using formals --- > > # formal args for graphics:::persp.default (R version 3.2.0) > formals <- c( "x", "y", "z", "xlim", "zlim", "xlab", "ylab", "zlab", + "main", "sub", "theta", "phi", "r", "d", "scale", "expand", "col", + "border", "ltheta", "lphi", "shade", "box", "axes", "nticks", + "ticktype") > > test.expand.dotnames(expected=list(x=9, persp.shade=3), + "persp.", graphics:::persp, "persp", FORMALS=formals, x=9, persp.sh=3) > > test.expand.dotnames(expected=list(x=9, persp.shade=3, persp.nonesuch=4), + "persp.", graphics:::persp, "persp", FORMALS=formals, x=9, persp.sh=3, persp.nonesuch=4) > > test.expand.dotnames(expected=list(x=9, persp.col=3), + "persp.", graphics:::persp, "persp", FORMALS=formals, x=9, persp.c=3) > > # TODO not sure why this works as it does > test.expand.dotnames(expected=list(x=9, persp.x=3), + "persp.", graphics:::persp, "persp", FORMALS=formals, x=9, persp.x=3) > > expect.err(try(test.expand.dotnames(expected=NULL, + "persp.", graphics:::persp, "persp", FORMALS=formals, x=9, persp.l=3)), + "'l' matches both the 'ltheta' and 'lphi' arguments of persp()") Error : 'l' matches both the 'ltheta' and 'lphi' arguments of persp() Got expected error from try(test.expand.dotnames(expected = NULL, "persp.", graphics:::persp, "persp", FORMALS = formals, x = 9, persp.l = 3)) > > # done formals tests > > test.expand.dotnames(expected=list(x=9, plot.foo=3, plot.xlim=c(1,2)), + "plot.", graphics:::plot.default, "plot.default", x=9, plot.foo=3, plot.xlim=c(1,2)) > > test.expand.dotnames(expected=list(x=9, plot.foo=3, plot.xlim=c(1,2)), + "plot.", graphics:::plot.default, "plot.default", x=9, plot.foo=3, plot.xli=c(1,2)) > > expect.err(try(test.expand.dotnames(expected=NULL, + "plot.", graphics:::plot.default, "plot.default", x=9, plot.foo=3, plot.xl=c(1,2))), + "'xl' matches both the 'xlim' and 'xlab' arguments of plot.default()") Error : 'xl' matches both the 'xlim' and 'xlab' arguments of plot.default() Got expected error from try(test.expand.dotnames(expected = NULL, "plot.", graphics:::plot.default, "plot.default", x = 9, plot.foo = 3, plot.xl = c(1, 2))) > > test.expand.dotnames(expected=list(foo3.aa=99), + "foo3.", foo3, "foo3", foo3.aa=99) > expect.err(try(plotmo:::call.plot(foo3, "foo3.", foo3.aa=99)), "Unnamed arguments are not allowed here\n The argument's value is \"foo3.\"") Error : Unnamed arguments are not allowed here The argument's value is "foo3." plotmo:::call.plot via try called call.dots(FUNC=foo3, PREFIX=PREFIX, ..., DROP="*", KEEP="PREFIX,PLOT.ARGS", TRACE=TRACE, FNAME=fname, FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=function.object, CALLER=caller, foo3.aa=99) Got expected error from try(plotmo:::call.plot(foo3, "foo3.", foo3.aa = 99)) > expect.err(try(plotmo:::call.plot(foo3, foo, foo3.aa=99)), + "Unnamed arguments are not allowed here\n The argument's value is function.object") Error : Unnamed arguments are not allowed here The argument's value is function.object plotmo:::call.plot via try called call.dots(FUNC=foo3, PREFIX=PREFIX, ..., DROP="*", KEEP="PREFIX,PLOT.ARGS", TRACE=TRACE, FNAME=fname, FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=function.object, CALLER=caller, foo3.aa=99) Got expected error from try(plotmo:::call.plot(foo3, foo, foo3.aa = 99)) > expect.err(try(plotmo:::call.plot(foo3, NULL, foo3.aa=99)), "Unnamed arguments are not allowed here\n The argument's value is NULL") Error : Unnamed arguments are not allowed here The argument's value is NULL plotmo:::call.plot via try called call.dots(FUNC=foo3, PREFIX=PREFIX, ..., DROP="*", KEEP="PREFIX,PLOT.ARGS", TRACE=TRACE, FNAME=fname, FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=function.object, CALLER=caller, foo3.aa=99) Got expected error from try(plotmo:::call.plot(foo3, NULL, foo3.aa = 99)) > expect.err(try(plotmo:::call.plot(foo3, stop("stop was called"), foo3.aa=99)), "Unnamed arguments are not allowed here (argument ..1 is unnamed)") Error : Unnamed arguments are not allowed here (argument ..1 is unnamed) plotmo:::call.plot via try called call.dots(FUNC=foo3, PREFIX=PREFIX, ..., DROP="*", KEEP="PREFIX,PLOT.ARGS", TRACE=TRACE, FNAME=fname, FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=function.object, CALLER=caller, foo3.aa=99) Got expected error from try(plotmo:::call.plot(foo3, stop("stop was called"), foo3.aa = 99)) > expect.err(try(plotmo:::call.plot(foo3, cat("side effect\n"), foo3.aa=99)), "Unnamed arguments are not allowed here\n The argument's value is NULL") side effect Error : Unnamed arguments are not allowed here The argument's value is NULL plotmo:::call.plot via try called call.dots(FUNC=foo3, PREFIX=PREFIX, ..., DROP="*", KEEP="PREFIX,PLOT.ARGS", TRACE=TRACE, FNAME=fname, FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=function.object, CALLER=caller, foo3.aa=99) Got expected error from try(plotmo:::call.plot(foo3, cat("side effect\n"), foo3.aa = 99)) > expect.err(try(plotmo:::call.plot(foo3, nonesuch1=1, nonesuch2, foo3.aa=99)), "Unnamed arguments are not allowed here (argument ..2 is unnamed)") Error : Unnamed arguments are not allowed here (argument ..2 is unnamed) plotmo:::call.plot via try called call.dots(FUNC=foo3, PREFIX=PREFIX, ..., DROP="*", KEEP="PREFIX,PLOT.ARGS", TRACE=TRACE, FNAME=fname, FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=function.object, CALLER=caller, nonesuch1=1, foo3.aa=99) Got expected error from try(plotmo:::call.plot(foo3, nonesuch1 = 1, nonesuch2, foo3.aa = 99)) > plotmo:::call.plot(foo3, PREFIX="foo3.", foo3.aa=99) foo3: aaa=1 aa=99, bb=3 bba=4 cca=5 ccb=6 def=7 > > test.expand.dotnames(expected=list(foo3.aaa=99), + "foo3.", foo3, "foo3", foo3.aaa=99) > plotmo:::call.plot(foo3, foo3.aaa=99) foo3: aaa=99 aa=2, bb=3 bba=4 cca=5 ccb=6 def=7 > > expect.err(try(test.expand.dotnames(expected=list(foo3.aaa=99), + "foo3.", foo3, "foo3", foo3.aa=88, foo3.aa=99)), + "'foo3.aa' for foo3() is duplicated") Error : argument 'foo3.aa' for foo3() is duplicated Got expected error from try(test.expand.dotnames(expected = list(foo3.aaa = 99), "foo3.", foo3, "foo3", foo3.aa = 88, foo3.aa = 99)) > > expect.err(try(test.expand.dotnames(expected=list(foo3.aaa=99), + "foo3.", foo3, "foo3", foo3.a=88, foo3.aa=99)), + "'a' matches both the 'aaa' and 'aa' arguments of foo3()") Error : 'a' matches both the 'aaa' and 'aa' arguments of foo3() Got expected error from try(test.expand.dotnames(expected = list(foo3.aaa = 99), "foo3.", foo3, "foo3", foo3.a = 88, foo3.aa = 99)) > > expect.err(try(test.expand.dotnames(expected=list(foo3.aaa=99), + "foo3.", foo3, "foo3", foo3.aaa=88, foo3.aaa=99)), + "'foo3.aaa' for foo3() is duplicated") Error : argument 'foo3.aaa' for foo3() is duplicated Got expected error from try(test.expand.dotnames(expected = list(foo3.aaa = 99), "foo3.", foo3, "foo3", foo3.aaa = 88, foo3.aaa = 99)) > > test.expand.dotnames(expected=list(foo3.bbb=88, foo3.bba=99), + "foo3.", foo3, "foo3", foo3.bbb=88, foo3.bba=99) > expect.err(try(plotmo:::call.plot(foo3, foo3.bbb=88, foo3.bba=99)), + "unused argument (bbb = 88)") foo3(bbb=88, bba=99) Error in (function (aaa = 1, aa = 2, bb = 3, bba = 4, cca = 5, ccb = 6, : unused argument (bbb = 88) Got expected error from try(plotmo:::call.plot(foo3, foo3.bbb = 88, foo3.bba = 99)) > > # same as above but with TRACE (so don't use try in call.dots) > expect.err(try(plotmo:::call.plot(foo3, foo3.bbb=88, foo3.bba=99, TRACE=T)), + "unused argument (bbb = 88)") foo3(bbb=88, bba=99) Error in (function (aaa = 1, aa = 2, bb = 3, bba = 4, cca = 5, ccb = 6, : unused argument (bbb = 88) Got expected error from try(plotmo:::call.plot(foo3, foo3.bbb = 88, foo3.bba = 99, TRACE = T)) > > test.expand.dotnames(expected=list(foo3.bb=88), + "foo3.", foo3, "foo3", foo3.bb=88) > plotmo:::call.plot(foo3, foo3.bb=88) foo3: aaa=1 aa=2, bb=88 bba=4 cca=5 ccb=6 def=7 > > # test with FUNC=NULL > > test.expand.dotnames(expected=list(foo3.aa=99), + "foo3.", NULL, "foo3", foo3.aa=99) > plotmo:::call.plot(foo3, foo3.aa=99) foo3: aaa=1 aa=99, bb=3 bba=4 cca=5 ccb=6 def=7 > > test.expand.dotnames(expected=list(foo3.aaa=99), + "foo3.", NULL, "foo3", foo3.aaa=99) > plotmo:::call.plot(foo3, foo3.aaa=99) foo3: aaa=99 aa=2, bb=3 bba=4 cca=5 ccb=6 def=7 > > expect.err(try(test.expand.dotnames(expected=list(foo3.aaa=99), + "foo3.", NULL, "foo3", foo3.aa=88, foo3.aa=99)), + "argument 'foo3.aa' for foo3() is duplicated") Error : argument 'foo3.aa' for foo3() is duplicated Got expected error from try(test.expand.dotnames(expected = list(foo3.aaa = 99), "foo3.", NULL, "foo3", foo3.aa = 88, foo3.aa = 99)) > > test.expand.dotnames(expected=list(foo3.a=88, foo3.aa=99), + "foo3.", NULL, "foo3", foo3.a=88, foo3.aa=99) > expect.err(try(plotmo:::call.plot(foo3, foo3.a=88, foo3.aa=99)), + "'a' matches both the 'aaa' and 'aa' arguments of foo3()") Error : 'a' matches both the 'aaa' and 'aa' arguments of foo3() Got expected error from try(plotmo:::call.plot(foo3, foo3.a = 88, foo3.aa = 99)) > > expect.err(try(test.expand.dotnames(expected=list(foo3.aaa=99), + "foo3.", NULL, "foo3", foo3.aaa=88, foo3.aaa=99)), + "argument 'foo3.aaa' for foo3() is duplicated") Error : argument 'foo3.aaa' for foo3() is duplicated Got expected error from try(test.expand.dotnames(expected = list(foo3.aaa = 99), "foo3.", NULL, "foo3", foo3.aaa = 88, foo3.aaa = 99)) > > test.expand.dotnames(expected=list(foo3.bbb=88, foo3.bba=99), + "foo3.", NULL, "foo3", foo3.bbb=88, foo3.bba=99) > expect.err(try(plotmo:::call.plot(foo3, PREFIX="foo3.", foo3.bbb=88, foo3.bba=99)), + "unused argument (bbb = 88)") foo3(bbb=88, bba=99) Error in (function (aaa = 1, aa = 2, bb = 3, bba = 4, cca = 5, ccb = 6, : unused argument (bbb = 88) Got expected error from try(plotmo:::call.plot(foo3, PREFIX = "foo3.", foo3.bbb = 88, foo3.bba = 99)) > > test.expand.dotnames(expected=list(foo3.bb=88), + "foo3.", NULL, "foo3", foo3.bb=88) > plotmo:::call.plot(foo3, foo3.bb=88) foo3: aaa=1 aa=2, bb=88 bba=4 cca=5 ccb=6 def=7 > > test.expand.dotnames(expected=list(foo3.bbx=88), + "foo3.", NULL, "foo3", foo3.bbx=88) > expect.err(try(plotmo:::call.plot(foo3, foo3.bbx=88)), + "unused argument (bbx = 88)") foo3(bbx=88) Error in (function (aaa = 1, aa = 2, bb = 3, bba = 4, cca = 5, ccb = 6, : unused argument (bbx = 88) Got expected error from try(plotmo:::call.plot(foo3, foo3.bbx = 88)) > > test.expand.dotnames(expected=list(foo3.cc=77), + "foo3.", NULL, "foo3", foo3.cc=77) > expect.err(try(plotmo:::call.plot(foo3, foo3.cc=77)), + "'cc' matches both the 'cca' and 'ccb' arguments of foo3()") Error : 'cc' matches both the 'cca' and 'ccb' arguments of foo3() Got expected error from try(plotmo:::call.plot(foo3, foo3.cc = 77)) > > # following two directly compare FUNC=NULL to FUNC=foo3 > test.expand.dotnames(expected=list(foo3.cc=77), + "foo3.", FUNC=NULL, "foo3", foo3.cc=77) > expect.err(try(test.expand.dotnames(expected=NULL, + "foo3.", FUNC=foo3, "foo3", foo3.cc=77)), + "'cc' matches both the 'cca' and 'ccb' arguments of foo3()") Error : 'cc' matches both the 'cca' and 'ccb' arguments of foo3() Got expected error from try(test.expand.dotnames(expected = NULL, "foo3.", FUNC = foo3, "foo3", foo3.cc = 77)) > > test.expand.dotnames(expected=list(), "foo3.", foo3, "foo3", d=88, de=99) > > expect.err(try(plotmo:::call.plot(graphics::plot, x=1:3, y=1:3, 99)), + "Unnamed arguments are not allowed here\n The argument's value is 99\n plotmo:::call.plot via try called call.dots(FUNC=plot, PREFIX=PREFIX, ...") Error : Unnamed arguments are not allowed here The argument's value is 99 plotmo:::call.plot via try called call.dots(FUNC=plot, PREFIX=PREFIX, ..., DROP="*", KEEP="PREFIX,PLOT.ARGS", TRACE=TRACE, FNAME=fname, FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=function.object, CALLER=caller, x=c(1,2,3), y=c(1,2,3)) Got expected error from try(plotmo:::call.plot(graphics::plot, x = 1:3, y = 1:3, 99)) > > # test TRACE > print(plotmo:::deprefix(FUNC=nchar, PREFIX="foo3.", TRACE=TRUE, FNAME="nchar", allowN=1, b=2, foo3.c=3)) $allowNA [1] 1 $b [1] 2 $c [1] 3 > print(plotmo:::deprefix(FUNC=nchar, PREFIX="foo3.", TRACE=2, allowN=1, b=2, foo3.c=3)) TRACE higher.caller.to.deprefix called higher.caller.to.deprefix(nchar, FNAME="nchar", allowN=1, b=2, foo3.c=3) PREFIX foo3. DROP NULL KEEP ^force.|^def.|^foo3. input dotnames allowN b foo3.c after DROP and KEEP allowN b foo3.c return dotnames allowNA b c $allowNA [1] 1 $b [1] 2 $c [1] 3 > print(plotmo:::deprefix(FUNC=nchar, PREFIX="foo3.", TRACE=3, allowN=1, b=2, foo3.c=3)) TRACE higher.caller.to.deprefix called higher.caller.to.deprefix(nchar, FNAME="nchar", allowN=1, b=2, foo3.c=3) PREFIX foo3. DROP NULL KEEP ^force.|^def.|^foo3. input dotnames allowN b foo3.c after DROP and KEEP allowN b foo3.c return dotnames allowNA b c $allowNA [1] 1 $b [1] 2 $c [1] 3 > > expect.err(try(plotmo:::call.plot(foo3, foo3.d=88, foo3.de=99)), + "'foo3.d' and 'foo3.de' both match the 'def' argument of foo3()") Error : 'foo3.d' and 'foo3.de' both match the 'def' argument of foo3() Got expected error from try(plotmo:::call.plot(foo3, foo3.d = 88, foo3.de = 99)) > > cat0("=== test stop.if.dots\n") === test stop.if.dots > > foo3 <- function(x=1, ...) plotmo:::stop.if.dots(...) > foo3(1) # ok > expect.err(try(foo3(10, y=2)), "foo3: unrecognized argument 'y'") Error : foo3: unrecognized argument 'y' Got expected error from try(foo3(10, y = 2)) > expect.err(try(foo3(10, 99)), "foo3: unrecognized unnamed argument\n The call was foo3(x=10, 99)") Error : foo3: unrecognized unnamed argument The call was foo3(x=10, 99) Got expected error from try(foo3(10, 99)) > expect.err(try(foo3(10, y=plot)), "foo3: unrecognized argument 'y'") Error : foo3: unrecognized argument 'y' Got expected error from try(foo3(10, y = plot)) > expect.err(try(foo3(10, plot)), + "foo3: unrecognized unnamed argument\n The call was foo3(x=10, plot)") Error : foo3: unrecognized unnamed argument The call was foo3(x=10, plot) Got expected error from try(foo3(10, plot)) > > expect.err(try(foo3(20, c(1,2,3), plot)), + "foo3: unrecognized unnamed argument\n The call was foo3(x=20, c(1,2,3), plot)") Error : foo3: unrecognized unnamed argument The call was foo3(x=20, c(1,2,3), plot) Got expected error from try(foo3(20, c(1, 2, 3), plot)) > > expect.err(try(foo3(20, c(1,2,3,4,5,6,7,8,9,10,11,12), plot)), + "foo3: unrecognized unnamed argument\n The call was foo3(x=20, c(1,2,3,4,5,6,7,8,9,10,11,12), plot)") Error : foo3: unrecognized unnamed argument The call was foo3(x=20, c(1,2,3,4,5,6,7,8,9,10,11,12), plot) Got expected error from try(foo3(20, c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12), plot)) > > # test that we don't crash because we eval the argument > expect.err(try(foo3(20, y=stop("stop was called"))), "foo3: unrecognized argument 'y'") Error : foo3: unrecognized argument 'y' Got expected error from try(foo3(20, y = stop("stop was called"))) > expect.err(try(foo3(20, stop("stop was called"))), "foo3: unrecognized unnamed argument") Error : foo3: unrecognized unnamed argument The call was foo3(x=20, stop("stopwascalled")) Got expected error from try(foo3(20, stop("stop was called"))) > expect.err(try(foo3(20, cat("side effect\n"))), + "foo3: unrecognized unnamed argument\n The call was foo3(x=20, cat(") Error : foo3: unrecognized unnamed argument The call was foo3(x=20, cat("sideeffect\n")) Got expected error from try(foo3(20, cat("side effect\n"))) > foo2 <- function(...) plotmo:::stop.if.dots(...) > foo2() # ok > expect.err(try(foo2(y=2)), "foo2: unrecognized argument 'y'") Error : foo2: unrecognized argument 'y' Got expected error from try(foo2(y = 2)) > expect.err(try(foo2(2)), "foo2: unrecognized unnamed argument\n The call was foo2(2)") Error : foo2: unrecognized unnamed argument The call was foo2(2) Got expected error from try(foo2(2)) > expect.err(try(foo2(y=plot)), "foo2: unrecognized argument 'y'") Error : foo2: unrecognized argument 'y' Got expected error from try(foo2(y = plot)) > expect.err(try(foo2(plot)), + "foo2: unrecognized unnamed argument\n The call was foo2(plot)") Error : foo2: unrecognized unnamed argument The call was foo2(plot) Got expected error from try(foo2(plot)) > > foo2a <- function(funcarg, ...) funcarg(...) > expect.err(try(foo2a(function(x=1, ...) plotmo:::stop.if.dots(...), x=1, y=2)), "funcarg: unrecognized argument 'y'") Error : funcarg: unrecognized argument 'y' Got expected error from try(foo2a(function(x = 1, ...) plotmo:::stop.if.dots(...), x = 1, y = 2)) > > cat0("=== test warn.if.dots\n") === test warn.if.dots > > options(warn=2) # treat warnings as errors > > foo3 <- function(x=1, ...) plotmo:::warn.if.dots(...) > foo3(1) # ok > expect.err(try(foo3(1, y=2)), "foo3 ignored argument 'y'") Error : (converted from warning) foo3 ignored argument 'y' Got expected error from try(foo3(1, y = 2)) > expect.err(try(foo3(1, 2)), "foo3 ignored unnamed argument\n The call was foo3(x=1, 2)") Error : (converted from warning) foo3 ignored unnamed argument The call was foo3(x=1, 2) Got expected error from try(foo3(1, 2)) > expect.err(try(foo3(1, y=plot)), "foo3 ignored argument 'y'") Error : (converted from warning) foo3 ignored argument 'y' Got expected error from try(foo3(1, y = plot)) > # TODO would like to improve this error messsage > expect.err(try(foo3(1, plot)), + "(converted from warning) foo3 ignored unnamed argument\n The call was foo3(x=1, plot)") Error : (converted from warning) foo3 ignored unnamed argument The call was foo3(x=1, plot) Got expected error from try(foo3(1, plot)) > foo4 <- function(...) plotmo:::warn.if.dots(...) > foo4() # ok > expect.err(try(foo4(y=2)), "foo4 ignored argument 'y'") Error : (converted from warning) foo4 ignored argument 'y' Got expected error from try(foo4(y = 2)) > expect.err(try(foo4(2)), "foo4 ignored unnamed argument\n The call was foo4(2)") Error : (converted from warning) foo4 ignored unnamed argument The call was foo4(2) Got expected error from try(foo4(2)) > expect.err(try(foo4(y=plot)), "foo4 ignored argument 'y'") Error : (converted from warning) foo4 ignored argument 'y' Got expected error from try(foo4(y = plot)) > expect.err(try(foo4(plot)), + "(converted from warning) foo4 ignored unnamed argument\n The call was foo4(plot)") Error : (converted from warning) foo4 ignored unnamed argument The call was foo4(plot) Got expected error from try(foo4(plot)) > > options(warn=1) > > foo3(1, nonesuch=12, nonesuch2=12, 999) # expect three warnings Warning: foo3 ignored argument 'nonesuch' Warning: foo3 ignored argument 'nonesuch2' Warning: foo3 ignored unnamed argument The call was foo3(x=1, nonesuch=12, nonesuch2=12, 999) > > cat0("=== test using sample functions that invoke call.dots\n") === test using sample functions that invoke call.dots > > x <- 1:10 > y <- x * x > lmfit <- lm(y~x) > par(mfrow=c(3, 2)) > par(oma=c(0, 0, 3, 0)) > > # plot1: simple example > # we choose to use predict() here rather than fitted() because nearly all > # models have a fitted() method, but many don't have a fitted() method. > > plot1 <- function(object, ...) + { + residuals <- residuals(object, ...) + + fitted <- predict(object, ...) + + plot(fitted, residuals, ...) + } > plot1(lmfit) > mtext("example plot functions using prefixed dots", outer=TRUE, font=2, line=1, cex=1) > > # Following causes error in predict.lm(). The type argument meant for > # residuals() is also sent to predict.lm(), where it is rejected. > > expect.err(try(plot1(lmfit, type="pearson")), "'arg' should be one of \"response\", \"terms\"") Error in match.arg(type) : 'arg' should be one of "response", "terms" Got expected error from try(plot1(lmfit, type = "pearson")) > > # plot2: use prefixed args > > plot2 <- function(object, ..., TRACE=2) + { + resids <- plotmo:::call.dots(residuals, object=object, ..., TRACE=TRACE) + + fitted <- plotmo:::call.dots(predict, object=object, ..., TRACE=TRACE) + + plotmo:::call.plot(plot, x=fitted, y=resids, ..., TRACE=TRACE) + } > # we can now direct args using the prefixes "residuals.", "predict.", or "plot.") > > plot2(lmfit, residuals.type="pearson") plot2 invoked call.dots TRACE plotmo:::call.dots called deprefix(FUNC=residuals, PREFIX=PREFIX, ..., DROP=DROP, KEEP=KEEP, TRACE=TRACE, FNAME="residuals", FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=CALLARGS, object=lm.object, residuals.type="pearson") PREFIX residuals. DROP .* KEEP >STANDARDPREFIXES|^force\.|^def\.|^drop\. >PREFIX|^residuals\. >CALLARGS|^object$ >EXPLICIT input dotnames object residuals.type after DROP and KEEP object residuals.type return dotnames object type residuals(object=lm.object, type="pearson") plot2 invoked call.dots TRACE plotmo:::call.dots called deprefix(FUNC=predict, PREFIX=PREFIX, ..., DROP=DROP, KEEP=KEEP, TRACE=TRACE, FNAME="predict", FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=CALLARGS, object=lm.object, residuals.type="pearson") PREFIX predict. DROP .* KEEP >STANDARDPREFIXES|^force\.|^def\.|^drop\. >PREFIX|^predict\. >CALLARGS|^object$ >EXPLICIT input dotnames object residuals.type after DROP and KEEP object return dotnames object predict(object=lm.object) plot2 invoked call.dots TRACE plotmo:::call.plot called call.dots(FUNC=plot, PREFIX=PREFIX, ..., DROP="*", KEEP="PREFIX,PLOT.ARGS", TRACE=TRACE, FNAME=fname, FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=function.object, CALLER=caller, x=c(-11,0,11,22,3...), y=c(12,4,-2,-6,-8...), residuals.type="pearson") PREFIX plot. DROP .* KEEP >STANDARDPREFIXES|^force\.|^def\.|^drop\. >PREFIX|^plot\. >CALLARGS|^x$|^y$ >EXPLICIT >PLOT_ARGS|^add$|^adj$|^bty$|^cex$|^cex\.axis$|^cex\.lab$|^cex\.main$|^cex\.sub$|^col$|^col\.axis$|^col\.lab$|^col\.main$|^col\.sub$|^crt$|^family$|^font$|^font$|^font\.axis$|^font\.lab$|^font\.main$|^font\.sub$|^lend$|^ljoin$|^lmitre$|^lty$|^lwd$|^main$|^pch$|^srt$|^xaxp$|^xaxs$|^xaxt$|^xlab$|^xlim$|^xlog$|^xpd$|^yaxp$|^yaxs$|^yaxt$|^ylab$|^ylim$|^ylog$ input dotnames x y residuals.type after DROP and KEEP x y return dotnames x y plot(x=c(-11,0,11,22,3...), y=c(12,4,-2,-6,-8...)) > > # We can also use the usual plot arguments like ylab: call.dots drops > # them; call.plot recognizes them and passes them to lines(). > > plot2(lmfit, residuals.type="pearson", ylab="pearson residuals", main="plot2") plot2 invoked call.dots TRACE plotmo:::call.dots called deprefix(FUNC=residuals, PREFIX=PREFIX, ..., DROP=DROP, KEEP=KEEP, TRACE=TRACE, FNAME="residuals", FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=CALLARGS, object=lm.object, residuals.type="pearson", ylab="pearson residuals", main="plot2") PREFIX residuals. DROP .* KEEP >STANDARDPREFIXES|^force\.|^def\.|^drop\. >PREFIX|^residuals\. >CALLARGS|^object$ >EXPLICIT input dotnames object residuals.type ylab main after DROP and KEEP object residuals.type return dotnames object type residuals(object=lm.object, type="pearson") plot2 invoked call.dots TRACE plotmo:::call.dots called deprefix(FUNC=predict, PREFIX=PREFIX, ..., DROP=DROP, KEEP=KEEP, TRACE=TRACE, FNAME="predict", FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=CALLARGS, object=lm.object, residuals.type="pearson", ylab="pearson residuals", main="plot2") PREFIX predict. DROP .* KEEP >STANDARDPREFIXES|^force\.|^def\.|^drop\. >PREFIX|^predict\. >CALLARGS|^object$ >EXPLICIT input dotnames object residuals.type ylab main after DROP and KEEP object return dotnames object predict(object=lm.object) plot2 invoked call.dots TRACE plotmo:::call.plot called call.dots(FUNC=plot, PREFIX=PREFIX, ..., DROP="*", KEEP="PREFIX,PLOT.ARGS", TRACE=TRACE, FNAME=fname, FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=function.object, CALLER=caller, x=c(-11,0,11,22,3...), y=c(12,4,-2,-6,-8...), residuals.type="pearson", ylab="pearson residuals", main="plot2") PREFIX plot. DROP .* KEEP >STANDARDPREFIXES|^force\.|^def\.|^drop\. >PREFIX|^plot\. >CALLARGS|^x$|^y$ >EXPLICIT >PLOT_ARGS|^add$|^adj$|^bty$|^cex$|^cex\.axis$|^cex\.lab$|^cex\.main$|^cex\.sub$|^col$|^col\.axis$|^col\.lab$|^col\.main$|^col\.sub$|^crt$|^family$|^font$|^font$|^font\.axis$|^font\.lab$|^font\.main$|^font\.sub$|^lend$|^ljoin$|^lmitre$|^lty$|^lwd$|^main$|^pch$|^srt$|^xaxp$|^xaxs$|^xaxt$|^xlab$|^xlim$|^xlog$|^xpd$|^yaxp$|^yaxs$|^yaxt$|^ylab$|^ylim$|^ylog$ input dotnames x y residuals.type ylab main after DROP and KEEP x y ylab main return dotnames x y main ylab plot(x=c(-11,0,11,22,3...), y=c(12,4,-2,-6,-8...), main="plot2", ylab="pearson residuals") > > # plot3: further refinements > # o namespace added to FUNC arg > # o full name for plot.default > # o force. and def. prefixes > # o explicit xlab and ylab for call.plot > # o unprefixed args are passed to residuals() > > plot3 <- function(object, ..., TRACE=2) + { + resids <- plotmo:::call.dots(stats::residuals, + DROP="plotmo:::PLOTARGS,predict.,plot.", + TRACE=TRACE, force.object=object, ...) + + fitted <- plotmo:::call.dots(stats::predict, + force.object=object, TRACE=TRACE, ...) + + plotmo:::call.plot(graphics::plot.default, force.x=fitted, force.y=resids, + def.xlab="fitted", def.ylab="residuals", + TRACE=TRACE, ...) + } > plot3(lmfit, type="pearson", main="plot3a") # type goes only to pearson, no prefix needed plot3 invoked call.dots TRACE plotmo:::call.dots called deprefix(FUNC=residuals, PREFIX=PREFIX, ..., DROP=DROP, KEEP=KEEP, TRACE=TRACE, FNAME="residuals", FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=CALLARGS, force.object=lm.object, type="pearson", main="plot3a") PREFIX residuals. DROP >PREFIX >EXPLICIT|^plotmo:::PLOTARGS|^predict\.|^plot\. KEEP >STANDARDPREFIXES|^force\.|^def\.|^drop\. >PREFIX|^residuals\. >CALLARGS|^force\.object$ >EXPLICIT input dotnames force.object type main after DROP and KEEP force.object type main return dotnames object type main stats::residuals(object=lm.object, type="pearson", main="plot3a") plot3 invoked call.dots TRACE plotmo:::call.dots called deprefix(FUNC=predict, PREFIX=PREFIX, ..., DROP=DROP, KEEP=KEEP, TRACE=TRACE, FNAME="predict", FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=CALLARGS, force.object=lm.object, type="pearson", main="plot3a") PREFIX predict. DROP .* KEEP >STANDARDPREFIXES|^force\.|^def\.|^drop\. >PREFIX|^predict\. >CALLARGS|^force\.object$ >EXPLICIT input dotnames force.object type main after DROP and KEEP force.object return dotnames object stats::predict(object=lm.object) plot3 invoked call.dots TRACE plotmo:::call.plot called call.dots(FUNC=plot.default, PREFIX=PREFIX, ..., DROP="*", KEEP="PREFIX,PLOT.ARGS", TRACE=TRACE, FNAME=fname, FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=function.object, CALLER=caller, force.x=c(-11,0,11,22,3...), force.y=c(12,4,-2,-6,-8...), def.xlab="fitted", def.ylab="residuals", type="pearson", main="plot3a") PREFIX plot. DROP .* KEEP >STANDARDPREFIXES|^force\.|^def\.|^drop\. >PREFIX|^plot\. >CALLARGS|^force\.x$|^force\.y$|^def\.xlab$|^def\.ylab$ >EXPLICIT >PLOT_ARGS|^add$|^adj$|^bty$|^cex$|^cex\.axis$|^cex\.lab$|^cex\.main$|^cex\.sub$|^col$|^col\.axis$|^col\.lab$|^col\.main$|^col\.sub$|^crt$|^family$|^font$|^font$|^font\.axis$|^font\.lab$|^font\.main$|^font\.sub$|^lend$|^ljoin$|^lmitre$|^lty$|^lwd$|^main$|^pch$|^srt$|^xaxp$|^xaxs$|^xaxt$|^xlab$|^xlim$|^xlog$|^xpd$|^yaxp$|^yaxs$|^yaxt$|^ylab$|^ylim$|^ylog$ input dotnames force.x force.y def.xlab def.ylab type main after DROP and KEEP force.x force.y def.xlab def.ylab main return dotnames x y main xlab ylab graphics::plot.default(x=c(-11,0,11,22,3...), y=c(12,4,-2,-6,-8...), main="plot3a", xlab="fitted", ylab="residuals") > plot3(lmfit, type="pearson", predict.type="response", main="plot3b") plot3 invoked call.dots TRACE plotmo:::call.dots called deprefix(FUNC=residuals, PREFIX=PREFIX, ..., DROP=DROP, KEEP=KEEP, TRACE=TRACE, FNAME="residuals", FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=CALLARGS, force.object=lm.object, type="pearson", predict.type="response", main="plot3b") PREFIX residuals. DROP >PREFIX >EXPLICIT|^plotmo:::PLOTARGS|^predict\.|^plot\. KEEP >STANDARDPREFIXES|^force\.|^def\.|^drop\. >PREFIX|^residuals\. >CALLARGS|^force\.object$ >EXPLICIT input dotnames force.object type predict.type main after DROP and KEEP force.object type main return dotnames object type main stats::residuals(object=lm.object, type="pearson", main="plot3b") plot3 invoked call.dots TRACE plotmo:::call.dots called deprefix(FUNC=predict, PREFIX=PREFIX, ..., DROP=DROP, KEEP=KEEP, TRACE=TRACE, FNAME="predict", FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=CALLARGS, force.object=lm.object, type="pearson", predict.type="response", main="plot3b") PREFIX predict. DROP .* KEEP >STANDARDPREFIXES|^force\.|^def\.|^drop\. >PREFIX|^predict\. >CALLARGS|^force\.object$ >EXPLICIT input dotnames force.object type predict.type main after DROP and KEEP force.object predict.type return dotnames object type stats::predict(object=lm.object, type="response") plot3 invoked call.dots TRACE plotmo:::call.plot called call.dots(FUNC=plot.default, PREFIX=PREFIX, ..., DROP="*", KEEP="PREFIX,PLOT.ARGS", TRACE=TRACE, FNAME=fname, FORMALS=FORMALS, SCALAR=SCALAR, CALLARGS=function.object, CALLER=caller, force.x=c(-11,0,11,22,3...), force.y=c(12,4,-2,-6,-8...), def.xlab="fitted", def.ylab="residuals", type="pearson", predict.type="response", main="plot3b") PREFIX plot. DROP .* KEEP >STANDARDPREFIXES|^force\.|^def\.|^drop\. >PREFIX|^plot\. >CALLARGS|^force\.x$|^force\.y$|^def\.xlab$|^def\.ylab$ >EXPLICIT >PLOT_ARGS|^add$|^adj$|^bty$|^cex$|^cex\.axis$|^cex\.lab$|^cex\.main$|^cex\.sub$|^col$|^col\.axis$|^col\.lab$|^col\.main$|^col\.sub$|^crt$|^family$|^font$|^font$|^font\.axis$|^font\.lab$|^font\.main$|^font\.sub$|^lend$|^ljoin$|^lmitre$|^lty$|^lwd$|^main$|^pch$|^srt$|^xaxp$|^xaxs$|^xaxt$|^xlab$|^xlim$|^xlog$|^xpd$|^yaxp$|^yaxs$|^yaxt$|^ylab$|^ylim$|^ylog$ input dotnames force.x force.y def.xlab def.ylab type predict.type main after DROP and KEEP force.x force.y def.xlab def.ylab main return dotnames x y main xlab ylab graphics::plot.default(x=c(-11,0,11,22,3...), y=c(12,4,-2,-6,-8...), main="plot3b", xlab="fitted", ylab="residuals") > > cat0("=== test callers.name\n") === test callers.name > > test.callers.name <- function(x) { + caller0 <- plotmo:::callers.name(0) # test.callers.name + caller1 <- plotmo:::callers.name(1) # caller of test.callers.name + caller99 <- plotmo:::callers.name(99) # sys.call(-n) : not that many frames on the stack + s <- sprint("0 %s 1 %s 99 %s", caller0, caller1, caller99) + cat(s, "\n", sep="") + s + } > print(plotmo:::callers.name()) # "eval" [1] "NULL" > myfunc <- function(func) func() > stopifnot(myfunc(function(x) test.callers.name(99)) == "0 test.callers.name 1 func 99 unknown") 0 test.callers.name 1 func 99 unknown > stopifnot(test.callers.name() == "0 test.callers.name 1 stopifnot 99 unknown") 0 test.callers.name 1 stopifnot 99 unknown > > source("test.epilog.R") plotmo/inst/slowtests/test.gbm.Rout.save0000644000176200001440000010356114664454472020171 0ustar liggesusers> # test.gbm.R: gbm tests for plotmo and plotres > > source("test.prolog.R") > library(gbm) Loaded gbm 2.2.2 This version of gbm is no longer under development. Consider transitioning to gbm3, https://github.com/gbm-developers/gbm3 > library(rpart.plot) # for ptitanic, want data with NAs for testing Loading required package: rpart > library(plotmo) Loading required package: Formula Loading required package: plotrix > data(ptitanic) > > cat("--- distribution=\"gaussian\", formula interface ----------------------------------\n") --- distribution="gaussian", formula interface ---------------------------------- > > set.seed(2016) > ptit <- ptitanic[sample(1:nrow(ptitanic), size=70), ] # small data for fast test > set.seed(2016) > # # TODO bug in gbm: following causes error: survived is not of type numeric, ordered, or factor > # ptit$survived <- ptit$survived == "survived" > ptit <- ptit[!is.na(ptit$age), ] > train.frac <- .8 > set.seed(2016) > gbm.gaussian <- gbm(age~., data=ptit, train.frac=train.frac, + distribution="gaussian", + n.trees=50, shrinkage=.1, keep.data=FALSE) > expect.err(try(plotres(gbm.gaussian)), "use keep.data=TRUE in the call to gbm") Error : use keep.data=TRUE in the call to gbm (cannot determine the variable importances) Got expected error from try(plotres(gbm.gaussian)) > set.seed(2016) > gbm.gaussian <- gbm(age~., data=ptit, train.frac=train.frac, + distribution="gaussian", + n.trees=50, shrinkage=.1) > par(mfrow=c(2,2), mar=c(3,3,4,1)) > w1 <- plotres(gbm.gaussian, which=1, do.par=FALSE, w1.smooth=TRUE, + w1.main="gbm.gaussian") > cat("w1 plot for gbm.gaussian returned (w1.smooth=TRUE):\n") w1 plot for gbm.gaussian returned (w1.smooth=TRUE): > print(w1) train test CV OOB 50 1 0 1 > plot(0, 0) # dummy plot > w3 <- plotres(gbm.gaussian, which=3, do.par=FALSE, info=TRUE, + smooth.col=0, col=ptit$sex, # ylim=c(-40,40), + wmain="nresponse=1") > # compare to manual residuals > iused <- 1:(train.frac * nrow(ptit)) > y <- ptit$age[iused] > n.trees <- plotmo:::gbm.n.trees(gbm.gaussian) > # TODO following fails in the new version of gbm (version 2.2) (you have to provide newdata) > # yhat <- predict(gbm.gaussian, type="response", n.trees=n.trees) > yhat <- predict(gbm.gaussian, newdata=ptit, type="response", n.trees=n.trees) > yhat <- yhat[iused] > plot(yhat, y - yhat, + col=ptit$sex[iused], main="manual gaussian residuals", + pch=20, ylim=c(-40,40)) > abline(h=0, col="gray") > stopifnot(all(yhat == w3$x)) > stopifnot(all(y - yhat == w3$y)) > par(org.par) > > w1 <- plotres(gbm.gaussian, predict.n.trees=13, w1.grid.col=1, trace=1, SHOWCALL=TRUE, + w1.smooth=TRUE, + w1.main="predict.n.trees=13 w1.grid.col=1") importance: survived pclass parch sibsp sex stats::residuals(object=gbm.object, type="response") residuals() was unsuccessful, will use predict() instead stats::predict(gbm.object, data.frame[3,5], type="response", n.trees=13) stats::fitted(object=gbm.object) fitted() was unsuccessful, will use predict() instead plot_gbm(gbm.object, main="predict.n.trees=13 w1.grid.col=1", n.trees=13, grid.col=1, smooth=TRUE) training rsq 0.07 > cat("second w1 plot for gbm.gaussian returned (w1.smooth=TRUE):\n") second w1 plot for gbm.gaussian returned (w1.smooth=TRUE): > print(w1) train test CV OOB 50 1 0 1 > plotmo(gbm.gaussian, trace=-1, SHOWCALL=TRUE) > # plotmo(gbm.gaussian, trace=-1, all1=TRUE, SHOWCALL=TRUE) > # plotmo(gbm.gaussian, trace=-1, all2=TRUE, SHOWCALL=TRUE) > > # test color argument > par(mfrow=c(2,2), mar=c(3,3,4,1)) > plotres(gbm.gaussian, which=1) > title("test color argument") > plotres(gbm.gaussian, which=1, w1.col=c(1,2,3,0)) > plotres(gbm.gaussian, which=1, w1.col=c(1,0,0,4), w1.legend.x=40, w1.legend.y=.3) > plotres(gbm.gaussian, which=1, w1.col=c(2,3,4,1), w1.legend.x="topright") > par(org.par) > > par(mfrow=c(2,2), mar=c(3,3,4,1)) > plot_gbm(gbm.gaussian) > title("test plot_gbm") > w1 <- plot_gbm(gbm.gaussian, col=c(1,2,3,0), grid.col=1, smooth=TRUE, + main="col=c(1,2,3,0), grid.col=1") > cat("third w1 plot for gbm.gaussian returned (smooth=TRUE):\n") third w1 plot for gbm.gaussian returned (smooth=TRUE): > print(w1) train test CV OOB 50 1 0 1 > par(org.par) > > # test xlim and ylim > par(mfrow=c(2,3), mar=c(3,3,4,1)) > plot_gbm(gbm.gaussian, main="test xlim and ylim default") > plot_gbm(gbm.gaussian, ylim=NULL, main="ylim=NULL") > plot_gbm(gbm.gaussian, xlim=c(5, 50), main="xlim=c(5, 50)") > plot_gbm(gbm.gaussian, ylim=c(100, 250), main="ylim=c(100, 250)") > plot_gbm(gbm.gaussian, xlim=c(10, 25), + ylim=c(150, 170), main="xlim=c(10, 25), ylim=c(150, 170)") > plot_gbm(gbm.gaussian, xlim=c(-10, 40), ylim=c(-10, 300), legend.x=NA, + main="xlim=c(-10, 40), ylim=c(-10, 300)\nlegend.x=NA") > par(org.par) > > # test the smooth argument > par(mfrow=c(3,3), mar=c(3,3,4,1)) > imin <- plot_gbm(gbm.gaussian, main="smooth=default") > imin.default <- imin > cat("smooth=default imin=c(", imin[1], ",", imin[2], ",", imin[3], ",", imin[4], ")\n", sep="") smooth=default imin=c(50,2,0,1) > > imin <- plot_gbm(gbm.gaussian, smooth=c(1,0,0,0), main="smooth=c(1,0,0,0)") > cat("smooth=c(1,0,0,0) imin=c(", imin[1], ",", imin[2], ",", imin[3], ",", imin[4], ")\n", sep="") smooth=c(1,0,0,0) imin=c(50,2,0,6) > > imin <- plot_gbm(gbm.gaussian, smooth=c(0,1,0,0), main="smooth=c(0,1,0,0)") > cat("smooth=c(0,1,0,0) imin=c(", imin[1], ",", imin[2], ",", imin[3], ",", imin[4], ")\n", sep="") smooth=c(0,1,0,0) imin=c(50,1,0,6) > > imin <- plot_gbm(gbm.gaussian, smooth=c(0,0,1,0), main="smooth=c(0,0,1,0)") > cat("smooth=c(0,0,1,0) imin=c(", imin[1], ",", imin[2], ",", imin[3], ",", imin[4], ")\n", sep="") smooth=c(0,0,1,0) imin=c(50,2,0,6) > > imin <- plot_gbm(gbm.gaussian, smooth=c(0,0,0,1), main="smooth=c(0,0,0,1)\nsame as default") > cat("smooth=c(0,0,0,1) imin=c(", imin[1], ",", imin[2], ",", imin[3], ",", imin[4], ")\n", sep="") smooth=c(0,0,0,1) imin=c(50,2,0,1) > > imin <- plot_gbm(gbm.gaussian, smooth=c(0,0,0,0), main="smooth=c(0,0,0,0)") > cat("smooth=c(0,0,0,0) imin=c(", imin[1], ",", imin[2], ",", imin[3], ",", imin[4], ")\n", sep="") smooth=c(0,0,0,0) imin=c(50,2,0,6) > > imin <- plot_gbm(gbm.gaussian, smooth=c(0,0,1,1), main="smooth=c(0,0,1,1)") > cat("smooth=c(0,0,1,1) imin=c(", imin[1], ",", imin[2], ",", imin[3], ",", imin[4], ")\n", sep="") smooth=c(0,0,1,1) imin=c(50,2,0,1) > > imin <- plot_gbm(gbm.gaussian, smooth=1, main="smooth=1") # gets recycled > cat("smooth=1 imin=c(", imin[1], ",", imin[2], ",", imin[3], ",", imin[4], ")\n", sep="") smooth=1 imin=c(50,1,0,1) > imin.smooth <- imin > > imin.noplot <- plot_gbm(gbm.gaussian, col=0) # will not be plotted > print(imin.default) train test CV OOB 50 2 0 1 > print(imin.noplot) train test CV OOB 50 2 0 1 > stopifnot(identical(imin.default, imin.noplot)) > > imin.noplot <- plot_gbm(gbm.gaussian, col=0, smooth=1) # will not be plotted > print(imin.smooth) train test CV OOB 50 1 0 1 > print(imin.noplot) train test CV OOB 50 1 0 1 > stopifnot(identical(imin.smooth, imin.noplot)) > > par(org.par) > > cat("--- distribution=\"gaussian\", glm.fit interface ----------------------------------\n") --- distribution="gaussian", glm.fit interface ---------------------------------- > > set.seed(2016) > ptit <- ptitanic[sample(1:nrow(ptitanic), size=70), ] > set.seed(2016) > ptit <- ptit[!is.na(ptit$age), ] > train.frac <- .8 > set.seed(2016) > gbm.gaussian.fit <- gbm.fit(ptit[,-4], ptit[,4], nTrain=floor(train.frac * nrow(ptit)), + distribution="gaussian", verbose=FALSE, + n.trees=50, shrinkage=.1) > par(mfrow=c(2,2), mar=c(3,3,4,1)) > w1 <- plotres(gbm.gaussian.fit, which=1, do.par=FALSE, w1.smooth=TRUE, + w1.main="gbm.gaussian.fit") > > cat("w1 plot for gbm.gaussian.fit returned (w1.smooth=TRUE):\n") w1 plot for gbm.gaussian.fit returned (w1.smooth=TRUE): > print(w1) train test CV OOB 50 1 0 1 > > plot(0, 0) # dummy plot > > w3 <- plotres(gbm.gaussian.fit, which=3, do.par=FALSE, info=TRUE, trace=0, + smooth.col=0, col=ptit$sex, # ylim=c(-40,40), + wmain="nresponse=1") > > # compare to manual residuals > iused <- 1:(train.frac * nrow(ptit)) > y.fit <- ptit$age[iused] > n.trees <- plotmo:::gbm.n.trees(gbm.gaussian.fit) > # TODO following fails in the new version of gbm (version 2.2) (you have to provide newdata) > # yhat.fit <- predict(gbm.gaussian.fit, type="response", n.trees=n.trees) > yhat.fit <- predict(gbm.gaussian.fit, newdata=ptit[,-4], type="response", n.trees=n.trees) > yhat.fit <- yhat.fit[iused] > # plot(yhat.fit, y.fit - yhat.fit, > # col=ptit$sex[iused], main="manual gaussian residuals\n(TODO gbm.fit don't match)", > # pch=20, ylim=c(-40,40)) > # abline(h=0, col="gray") > # --- TODO known issue, these fail --- > # compare to formual interface > # stopifnot(all(yhat.fit == yhat)) > stopifnot(all(y.fit == y)) > # # sanity check > # stopifnot(all(yhat.fit == w3$x)) > # stopifnot(all(y.fit - yhat.fit == w3$y.fit)) > plotmo(gbm.gaussian.fit, trace=-1, SHOWCALL=TRUE) > par(org.par) > > cat("--- distribution=\"laplace\" ----------------------------------\n") --- distribution="laplace" ---------------------------------- > > set.seed(2016) > ptit <- ptitanic[sample(1:nrow(ptitanic), size=70), ] > ptit <- ptit[!is.na(ptit$age), ] > ptit$survived <- ptit$parch <- ptit$sex <- NULL > train.frac <- .8 > set.seed(2016) > gbm.laplace <- gbm(age~., data=ptit, train.frac=train.frac, + distribution="laplace", + n.trees=100, shrinkage=.1) > par(mfrow=c(2,2), mar=c(3,3,4,1)) > w1 <- plotres(gbm.laplace, which=1:2, do.par=FALSE, w1.smooth=TRUE, + w1.main="gbm.laplace") > > cat("w1 plot for gbm.laplace returned (w1.smooth=TRUE):\n") w1 plot for gbm.laplace returned (w1.smooth=TRUE): > print(w1) train test CV OOB 75 100 0 1 > > w3 <- plotres(gbm.laplace, which=3, do.par=FALSE, info=TRUE) > > # compare to manual residuals > iused <- 1:(train.frac * nrow(ptit)) > y <- ptit$age[iused] > n.trees <- plotmo:::gbm.n.trees(gbm.laplace) > # TODO following fails in the new version of gbm (version 2.2) (you have to provide newdata) > # yhat <- predict(gbm.laplace, type="response", n.trees=n.trees) > yhat <- predict(gbm.laplace, newdata=ptit, type="response", n.trees=n.trees) > yhat <- yhat[iused] > plot(yhat, y - yhat, + main="manual laplace residuals", + pch=20, ylim=c(-40,40)) > abline(h=0, col="gray") > stopifnot(all(yhat == w3$x)) > stopifnot(all(y - yhat == w3$y)) > plotmo(gbm.laplace, trace=-1, SHOWCALL=TRUE) > par(org.par) > > # # TODO commented out because gives random slightly different results per invocation > # cat("--- distribution=\"tdist\" ----------------------------------\n") > # > # set.seed(2016) > # ptit <- ptitanic[sample(1:nrow(ptitanic), size=70), ] > # ptit <- ptit[!is.na(ptit$age), ] > # ptit$survived <- ptit$parch <- ptit$sex <- NULL > # train.frac <- .8 > # set.seed(2016) > # gbm.tdist <- gbm(age~., data=ptit, train.frac=train.frac, > # distribution="tdist", > # n.trees=100, shrinkage=.1) > # par(mfrow=c(2,2), mar=c(3,3,4,1)) > # set.seed(2016) > # w1 <- plotres(gbm.tdist, which=1:2, do.par=FALSE, > # w1.main="gbm.tdist") > # > # cat("w1 plot for gbm.tdist returned (w1.smooth=default):\n") > # print(w1) > # > # set.seed(2016) > # w3 <- plotres(gbm.tdist, which=3, do.par=FALSE, info=TRUE) > # > # # compare to manual residuals > # iused <- 1:(train.frac * nrow(ptit)) > # y <- ptit$age[iused] > # n.trees <- plotmo:::gbm.n.trees(gbm.tdist) > # # TODO following fails in the new version of gbm (version 2.2) (you have to provide newdata) > # # yhat <- predict(gbm.tdist, type="response", n.trees=n.trees) > # yhat <- predict(gbm.tdist, newdata=ptit, type="response", n.trees=n.trees) > # yhat <- yhat[iused] > # plot(yhat, y - yhat, > # main="manual tdist residuals", > # pch=20, ylim=c(-40,40)) > # abline(h=0, col="gray") > # stopifnot(all(yhat == w3$x)) > # stopifnot(all(y - yhat == w3$y)) > # plotmo(gbm.tdist, trace=-1, SHOWCALL=TRUE) > # par(org.par) > > cat("--- distribution=\"bernoulli\" ----------------------------------\n") --- distribution="bernoulli" ---------------------------------- > > set.seed(2016) > ptit <- ptitanic[sample(1:nrow(ptitanic), size=80), ] > ptit$survived <- as.numeric(ptit$survived == "survived") > temp <- ptit$pclass # put pclass at the end so can check ordering of importances > ptit$pclass <- NULL > ptit$pclass <- factor(as.numeric(temp), labels=c("first", "second", "third")) > train.frac <- .9 > set.seed(2016) > gbm.bernoulli <- gbm(survived~., data=ptit, train.frac=train.frac, + distribution="bernoulli", + n.trees=100, shrinkage=.1, cv.folds=3) > par(mfrow=c(2,2)) > par(mar=c(3.5, 3, 2, 0.5)) # small margins and text to pack figs in > par(mgp=c(1.5, .4, 0)) # squash axis annotations > w1 <- plotres(gbm.bernoulli, which=c(1,4), + col=ptit$survived+2, trace=0, do.par=FALSE, + w1.main="gbm.bernoulli") > cat("w1 plot for gbm.bernoulli with cv.folds=3 returned:\n") w1 plot for gbm.bernoulli with cv.folds=3 returned: > print(w1) train test CV OOB 100 24 99 16 > > w3 <- plotres(gbm.bernoulli, which=3, predict.n.trees=40, + ylim=c(-.6, 1), xlim=c(.1, .6), + col=ptit$sex, trace=0, do.par=FALSE, smooth.col=0) > > # compare to manual residuals > iused <- 1:(train.frac * nrow(ptit)) > y <- ptit$survived[iused] > # TODO following fails in the new version of gbm (version 2.2) (you have to provide newdata) > # yhat <- predict(gbm.bernoulli, type="response", n.trees=40) > yhat <- predict(gbm.bernoulli, newdata=ptit, type="response", n.trees=40) > yhat <- yhat[iused] > plot(yhat, y - yhat, col=ptit$sex, + main="manual bernoulli residuals", pch=20, cex=1, + ylim=c(-.6, 1), xlim=c(.1, .6)) > abline(h=0, col="gray") > stopifnot(all(yhat == w3$x)) > stopifnot(all(y - yhat == w3$y)) > par(org.par) > > plotmo(gbm.bernoulli, do.par=2) plotmo grid: sex age sibsp parch pclass male 27 0 0 third > print(summary(gbm.bernoulli)) # will also plot var rel.inf age age 32.307096 sex sex 29.921593 pclass pclass 17.323084 parch parch 13.277759 sibsp sibsp 7.170468 > par(org.par) > > cat("--- distribution=\"huberized\" ----------------------------------\n") --- distribution="huberized" ---------------------------------- > > set.seed(2016) > ptit <- ptitanic[sample(1:nrow(ptitanic), size=100), ] > ptit$survived <- as.numeric(ptit$survived == "survived") > ptit$sibsp <- ptit$parch <- ptit$pclass <- NULL > train.frac <- 1 > set.seed(2016) > gbm.huberized <- gbm(survived~., data=ptit, train.frac=train.frac, + distribution="huberized", + n.trees=200, shrinkage=.1) > par(mfrow=c(2,2)) > par(mar=c(3.5, 3, 2, 0.5)) # small margins and text to pack figs in > par(mgp=c(1.5, .4, 0)) # squash axis annotations > w1 <- plotres(gbm.huberized, which=c(1,4), + col=ptit$survived+2, trace=0, do.par=FALSE, + w1.main="gbm.huberized") Warning: plot_gbm: cannot plot OOB curve (it has some non-finite values) > cat("w1 plot for gbm.huberized returned (smooth=default):\n") w1 plot for gbm.huberized returned (smooth=default): > print(w1) train test CV OOB 169 0 0 0 > > # TODO huberized residuals look weird > w3 <- plotres(gbm.huberized, which=3, predict.n.trees=40, + col=ptit$sex, trace=0, do.par=FALSE, smooth.col=0) > > # compare to manual residuals > iused <- 1:(train.frac * nrow(ptit)) > y <- ptit$survived[iused] > # TODO following fails in the new version of gbm (version 2.2) (you have to provide newdata) > # yhat <- predict(gbm.huberized, type="response", n.trees=40) > yhat <- predict(gbm.huberized, newdata=ptit, type="response", n.trees=40) > yhat <- yhat[iused] > plot(yhat, y - yhat, col=ptit$sex, ylim=c(-2.5, 2.5), + main="manual huberized residuals", pch=20) > abline(h=0, col="gray") > stopifnot(all(yhat == w3$x)) > stopifnot(all(y - yhat == w3$y)) > par(org.par) > > plotmo(gbm.huberized, do.par=2) plotmo grid: sex age male 28 > print(summary(gbm.huberized)) # will also plot var rel.inf age age 68.12613 sex sex 31.87387 > par(org.par) > > cat("--- distribution=\"adaboost\" ----------------------------------\n") --- distribution="adaboost" ---------------------------------- > > set.seed(2016) > ptit <- ptitanic[sample(1:nrow(ptitanic), size=100), ] > ptit$survived <- as.numeric(ptit$survived == "survived") > ptit$sibsp <- ptit$parch <- ptit$pclass <- NULL > train.frac <- .8 > set.seed(2016) > gbm.adaboost <- gbm(survived~., data=ptit, train.frac=train.frac, + distribution="adaboost", + n.trees=150, shrinkage=.01) > par(mfrow=c(2,2)) > par(mar=c(3.5, 3, 2, 0.5)) # small margins and text to pack figs in > par(mgp=c(1.5, .4, 0)) # squash axis annotations > w1 <- plotres(gbm.adaboost, which=c(1,4), + col=ptit$survived+2, trace=0, do.par=FALSE, + w1.main="gbm.adaboost") > cat("w1 plot for gbm.adaboost returned (smooth=default):\n") w1 plot for gbm.adaboost returned (smooth=default): > print(w1) train test CV OOB 150 150 0 117 > > w3 <- plotres(gbm.adaboost, which=3, predict.n.trees=40, + col=ptit$sex, trace=0, do.par=FALSE, smooth.col=0) > > # compare to manual residuals > iused <- 1:(train.frac * nrow(ptit)) > y <- ptit$survived[iused] > # TODO following fails in the new version of gbm (version 2.2) (you have to provide newdata) > # yhat <- predict(gbm.adaboost, type="response", n.trees=40) > yhat <- predict(gbm.adaboost, newdata=ptit, type="response", n.trees=40) > yhat <- yhat[iused] > plot(yhat, y - yhat, col=ptit$sex, + main="manual adaboost residuals", pch=20) > abline(h=0, col="gray") > stopifnot(all(yhat == w3$x)) > stopifnot(all(y - yhat == w3$y)) > par(org.par) > > plotmo(gbm.adaboost, do.par=2) plotmo grid: sex age male 27.5 > print(summary(gbm.adaboost)) # will also plot var rel.inf sex sex 75.09661 age age 24.90339 > par(org.par) > > # test gbm multinomial model, also test very small number of trees in plot_gbm > > data(iris) > set.seed(2016) > gbm.iris <- gbm(Species~., data=iris, distribution="multinomial", n.tree=5) Warning: Setting `distribution = "multinomial"` is ill-advised as it is currently broken. It exists only for backwards compatibility. Use at your own risk. > expect.err(try(plotres(gbm.iris)), + "gbm distribution=\"multinomial\" is not yet supported") Error : gbm distribution="multinomial" is not yet supported (A direct call to plot_gbm may work) Got expected error from try(plotres(gbm.iris)) > expect.err(try(plotmo(gbm.iris)), + "gbm distribution=\"multinomial\" is not yet supported") Error : gbm distribution="multinomial" is not yet supported (A direct call to plot_gbm may work) Got expected error from try(plotmo(gbm.iris)) > plot_gbm(gbm.iris) > > # TODO following fails in the new version of gbm (version 2.2) > # (distribution "multinomial" is no longer supported) > # > # cat("--- distribution=\"multinomial\" ----------------------------------\n") > # > # set.seed(2016) > # ptit <- ptitanic[sample(1:nrow(ptitanic), size=500), ] > # set.seed(2016) > # gbm.multinomial <- gbm(pclass~., > # data=ptit, train.frac=.7, > # distribution="multinomial", > # n.trees=100, shrinkage=.1) > # > # w1 <- plot_gbm(gbm.multinomial, main="gbm.multinomial", smooth=T) > # cat("plot_gbm for gbm.multinomial returned (smooth=TRUE):\n") > # print(w1) > # > # expect.err(try(plotres(gbm.multinomial)), > # "gbm distribution=\"multinomial\" is not yet supported") > # > # expect.err(try(plotmo(gbm.multinomial)), > # "gbm distribution=\"multinomial\" is not yet supported") > > # cat("--- gbmt distribution=\"Gaussian\", formula interface ----------------------------------\n") > # > # set.seed(2016) > # ptit <- ptitanic[sample(1:nrow(ptitanic), size=70), ] # small data for fast test > # set.seed(2016) > # # # TODO bug in gbm: following causes error: survived is not of type numeric, ordered, or factor > # # ptit$survived <- ptit$survived == "survived" > # ptit <- ptit[!is.na(ptit$age), ] > # # TODO change this to build same model as gbm.gaussian > # train_params <- > # training_params(num_trees = 50, > # shrinkage = 0.1, > # bag_fraction = 0.5, > # num_train = round(.8 * nrow(ptit))) > # par(mfrow=c(2,2), mar=c(3,3,4,1)) > # set.seed(2016) > # gbmt.gaussian <- gbmt(age~., data=ptit, > # distribution=gbm_dist("Gaussian"), > # train_params = train_params, > # is_verbose = FALSE) > # expect.err(try(plotres(gbmt.gaussian)), > # "use keep.data=TRUE in the call to gbm") > # set.seed(2016) > # gbmt.gaussian <- gbmt(age~., data=ptit, > # distribution=gbm_dist("Gaussian"), > # train_params = train_params, > # is_verbose = FALSE, keep_gbm_data=TRUE) > # w1 <- plotres(gbmt.gaussian, which=1, do.par=FALSE, w1.smooth=TRUE, > # w1.main="gbmt.gaussian") > # cat("w1 plot for gbmt.gaussian returned (w1.smooth=TRUE):\n") > # print(w1) > # plot(0, 0) # dummy plot > # set.seed(2016) > # w3 <- plotres(gbmt.gaussian, which=3, do.par=FALSE, info=TRUE, > # smooth.col=0, col=ptit$sex, # ylim=c(-40,40), > # wmain="nresponse=1") > # > # # compare to manual residuals > # iused <- 1:(train.frac * nrow(ptit)) > # y <- ptit$age[iused] > # n.trees <- plotmo:::gbm.n.trees(gbmt.gaussian) > # # TODO following fails in the new version of gbm (version 2.2) (you have to provide newdata) > # # yhat <- predict(gbmt.gaussian, type="response", n.trees=n.trees) > # yhat <- predict(gbmt.gaussian, newdata=ptit, type="response", n.trees=n.trees) > # yhat <- yhat[iused] > # plot(yhat, y - yhat, > # col=ptit$sex[iused], main="manual gaussian residuals", > # pch=20, ylim=c(-40,40)) > # abline(h=0, col="gray") > # stopifnot(all(yhat == w3$x)) > # stopifnot(all(y - yhat == w3$y)) > # par(org.par) > # > # w1 <- plotres(gbmt.gaussian, predict.n.trees=13, w1.grid.col=1, trace=1, SHOWCALL=TRUE, > # w1.smooth=TRUE, > # w1.main="predict.n.trees=13 w1.grid.col=1") > # cat("second w1 plot for gbmt.gaussian returned (w1.smooth=TRUE):\n") > # print(w1) > # plotmo(gbmt.gaussian, trace=-1, SHOWCALL=TRUE) > # > # par(org.par) > # > # cat("--- distribution=\"bernoulli\" ----------------------------------\n") > # > # set.seed(2016) > # ptit <- ptitanic[sample(1:nrow(ptitanic), size=80), ] > # ptit$survived <- ptit$survived == "survived" > # temp <- ptit$pclass # put pclass at the end so can check ordering of importances > # ptit$pclass <- NULL > # ptit$pclass <- factor(as.numeric(temp), labels=c("first", "second", "third")) > # # TODO change this to build same model as gbm.bernoulli > # train_params <- > # training_params(num_trees = 100, > # shrinkage = 0.1, > # bag_fraction = 0.5, > # num_train = round(.8 * nrow(ptit))) > # set.seed(2016) > # gbmt.bernoulli <- gbmt(survived~., data=ptit, > # distribution=gbm_dist("Bernoulli"), > # train_params = train_params, > # cv_folds = 3, > # is_verbose = FALSE, keep_gbm_data=TRUE) > # par(mfrow=c(2,2)) > # par(mar=c(3.5, 3, 2, 0.5)) # small margins and text to pack figs in > # par(mgp=c(1.5, .4, 0)) # squash axis annotations > # w1 <- plotres(gbmt.bernoulli, which=c(1,4), > # col=ptit$survived+2, trace=0, do.par=FALSE, > # w1.main="gbmt.bernoulli") > # cat("w1 plot for gbmt.bernoulli with cv.folds=3 returned:\n") > # print(w1) > # > # w3 <- plotres(gbmt.bernoulli, which=3, predict.n.trees=40, > # ylim=c(-.6, 1), xlim=c(.1, .6), > # col=ptit$sex, trace=0, do.par=FALSE, smooth.col=0) > # > # # compare to manual residuals > # iused <- 1:(train.frac * nrow(ptit)) > # y <- ptit$survived[iused] > # # TODO following fails in the new version of gbm (version 2.2) (you have to provide newdata) > # # yhat <- predict(gbmt.bernoulli, type="response", n.trees=40) > # yhat <- predict(gbmt.bernoulli, newdata=ptit, type="response", n.trees=40) > # yhat <- yhat[iused] > # plot(yhat, y - yhat, col=ptit$sex, > # main="manual bernoulli residuals", pch=20, cex=1, > # ylim=c(-.6, 1), xlim=c(.1, .6)) > # abline(h=0, col="gray") > # stopifnot(all(yhat == w3$x)) > # stopifnot(all(y - yhat == w3$y)) > # par(org.par) > # > # plotmo(gbmt.bernoulli, do.par=2) > # print(summary(gbmt.bernoulli)) # will also plot > # par(org.par) > > cat("--- gbm3: distribution=\"gaussian\", formula interface ----------------------------------\n") --- gbm3: distribution="gaussian", formula interface ---------------------------------- > > library(gbm3) Attaching package: 'gbm3' The following objects are masked from 'package:gbm': gbm, gbm.fit, gbm.perf > > set.seed(2016) > ptit <- ptitanic[sample(1:nrow(ptitanic), size=70), ] # small data for fast test > set.seed(2016) > # # TODO bug in gbm3: 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) > gbm3.gaussian <- gbm3::gbm(age~., data=ptit, train.frac=train.frac, + distribution="gaussian", + n.trees=50, shrinkage=.1, keep.data=FALSE) > expect.err(try(plotres(gbm3.gaussian)), "use keep_gbm_data=TRUE in the call to gbm") Error : use keep_gbm_data=TRUE in the call to gbmt (object$gbm_data_obj is NULL) Got expected error from try(plotres(gbm3.gaussian)) > set.seed(2016) > gbm3.gaussian <- gbm3::gbm(age~., data=ptit, train.frac=train.frac, + distribution="gaussian", + n.trees=50, shrinkage=.1) > par(mfrow=c(2,2), mar=c(3,3,4,1)) > w1 <- plotres(gbm3.gaussian, which=1, do.par=FALSE, w1.smooth=TRUE, + w1.main="gbm3.gaussian") > cat("w1 plot for gbm3.gaussian returned (w1.smooth=TRUE):\n") w1 plot for gbm3.gaussian returned (w1.smooth=TRUE): > print(w1) train test CV OOB 50 1 0 12 > plot(0, 0) # dummy plot > w3 <- plotres(gbm3.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(gbm3.gaussian) > # TODO following fails in the new version of gbm (version 2.2) (you have to provide newdata) > # yhat <- predict(gbm3.gaussian, type="response", n.trees=n.trees) > yhat <- predict(gbm3.gaussian, newdata=ptit, type="response", n.trees=n.trees) > yhat <- yhat[iused] > plot(yhat, y - yhat, + col=ptit$sex[iused], main="manual gaussian residuals", + pch=20, ylim=c(-40,40)) > abline(h=0, col="gray") > stopifnot(all(yhat == w3$x)) > stopifnot(all(y - yhat == w3$y)) > par(org.par) > > w1 <- plotres(gbm3.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") stats::residuals(object=GBMFit.object, type="response") residuals() was unsuccessful, will use predict() instead stats::predict(GBMFit.object, data.frame[3,5], type="response", n.trees=13) stats::fitted(object=GBMFit.object) fitted() was unsuccessful, will use predict() instead plot_gbm(GBMFit.object, main="predict.n.trees=13 w1.grid.col=1", n.trees=13, grid.col=1, smooth=TRUE) training rsq 0.23 > cat("second w1 plot for gbm3.gaussian returned (w1.smooth=TRUE):\n") second w1 plot for gbm3.gaussian returned (w1.smooth=TRUE): > print(w1) train test CV OOB 50 1 0 12 > plotmo(gbm3.gaussian, trace=-1, SHOWCALL=TRUE) > # plotmo(gbm3.gaussian, trace=-1, all1=TRUE, SHOWCALL=TRUE) > # plotmo(gbm3.gaussian, trace=-1, all2=TRUE, SHOWCALL=TRUE) > > cat("--- gbm3: distribution=\"gaussian\", xy interface ----------------------------------\n") --- gbm3: distribution="gaussian", xy interface ---------------------------------- > > y = ptit$age > x = ptit[,c(1,2,3,5,6)] > train_params=gbm3::training_params(num_trees=100, + interaction_depth=2, + min_num_obs_in_node=3, + shrinkage=0.1, bag_fraction=0.5, + id=seq_len(nrow(x)), num_train=round(0.5 * nrow(x)), + num_features=ncol(x)) > gbm3fit <- gbm3::gbmt_fit(x, y, train_params=train_params, + keep_gbm_data=TRUE, dist=gbm_dist("Gaussian")) > plotmo(gbm3fit, trace=-1, SHOWCALL=TRUE) > plotres(gbm3fit, trace=-1, SHOWCALL=TRUE) > > cat("--- gbm3: large number of variables ----------------------------------\n") --- gbm3: large number of variables ---------------------------------- > > set.seed(2024) > N <- 1000 > > X <- data.frame(X1=runif(N), X2=2*runif(N), X3=3*runif(N), + X4=runif(N), X5=2*runif(N), X6=3*runif(N), + X7=runif(N), X8=2*runif(N), X9=3*runif(N), + X10=runif(N), X11=2*runif(N), X12=3*runif(N), + X13=runif(N), X14=2*runif(N), X15=3*runif(N)) > > # Y <- sample(c(0, 1), N, replace = TRUE) > set.seed(2024) > Y <- sqrt(X[,1]) + + sqrt(X[,2]) + + sqrt(X[,3]) + + sqrt(X[,4]) + + sqrt(X[,5]) + + sqrt(X[,6]) + + .5 * sqrt(X[,8]) + + sqrt(X[,9]) + + sqrt(X[,10]) + + sqrt(X[,11]) + + sqrt(X[,12]) > > data <- data.frame(Y, X) > set.seed(2024) > gbm3.big <- gbm3::gbm(Y~., data=data, shrinkage=0.1, dist="gaussian") > y = data[,1] > x = data[,2:ncol(data)] > train_params=gbm3::training_params(num_trees=100, + interaction_depth=3, + min_num_obs_in_node=10, + shrinkage=0.1, bag_fraction=0.5, + id=seq_len(nrow(x)), num_train=round(0.5 * nrow(x)), + num_features=ncol(x)) > gbm3fit.big <- gbm3::gbmt_fit(x, y, train_params=train_params, keep_gbm_data=TRUE, dist=gbm_dist("Gaussian")) > > set.seed(2024) > plotmo(gbm3.big, SHOWCALL=TRUE) plotmo grid: X1 X2 X3 X4 X5 X6 X7 0.5143486 0.9627323 1.474525 0.5117489 0.9737853 1.50762 0.4913198 X8 X9 X10 X11 X12 X13 X14 X15 1.009313 1.496057 0.5009011 0.9942378 1.568558 0.5078663 0.9544786 1.408739 > plotmo(gbm3.big, all1=TRUE, all2=TRUE, caption="all1=TRUE, 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 0.5143486 0.9627323 1.474525 0.5117489 0.9737853 1.50762 0.4913198 X8 X9 X10 X11 X12 X13 X14 X15 1.009313 1.496057 0.5009011 0.9942378 1.568558 0.5078663 0.9544786 1.408739 > plotmo(gbm3.big, all1=TRUE, all2=2, caption="all1=TRUE, all2=2") plotmo grid: X1 X2 X3 X4 X5 X6 X7 0.5143486 0.9627323 1.474525 0.5117489 0.9737853 1.50762 0.4913198 X8 X9 X10 X11 X12 X13 X14 X15 1.009313 1.496057 0.5009011 0.9942378 1.568558 0.5078663 0.9544786 1.408739 > plotres(gbm3.big, trace=-1, SHOWCALL=TRUE) > > set.seed(2024) > plotmo(gbm3fit.big, SHOWCALL=TRUE) plotmo grid: X1 X2 X3 X4 X5 X6 X7 0.5223775 0.9345499 1.439748 0.5139633 0.98243 1.518506 0.4884308 X8 X9 X10 X11 X12 X13 X14 X15 1.005225 1.582743 0.5212554 0.9505451 1.60459 0.5136175 0.9552039 1.413134 > plotmo(gbm3fit.big, all1=TRUE, caption="all1=TRUE") plotmo grid: X1 X2 X3 X4 X5 X6 X7 0.5223775 0.9345499 1.439748 0.5139633 0.98243 1.518506 0.4884308 X8 X9 X10 X11 X12 X13 X14 X15 1.005225 1.582743 0.5212554 0.9505451 1.60459 0.5136175 0.9552039 1.413134 > plotmo(gbm3fit.big, all2=TRUE, caption="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 0.5223775 0.9345499 1.439748 0.5139633 0.98243 1.518506 0.4884308 X8 X9 X10 X11 X12 X13 X14 X15 1.005225 1.582743 0.5212554 0.9505451 1.60459 0.5136175 0.9552039 1.413134 > plotmo(gbm3fit.big, 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 0.5223775 0.9345499 1.439748 0.5139633 0.98243 1.518506 0.4884308 X8 X9 X10 X11 X12 X13 X14 X15 1.005225 1.582743 0.5212554 0.9505451 1.60459 0.5136175 0.9552039 1.413134 > plotres(gbm3.big, trace=-1, SHOWCALL=TRUE) > > source("test.epilog.R") plotmo/inst/slowtests/make.README.bat0000755000176200001440000000024714655214117017165 0ustar liggesusers@rem Create README.html from README.md "C:\PROGRA~1\R\R-4.4.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.epilog.R0000644000176200001440000000034013725307662017200 0ustar liggesusers# test.epilog.R if(!interactive()) { dev.off() # finish postscript plot q(runLast=FALSE) # needed else R prints the time on exit # (R2.5 and higher) which messes up the diffs } plotmo/inst/slowtests/test.modguide.bat0000755000176200001440000000154714655214117020073 0ustar liggesusers@rem test.modguide.bat: test model1 and model2 (linmod examples) in modguide.pdf @echo test.modguide.bat @"C:\PROGRA~1\R\R-4.4.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.fac.bat0000755000176200001440000000154214655214117017022 0ustar liggesusers@rem test.fac.bat: test factor plotting in plotmo. This also tests swapxy, xflip, and yflip @rem Stephen Milborrow, Berea Mar 2011 @echo test.fac.bat @"C:\PROGRA~1\R\R-4.4.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.plotmo.dots.Rout.save0000644000176200001440000000711314567071010021663 0ustar liggesusers> # test.dots.plotmo.R: test dots functions with the plotmo and earth libraries > > source("test.prolog.R") > library(plotmo) Loading required package: Formula Loading required package: plotrix > library(earth) > data(ozone1) > options(warn=1) # print warnings as they occur > > a <- earth(O3~., data=ozone1, degree=2) > expect.err(try(plotmo(a, persp.s=99)), "'s' matches both the 'sub' and 'scale' arguments of persp()") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 Error : 's' matches both the 'sub' and 'scale' arguments of persp() Got expected error from try(plotmo(a, persp.s = 99)) > > # Commented out because we now silently drop partial plot args like cex.l > # expect.err(try(plotmo(a, cex.l=.8, cex.la=.9)), "arguments 'cex.l' and 'cex.la' both match 'cex.lab' in draw.plot_degree1") > # expect.err(try(plotmo(a, persp.shad=1, persp.sh=2)), "'persp.shad' and 'persp.sh' both match the 'shade' argument of persp()") > > options(warn=2) # treat warnings as errors > > # Commented out because we now silently drop partial plot args like cex.l > # expect.err(try(plotmo(a, cex.l=.8)), "\"cex.l\" is not a graphical parameter") > # expect.err(try(plotmo(a, cex.lxx=.8)), "\"cex.lxx\" is not a graphical parameter") > # expect.err(try(plotmo(a, cex.labx=.8)), "\"cex.labx\" is not a graphical parameter") > # expect.err(try(plotmo(a, cex.l=.8, cex.lab=.9)), "\"cex.l\" is not a graphical parameter") > > expect.err(try(plotmo(a, nonesuch=.8)), "predict.earth ignored argument 'nonesuch'") stats::predict(earth.object, NULL, type="response", nonesuch=0.8) Error : (converted from warning) predict.earth ignored argument 'nonesuch' Got expected error from try(plotmo(a, nonesuch = 0.8)) > expect.err(try(plotmo(a, lw=2)), "predict.earth ignored argument 'lw'") stats::predict(earth.object, NULL, type="response", lw=2) Error : (converted from warning) predict.earth ignored argument 'lw' Got expected error from try(plotmo(a, lw = 2)) > options(warn=1) > > # test main, xlab, ylab, etc. arguments with recycling > a <- earth(O3~., data=ozone1, degree=2) > plotmo(a, caption="test main, xlab, ylab, ticktype arguments", + main=c("main1", "main2", "main3", "main4"), xlab=c("x1", "x2"), + persp.nticks=2, persp.ticktype="d", ylab=c("y1", "y2", "y3")) plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > > par(mfrow=c(2,2), mar = c(3,3,3,1), mgp = c(1.5,.5,0), oma=c(0,0,4,0)) > plotmo(a, trace=1, do.par=FALSE, degree1=1, degree2=1, caption="top: standard\nbottom: lwd=2 thresh=.9") # no errors or warnings stats::predict(earth.object, NULL, type="response") stats::fitted(object=earth.object) got model response from model.frame(O3 ~ vh + wind + humidity + temp + ib..., data=call$data, na.action="na.fail") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > plotmo(a, lwd=2, trace=1, thresh=.9, do.par=FALSE, degree1=1, degree2=1) # no errors or warnings stats::predict(earth.object, NULL, type="response", thresh=0.9) stats::fitted(object=earth.object) got model response from model.frame(O3 ~ vh + wind + humidity + temp + ib..., data=call$data, na.action="na.fail") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > > source("test.epilog.R") plotmo/inst/slowtests/test.plotmo.dots.R0000644000176200001440000000365614566064534020222 0ustar liggesusers# test.dots.plotmo.R: test dots functions with the plotmo and earth libraries source("test.prolog.R") library(plotmo) library(earth) data(ozone1) options(warn=1) # print warnings as they occur a <- earth(O3~., data=ozone1, degree=2) expect.err(try(plotmo(a, persp.s=99)), "'s' matches both the 'sub' and 'scale' arguments of persp()") # Commented out because we now silently drop partial plot args like cex.l # expect.err(try(plotmo(a, cex.l=.8, cex.la=.9)), "arguments 'cex.l' and 'cex.la' both match 'cex.lab' in draw.plot_degree1") # expect.err(try(plotmo(a, persp.shad=1, persp.sh=2)), "'persp.shad' and 'persp.sh' both match the 'shade' argument of persp()") options(warn=2) # treat warnings as errors # Commented out because we now silently drop partial plot args like cex.l # expect.err(try(plotmo(a, cex.l=.8)), "\"cex.l\" is not a graphical parameter") # expect.err(try(plotmo(a, cex.lxx=.8)), "\"cex.lxx\" is not a graphical parameter") # expect.err(try(plotmo(a, cex.labx=.8)), "\"cex.labx\" is not a graphical parameter") # expect.err(try(plotmo(a, cex.l=.8, cex.lab=.9)), "\"cex.l\" is not a graphical parameter") expect.err(try(plotmo(a, nonesuch=.8)), "predict.earth ignored argument 'nonesuch'") expect.err(try(plotmo(a, lw=2)), "predict.earth ignored argument 'lw'") options(warn=1) # test main, xlab, ylab, etc. arguments with recycling a <- earth(O3~., data=ozone1, degree=2) plotmo(a, caption="test main, xlab, ylab, ticktype arguments", main=c("main1", "main2", "main3", "main4"), xlab=c("x1", "x2"), persp.nticks=2, persp.ticktype="d", ylab=c("y1", "y2", "y3")) par(mfrow=c(2,2), mar = c(3,3,3,1), mgp = c(1.5,.5,0), oma=c(0,0,4,0)) plotmo(a, trace=1, do.par=FALSE, degree1=1, degree2=1, caption="top: standard\nbottom: lwd=2 thresh=.9") # no errors or warnings plotmo(a, lwd=2, trace=1, thresh=.9, do.par=FALSE, degree1=1, degree2=1) # no errors or warnings source("test.epilog.R") plotmo/inst/slowtests/modguide.model2.R0000644000176200001440000000441213725307662017725 0ustar liggesusers# modguide.model2.R: # # linmod code from Stephen Milborrow "Guidelines for S3 Regression Models" # This is called Model 2 in that document. # ## A simple linear model (extended from Friedrich Leisch's tutorial). ## Functions like print.linmod in the tutorial don't appear in the code below. linmod <- function(...) UseMethod("linmod") linmod.fit <- function(x, y) # internal function, not for the casual user { # first column of x is the intercept (all 1s) y <- as.vector(as.matrix(y)) # necessary when y is a data.frame qx <- qr(x) # QR-decomposition of x coef <- solve.qr(qx, y) # compute (x'x)^(-1) x'y df.residual <- nrow(x) - ncol(x) # degrees of freedom sigma2 <- sum((y - x %*% coef)^2) / df.residual # variance of residuals vcov <- sigma2 * chol2inv(qx$qr) # covar mat is sigma^2 * (x'x)^(-1) colnames(vcov) <- rownames(vcov) <- colnames(x) fitted.values <- qr.fitted(qx, y) names(fitted.values) <- rownames(x) fit <- list(coefficients = coef, residuals = y - fitted.values, fitted.values = fitted.values, vcov = vcov, sigma = sqrt(sigma2), df.residual = df.residual) class(fit) <- "linmod" fit } linmod.default <- function(x, y, ...) { fit <- linmod.fit(cbind("(Intercept)"=1, as.matrix(x)), y) fit$call <- match.call() fit } linmod.formula <- function(formula, data=parent.frame(), ...) { mf <- model.frame(formula=formula, data=data) terms <- attr(mf, "terms") fit <- linmod.fit(model.matrix(terms, mf), model.response(mf)) fit$call <- match.call() fit$terms <- terms fit } predict.linmod <- function(object, newdata=NULL, ...) { if(is.null(newdata)) y <- fitted(object) else { if(is.null(object$terms)) # x,y interface x <- cbind(1, as.matrix(newdata)) else { # formula interface terms <- delete.response(object$terms) x <- model.matrix(terms, model.frame(terms, as.data.frame(newdata))) } y <- as.vector(x %*% coef(object)) } y } plotmo/inst/slowtests/test.c50.bat0000755000176200001440000000142314655214117016656 0ustar liggesusers@rem test.c50.bat: c50 tests for plotmo and plotres @echo test.c50.bat @"C:\PROGRA~1\R\R-4.4.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/test.mlr.Rout.save0000644000176200001440000011036714663413473020213 0ustar liggesusers> # test.mlr.R: test the "mlr" package with plotmo and plotres > # > # TODO mlr is in maintenance mode, add mlr3 support to plotmo? > # TODO generally, plotres residuals for WrappedModel prob models aren't right > > source("test.prolog.R") > library(mlr) Loading required package: ParamHelpers > library(plotmo) Loading required package: Formula Loading required package: plotrix > library(rpart.plot) Loading required package: rpart > library(earth) > # TODO following function is temporary until mlr package is updated > train.with.call <- function(learner, task, subset=NULL, weights=NULL) + { + retval <- train(learner, task, subset, weights) + retval$call <- match.call() + retval + } > > cat("==simple one variable regression model with earth ===============================\n") ==simple one variable regression model with earth =============================== > > data(trees) > trees1 <- trees[,c("Volume", "Girth")] > > task <- makeRegrTask(data=trees1, target="Volume") > lrn <- makeLearner("regr.earth", degree=2) > regr.earth.with.call = train.with.call(lrn, task) > regr.earth = train(lrn, task) > earth <- earth(Volume~., data=trees1, degree=2) > > # SHOWCALL is just a testing thing, so we can see who created the plot on the plot itself > plotres(regr.earth.with.call, SHOWCALL=TRUE) > plotres(regr.earth$learner.model, SHOWCALL=TRUE) > plotres(earth, SHOWCALL=TRUE) > > plotmo(regr.earth.with.call, trace=1, SHOWCALL=TRUE) stats::fitted(object=WrappedModel.object) fitted() was unsuccessful, will use predict() instead got model response from object$y > plotmo(regr.earth$learner.model, trace=1, SHOWCALL=TRUE) stats::predict(earth.object, NULL, type="response") stats::fitted(object=earth.object) got model response from model.frame(Volume ~ Girth, data=call$data, na.action="na.fail") > plotmo(earth, trace=1, SHOWCALL=TRUE) stats::predict(earth.object, NULL, type="response") stats::fitted(object=earth.object) got model response from model.frame(Volume ~ Girth, data=call$data, na.action="na.fail") > > # compare partial dependence plots from mlr and plotmo packages > set.seed(2018) > plotmo(earth, pmethod="partdep", SHOWCALL=TRUE, col=2, pt.col="darkgray", grid.col="lightgray") calculating partdep for Girth > set.seed(2018) > pd <- generatePartialDependenceData(regr.earth, task, "Girth", n=c(50, NA)) Loading required package: mmpf > print(plotPartialDependence(pd, data = getTaskData(task))) Warning in grid.Call.graphics(C_points, x$x, x$y, x$pch, x$size) : semi-transparency is not supported on this device: reported only once per page > > cat("==test error handling if original data is messed up===========================\n") ==test error handling if original data is messed up=========================== > > par(mfrow=c(4,2), mar=c(1.5,2.5,4,1), oma=c(0,0,0,0)) > colnames(trees1) <- c("nonesuch", "Volume") > plotmo(regr.earth$learner.model, do.par=0, degree1=1, degree2=0, main='colnames(trees1) <- c("nonesuch", "Volume")') > plotmo(regr.earth.with.call, do.par=0, degree1=1, degree2=0) > par(org.par) > expect.err(try(plotmo(earth, degree1=1, degree2=0)), "cannot get the original model predictors") Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: object 'Girth' not found (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(plotmo(earth, degree1 = 1, degree2 = 0)) > > cat("==regression model with randomForest (binary response)============================\n") ==regression model with randomForest (binary response)============================ > > library(randomForest) randomForest 4.7-1.1 Type rfNews() to see new features/changes/bug fixes. > library(earth) # for etitanic data > data(etitanic) > set.seed(2018) > # use a logical subset (since we test for numeric subset elsewhere) > # use a small subset so we can see easily if subset is applied or ignored in plots > train.subset <- rnorm(nrow(etitanic)) > 1 # 166 cases ((16% of 1046 cases)) > printf("sum(train.subset) %g (%.0f%% of %g cases)\n", sum(train.subset), + 100 * sum(train.subset) / nrow(etitanic), nrow(etitanic)) sum(train.subset) 166 (16% of 1046 cases) > task.regr.rf <- makeRegrTask(data=etitanic, target="survived") > lrn.regr.rf = makeLearner("regr.randomForest") > set.seed(2018) > regr.rf.with.call = train.with.call(lrn.regr.rf, task.regr.rf, subset=train.subset) Warning in randomForest.default(x = data[["data"]], y = data[["target"]], : The response has five or fewer unique values. Are you sure you want to do regression? > set.seed(2018) > rf <- randomForest(survived~., data=etitanic, subset=train.subset) Warning in randomForest.default(m, y, ...) : The response has five or fewer unique values. Are you sure you want to do regression? > # sanity check that the models are identical > stopifnot(identical(predict(regr.rf.with.call$learner.model), predict(rf))) > > plotres(regr.rf.with.call, info=TRUE, SHOWCALL=TRUE) > # plotres(regr.rf$learner.model, info=TRUE, SHOWCALL=TRUE) # Error: no formula in getCall(object) > plotres(rf, info=TRUE, SHOWCALL=TRUE) > > set.seed(2018) # for repeatable jitter in points (specified with pt.col) > plotmo(regr.rf.with.call, pt.col=2, SHOWCALL=TRUE) plotmo grid: pclass sex age sibsp parch 3rd male 29 0 0 > # plotmo(regr.rf$learner.model, trace=1, SHOWCALL=TRUE) # Error: no formula in getCall(object) > set.seed(2018) > plotmo(rf, pt.col=2, SHOWCALL=TRUE) plotmo grid: pclass sex age sibsp parch 3rd male 29 0 0 > > # compare partial dependence plots > set.seed(2018) > plotmo(regr.rf.with.call, degree1="age", degree2=0, pmethod="partdep", + grid.col="gray", col=2, pt.col="darkgray", SHOWCALL=TRUE) calculating partdep for age > # function from randomForest package > set.seed(2018) > partialPlot(rf, pred.data=etitanic[train.subset,], x.var="age", n.pt=50, ylim=c(0, 1)) > grid() > # function from mlr package > set.seed(2018) > pd <- generatePartialDependenceData(regr.rf.with.call, task.regr.rf, "age", n=c(50, NA)) > print(plotPartialDependence(pd, data = getTaskData(task.regr.rf))) Warning in grid.Call.graphics(C_points, x$x, x$y, x$pch, x$size) : semi-transparency is not supported on this device: reported only once per page > > plotmo(regr.rf.with.call, degree1="pclass", degree2=0, pmethod="partdep", SHOWCALL=TRUE) calculating partdep for pclass > set.seed(2018) > # function from randomForest package > set.seed(2018) > partialPlot(rf, pred.data=etitanic[train.subset,], x.var="pclass", n.pt=50, ylim=c(0, 1)) > grid() > # TODO following fails > pd <- generatePartialDependenceData(regr.rf.with.call, task.regr.rf, "pclass", n=c(50, NA)) > try(print(plotPartialDependence(pd, data = getTaskData(task.regr.rf)))) # Error: Discrete value supplied to continuous scale Error in scale_x_continuous() : Discrete values supplied to continuous scale. ℹ Example values: 1st, 1st, 1st, 1st, and 1st > > cat("==classification model with randomForest (binary response)======================\n") ==classification model with randomForest (binary response)====================== > > set.seed(2018) > library(earth) # for etitanic data > data(etitanic) > etit <- etitanic > etit$survived <- factor(etit$survived, labels=c("notsurvived", "survived")) > > task.classif.rf <- makeClassifTask(data=etit, target="survived") > lrn.classif.rf <- makeLearner("classif.randomForest", predict.type="prob") > set.seed(2018) > classif.rf.with.call <- train.with.call(lrn.classif.rf, task.classif.rf, , subset=train.subset) > set.seed(2018) > rf <- randomForest(survived~., data=etit, method="class", subset=train.subset) > # sanity check that the models are identical > stopifnot(identical(predict(classif.rf.with.call$learner.model), predict(rf))) > > # TODO following causes Error: classif.earth: Setting parameter glm without available description object > # lrn <- makeLearner("classif.earth", degree=2, glm=list(family=binomial)) > > # TODO residuals on WrappedModel don't match direct call to rf model > set.seed(2018) # for repeatable jitter > plotres(classif.rf.with.call, nresponse="prob.survived", SHOWCALL=TRUE, jitter=2) > set.seed(2018) > plotres(classif.rf.with.call$learner.model, type="prob", SHOWCALL=TRUE, jitter=2) > set.seed(2018) > plotres(rf, type="prob", SHOWCALL=TRUE, jitter=2) > > options(warn=2) # treat warnings as errors > expect.err(try(plotmo(classif.rf.with.call)), "Defaulting to nresponse=1, see above messages") predict.WrappedModel[3,3]: prob.notsurvived prob.survived response 5 0.466 0.534 survived 7 0.358 0.642 survived 22 0.028 0.972 survived response is a factor with levels: notsurvived survived predict.WrappedModel returned multiple columns (see above) but nresponse is not specified Use the nresponse argument to specify a column. Example: nresponse=2 Example: nresponse="prob.survived" Error : (converted from warning) Defaulting to nresponse=1, see above messages Got expected error from try(plotmo(classif.rf.with.call)) > options(warn=1) > set.seed(2018) # for repeatable jitter > plotmo(classif.rf.with.call, SHOWCALL=TRUE, nresponse="prob.survived", pt.col=2, trace=2) plotmo trace 2: plotmo(object=classif.rf.with.call, nresponse="prob.survived", pt.col=2, trace=2, SHOWCALL=TRUE) --get.model.env for object with class WrappedModel object call is train.with.call(learner=lrn.classif.rf, task=task.classif.rf, subset=train.subset) assuming the environment of the WrappedModel model is that of plotmo's caller: R_GlobalEnv --plotmo_prolog for WrappedModel object 'classif.rf.with.call' task$task.desc$id for 'classif.rf.with.call' is "etit" --plotmo_prolog for randomForest.formula object object$learner.model Done recursive call in plotmo.prolog for learner.model --plotmo_x for WrappedModel object get.object.x: object$x is usable and has column names pclass sex age sibsp parch plotmo_x returned[166,5]: pclass sex age sibsp parch 5 1st female 25 1 2 7 1st female 63 1 0 22 1st female 47 1 1 ... 1st female 29 0 0 1288 3rd male 51 0 0 factors: pclass sex ----Metadata: plotmo_predict with nresponse=NULL and newdata=NULL plotmo_predict with NULL newdata (nrows=3), using plotmo_x to get the data --plotmo_x for WrappedModel object get.object.x: object$x is usable and has column names pclass sex age sibsp parch plotmo_x returned[166,5]: pclass sex age sibsp parch 5 1st female 25 1 2 7 1st female 63 1 0 22 1st female 47 1 1 ... 1st female 29 0 0 1288 3rd male 51 0 0 factors: pclass sex will use the above data instead of newdata=NULL for predict.WrappedModel predict returned[3,3]: prob.notsurvived prob.survived response 5 0.466 0.534 survived 7 0.358 0.642 survived 22 0.028 0.972 survived response is a factor with levels: notsurvived survived predict after processing with nresponse=NULL is [3,3]: prob.notsurvived prob.survived response 5 0.466 0.534 survived 7 0.358 0.642 survived 22 0.028 0.972 survived response is a factor with levels: notsurvived survived ----Metadata: plotmo_fitted with nresponse=NULL stats::fitted(object=WrappedModel.object) fitted() was unsuccessful, will use predict() instead plotmo_predict with NULL newdata, using plotmo_x to get the data --plotmo_x for WrappedModel object get.object.x: object$x is usable and has column names pclass sex age sibsp parch plotmo_x returned[166,5]: pclass sex age sibsp parch 5 1st female 25 1 2 7 1st female 63 1 0 22 1st female 47 1 1 ... 1st female 29 0 0 1288 3rd male 51 0 0 factors: pclass sex will use the above data instead of newdata=NULL for predict.WrappedModel predict returned[166,3]: prob.notsurvived prob.survived response 5 0.466 0.534 survived 7 0.358 0.642 survived 22 0.028 0.972 survived ... 0.032 0.968 survived 1288 0.906 0.094 notsurvived response is a factor with levels: notsurvived survived predict after processing with nresponse=NULL is [166,3]: prob.notsurvived prob.survived response 5 0.466 0.534 survived 7 0.358 0.642 survived 22 0.028 0.972 survived ... 0.032 0.968 survived 1288 0.906 0.094 notsurvived response is a factor with levels: notsurvived survived got fitted values by calling predict (see above) ----Metadata: plotmo_y with nresponse=NULL --plotmo_y with nresponse=NULL for WrappedModel object get.object.y: object$y is usable and has column name survived plotmo_y returned[166,1]: survived 5 notsurvived 7 survived 22 survived ... survived 1288 notsurvived survived is a factor with levels: notsurvived survived plotmo_y after processing with nresponse=NULL is [166,1]: survived 5 notsurvived 7 survived 22 survived ... survived 1288 notsurvived survived is a factor with levels: notsurvived survived converted nresponse="prob.survived" to nresponse=2 nresponse=2 (was "prob.survived") ncol(fitted) 3 ncol(predict) 1 ncol(y) 1 ----Metadata: plotmo_y with nresponse=2 nresponse=2 but for plotmo_y using nresponse=1 because ncol(y) == 1 --plotmo_y with nresponse=1 for WrappedModel object get.object.y: object$y is usable and has column name survived got model response from object$y the response is a factor but could not get the family of the WrappedModel model plotmo_y returned[166,1]: survived 5 notsurvived 7 survived 22 survived ... survived 1288 notsurvived survived is a factor with levels: notsurvived survived converted to numeric from factor with levels "notsurvived" "survived" plotmo_y after processing with nresponse=1 is [166,1]: survived 1 1 2 2 3 2 ... 2 166 1 got response name "prob.survived" from yhat got resp.levs from yfull response levels: notsurvived survived ----Metadata: done number of x values: pclass 3 sex 2 age 60 sibsp 5 parch 5 ----plotmo_singles for WrappedModel object randomForest built with importance=FALSE, ranking variables on MeanDecreaseGini plotmo.singles(object$learner.model) succeeded singles: 1 pclass, 2 sex, 3 age, 4 sibsp, 5 parch ----plotmo_pairs for WrappedModel object plotmo.pairs(object$learner.model) succeeded pairs: [,1] [,2] [1,] "1 pclass" "2 sex" [2,] "1 pclass" "3 age" [3,] "1 pclass" "4 sibsp" [4,] "1 pclass" "5 parch" [5,] "2 sex" "3 age" [6,] "2 sex" "4 sibsp" [7,] "2 sex" "5 parch" [8,] "3 age" "4 sibsp" [9,] "3 age" "5 parch" [10,] "4 sibsp" "5 parch" graphics::par(mfrow=c(4,4), mgp=c(1.5,0.4,0), tcl=-0.3, font.main=2, mar=c(3,2,1.2,0.8), oma=c(0,0,4,0), cex.main=1.1, cex.lab=1, cex.axis=1, cex=0.66) ----Figuring out ylim ylim c(-0.1, 1.1) clip TRUE --plot.degree1(draw.plot=TRUE) plotmo grid: pclass sex age sibsp parch 3rd male 29 0 0 degree1 plot1 (pmethod "plotmo") variable pclass newdata[3,5]: pclass sex age sibsp parch 1 1st male 29 0 0 2 2nd male 29 0 0 3 3rd male 29 0 0 factors: pclass sex predict returned[3,3]: prob.notsurvived prob.survived response 1 0.872 0.128 notsurvived 2 0.904 0.096 notsurvived 3 0.928 0.072 notsurvived response is a factor with levels: notsurvived survived predict returned[3,1] after selecting nresponse=2: prob.survived 1 0.128 2 0.096 3 0.072 predict after processing with nresponse=2 is [3,1]: prob.survived 1 0.128 2 0.096 3 0.072 graphics::plot.default(x=factor.object, y=c(0.128,0.096,0...), type="n", main="1 pclass", xlab="", ylab="", xaxt="n", yaxt="s", xlim=c(0.6,3.4), ylim=c(-0.1,1.1)) Will shift and scale displayed points specified by pt.col: yshift -1 yscale 1 graphics::plot(x=factor.object, y=c(0.128,0.096,0...), xaxt="n", yaxt="s", add=TRUE, lty=1, lwd=1) Reducing trace level for subsequent degree1 plots degree1 plot2 (pmethod "plotmo") variable sex Will shift and scale displayed points specified by pt.col: yshift -1 yscale 1 degree1 plot3 (pmethod "plotmo") variable age Will shift and scale displayed points specified by pt.col: yshift -1 yscale 1 degree1 plot4 (pmethod "plotmo") variable sibsp Will shift and scale displayed points specified by pt.col: yshift -1 yscale 1 degree1 plot5 (pmethod "plotmo") variable parch Will shift and scale displayed points specified by pt.col: yshift -1 yscale 1 --plot.degree2(draw.plot=TRUE) degree2 plot1 (pmethod "plotmo") variables pclass:sex newdata[6,5]: pclass sex age sibsp parch 1 1st female 29 0 0 2 2nd female 29 0 0 3 3rd female 29 0 0 ... 1st male 29 0 0 6 3rd male 29 0 0 factors: pclass sex predict returned[6,3]: prob.notsurvived prob.survived response 1 0.032 0.968 survived 2 0.098 0.902 survived 3 0.890 0.110 notsurvived ... 0.872 0.128 notsurvived 6 0.928 0.072 notsurvived response is a factor with levels: notsurvived survived predict returned[6,1] after selecting nresponse=2: prob.survived 1 0.968 2 0.902 3 0.110 ... 0.128 6 0.072 predict after processing with nresponse=2 is [6,1]: prob.survived 1 0.968 2 0.902 3 0.110 ... 0.128 6 0.072 persp(pclass:sex) theta 145 Reducing trace level for subsequent degree2 plots degree2 plot2 (pmethod "plotmo") variables pclass:age persp(pclass:age) theta 235 degree2 plot3 (pmethod "plotmo") variables pclass:sibsp persp(pclass:sibsp) theta 55 degree2 plot4 (pmethod "plotmo") variables pclass:parch persp(pclass:parch) theta 55 degree2 plot5 (pmethod "plotmo") variables sex:age persp(sex:age) theta 145 degree2 plot6 (pmethod "plotmo") variables sex:sibsp persp(sex:sibsp) theta 55 degree2 plot7 (pmethod "plotmo") variables sex:parch persp(sex:parch) theta 55 degree2 plot8 (pmethod "plotmo") variables age:sibsp persp(age:sibsp) theta 145 degree2 plot9 (pmethod "plotmo") variables age:parch persp(age:parch) theta 145 degree2 plot10 (pmethod "plotmo") variables sibsp:parch persp(sibsp:parch) theta 55 > set.seed(2018) > plotmo(classif.rf.with.call$learner.model, SHOWCALL=TRUE, type="prob", pt.col=2) plotmo grid: pclass sex age sibsp parch 3rd male 29 0 0 > set.seed(2018) > # note that in the following, get.y.shift.scale (in plotmo code) rescales the plotted y to 0..1 > plotmo(rf, SHOWCALL=TRUE, type="prob", pt.col="gray") plotmo grid: pclass sex age sibsp parch 3rd male 29 0 0 > set.seed(2018) > # in following graph, note that get.y.shift.scale doesn't rescale the plotted y because ylim=c(0,2) > plotmo(rf, SHOWCALL=TRUE, type="prob", ylim=c(0,2), pt.col="gray") plotmo grid: pclass sex age sibsp parch 3rd male 29 0 0 > > # compare partial dependence plots > set.seed(2018) > plotmo(rf, type="prob", degree1="pclass", degree2=0, pmethod="partdep", pt.col=2, SHOWCALL=TRUE) calculating partdep for pclass > set.seed(2018) > plotmo(rf, degree1="pclass", degree2=0, pmethod="partdep", pt.col=2, SHOWCALL=TRUE) calculating partdep for pclass > set.seed(2018) > # TODO following fails > pd <- generatePartialDependenceData(classif.rf.with.call, task.classif.rf, "pclass", n=c(50, NA)) > try(print(plotPartialDependence(pd, data = getTaskData(task.classif.rf)))) # Error: Discrete value supplied to continuous scale Error in scale_x_continuous() : Discrete values supplied to continuous scale. ℹ Example values: 1st, 1st, 1st, 1st, and 1st > > plotmo(rf, type="prob", nresponse="notsurvived", degree1="age", degree2=0, + pmethod="partdep", ylim=c(.3,.75), nrug=TRUE, grid.col="gray") # looks plausible calculating partdep for age > set.seed(2018) > pd <- generatePartialDependenceData(classif.rf.with.call, task.classif.rf, "age", n=c(50, NA)) > print(plotPartialDependence(pd, data = getTaskData(task.classif.rf))) Warning in grid.Call.graphics(C_segments, x$x0, x$y0, x$x1, x$y1, x$arrow) : semi-transparency is not supported on this device: reported only once per page > > cat("==examples from plotmo-notes.pdf ===============================================\n") ==examples from plotmo-notes.pdf =============================================== > > #-- Regression model with mlr ------------------------------------------- > > library(mlr) > library(plotmo) > lrn <- makeLearner("regr.svm") > fit1.with.call <- train.with.call(lrn, bh.task) > fit1 <- train(lrn, bh.task) > > # generate partial dependence plots for all variables > # we use "apartdep" and not "partdep" to save testing time > plotmo(fit1.with.call, pmethod="apartdep") calculating apartdep for crim calculating apartdep for zn calculating apartdep for indus calculating apartdep for chas calculating apartdep for nox calculating apartdep for rm calculating apartdep for age calculating apartdep for dis calculating apartdep for rad calculating apartdep for tax calculating apartdep for ptratio calculating apartdep for b calculating apartdep for lstat > plotmo(fit1$learner.model, pmethod="apartdep") calculating apartdep for crim calculating apartdep for zn calculating apartdep for indus calculating apartdep for chas calculating apartdep for nox calculating apartdep for rm calculating apartdep for age calculating apartdep for dis calculating apartdep for rad calculating apartdep for tax calculating apartdep for ptratio calculating apartdep for b calculating apartdep for lstat > > # generate partial dependence plot for just "lstat" > set.seed(2018) # so slight jitter on pt.col points in plotmo doesn't change across test runs > plotmo(fit1.with.call, + degree1="lstat", # what predictor to plot + degree2=0, # no interaction plots + pmethod="partdep", # generate partial dependence plot + pt.col=2, grid.col="gray", # optional bells and whistles + nrug=TRUE) # rug ticks along the bottom calculating partdep for lstat > set.seed(2018) # so slight jitter on pt.col points in plotmo doesn't change across test runs > plotmo(fit1$learner.model, + degree1="lstat", # what predictor to plot + degree2=0, # no interaction plots + pmethod="partdep", # generate partial dependence plot + pt.col=2, grid.col="gray", # optional bells and whistles + nrug=TRUE) # rug ticks along the bottom calculating partdep for lstat > > # compare to the function provided by the mlr package > set.seed(2018) > pd <- generatePartialDependenceData(fit1, bh.task, "lstat", n=c(50, NA)) > print(plotPartialDependence(pd, data = getTaskData(bh.task))) Warning in grid.Call.graphics(C_points, x$x, x$y, x$pch, x$size) : semi-transparency is not supported on this device: reported only once per page > # # TODO following fails: Error: Discrete value supplied to continuous scale > # pd <- generatePartialDependenceData(fit1, bh.task, "chas", n=c(50, NA)) > # plotPartialDependence(pd, data = getTaskData(bh.task)) > > #-- Classification model with mlr --------------------------------------- > > lrn.classif.rpart <- makeLearner("classif.rpart", predict.type = "prob", minsplit = 10) > fit2.with.call <- train.with.call(lrn.classif.rpart, iris.task) > fit2 <- train(lrn.classif.rpart, iris.task) > > # generate partial dependence plots for all variables > # TODO plotmo can plot the response for only one class at a time > plotmo(fit2.with.call, + nresponse="prob.virginica", # what response to plot + # type="prob", # type gets passed to predict.rpart + pmethod="apartdep") # generate partial dependence plot calculating apartdep for Petal.Length calculating apartdep for Petal.Width calculating apartdep for Petal.Length:Petal.Width 01234567890 > > plotmo(fit2$learner.model, + nresponse="virginica", # what response to plot + type="prob", # type gets passed to predict.rpart + pmethod="apartdep") # generate partial dependence plot calculating apartdep for Petal.Length calculating apartdep for Petal.Width calculating apartdep for Petal.Length:Petal.Width 01234567890 > > # generate partial dependence plot for just "Petal.Length" > plotmo(fit2.with.call, + degree1="Petal.Length", # what predictor to plot + degree2=0, # no interaction plots + nresponse="prob.virginica", # what response to plot + # type="prob", # type gets passed to predict.rpart + pmethod="apartdep") # generate partial dependence plot calculating apartdep for Petal.Length > > plotmo(fit2$learner.model, + degree1="Petal.Length", # what predictor to plot + degree2=0, # no interaction plots + nresponse="virginica", # what response to plot + type="prob", # type gets passed to predict.rpart + pmethod="apartdep") # generate partial dependence plot calculating apartdep for Petal.Length > > # compare to the function provided by the mlr package > set.seed(2018) > pd <- generatePartialDependenceData(fit2, iris.task, "Petal.Length", n=c(50, NA)) > print(plotPartialDependence(pd, data = getTaskData(iris.task))) Warning in grid.Call.graphics(C_segments, x$x0, x$y0, x$x1, x$y1, x$arrow) : semi-transparency is not supported on this device: reported only once per page > > cat("==lda example from mlr documentation, and plotmo error handling =================\n") ==lda example from mlr documentation, and plotmo error handling ================= > > set.seed(2018) > data(iris) > task.lda <- makeClassifTask(data=iris, target="Species") > lrn.lda <- makeLearner("classif.lda") > n <- nrow(iris) > train.set <- sample(n, size=2/3*n) > test.set <- setdiff(1:n, train.set) > classif.lda.with.call <- train.with.call(lrn.lda, task.lda, subset=train.set) > classif.lda <- train(lrn.lda, task.lda, subset=train.set) > iris1 <- iris[train.set, ] > library(MASS) > lda <- lda(Species~., data=iris1) > > # expect.err(try(plotres(classif.lda.with.call)), "plotres does not (yet) support type=\"class\" for \"lda\" objects") > expect.err(try(plotres(classif.lda$learner.model)), "plotres does not (yet) support type=\"class\" for \"lda\" objects") Error : plotres does not (yet) support type="class" for "lda" objects Try type="response" ? Got expected error from try(plotres(classif.lda$learner.model)) > > options(warn=2) # treat warnings as errors > # expect.err(try(plotres(classif.lda.with.call, type="response")), "predict.lda returned multiple columns (see above) but nresponse is not specified") > expect.err(try(plotres(classif.lda$learner.model, type="response")), "Defaulting to nresponse=1, see above messages") predict.lda[3,2]: LD1 LD2 15 10.723308 -1.2184763 131 -6.507414 0.9729798 140 -5.339014 -0.8727408 predict.lda returned multiple columns (see above) but nresponse is not specified Use the nresponse argument to specify a column. Example: nresponse=2 Example: nresponse="LD2" Error : (converted from warning) Defaulting to nresponse=1, see above messages Got expected error from try(plotres(classif.lda$learner.model, type = "response")) > options(warn=1) > > expect.err(try(plotres(classif.lda.with.call, type="response", nresponse="nonesuch")), "nresponse=\"nonesuch\" is not allowed") Error : nresponse="nonesuch" is not allowed Only an integer index or "response" is allowed Got expected error from try(plotres(classif.lda.with.call, type = "response", nresponse = "nonesuch")) > expect.err(try(plotres(classif.lda$learner.model, type="response", nresponse="nonesuch")), "nresponse=\"nonesuch\" is not allowed") Error : nresponse="nonesuch" is not allowed Choose an integer index or one of: "LD1" "LD2" Got expected error from try(plotres(classif.lda$learner.model, type = "response", nresponse = "nonesuch")) > > expect.err(try(plotres(classif.lda.with.call, type="response", nresponse=0)), "nresponse=0 but it should be at least 1") Error : nresponse=0 but it should be at least 1 Got expected error from try(plotres(classif.lda.with.call, type = "response", nresponse = 0)) > expect.err(try(plotres(classif.lda$learner.model, type="response", nresponse=0)), "nresponse=0 but it should be at least 1") Error : nresponse=0 but it should be at least 1 Got expected error from try(plotres(classif.lda$learner.model, type = "response", nresponse = 0)) > > expect.err(try(plotres(classif.lda.with.call, type="response", nresponse=99)), "nresponse is 99 but the number of columns is only 1") Error : nresponse is 99 but the number of columns is only 1 Got expected error from try(plotres(classif.lda.with.call, type = "response", nresponse = 99)) > expect.err(try(plotres(classif.lda$learner.model, type="response", nresponse=99)), "nresponse is 99 but the number of columns is only 2") Error : nresponse is 99 but the number of columns is only 2 Got expected error from try(plotres(classif.lda$learner.model, type = "response", nresponse = 99)) > > expect.err(try(plotmo(classif.lda)), "getCall(classif.lda) failed") Error : getCall(classif.lda) failed. Possible workaround: call plotmo like this: plotmo(classif.lda$learner.model, ...) Got expected error from try(plotmo(classif.lda)) > > expect.err(try(plotres(classif.lda)), "getCall(classif.lda) failed") Error : getCall(classif.lda) failed. Possible workaround: call plotres like this: plotres(classif.lda$learner.model, ...) Got expected error from try(plotres(classif.lda)) > > # TODO residuals don't match > plotres(classif.lda.with.call, SHOWCALL=TRUE, type="response") > plotres(classif.lda$learner.model, SHOWCALL=TRUE, type="response", nresponse="LD2") > plotres(lda, SHOWCALL=TRUE, type="response", nresponse="LD2") > > plotmo(classif.lda.with.call, SHOWCALL=TRUE) plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 6 3 4.45 1.4 > plotmo(classif.lda$learner.model, SHOWCALL=TRUE) plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 6 3 4.45 1.4 > plotmo(lda, SHOWCALL=TRUE) plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 6 3 4.45 1.4 > > # # TODO plotPartialDependence and plotmo graphs below don't match > # pd <- generatePartialDependenceData(classif.lda, task.lda, "Petal.Width", n=c(50, NA)) # TODO generates warnings > # print(plotPartialDependence(pd, data = getTaskData(task.lda))) > plotmo(classif.lda.with.call, degree1="Petal.Width", degree2=0, pmethod="partdep", do.par=FALSE) calculating partdep for Petal.Width > > plotmo(classif.lda.with.call, SHOWCALL=TRUE, all2=TRUE, type="response") plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 6 3 4.45 1.4 > plotmo(classif.lda$learner.model, SHOWCALL=TRUE, all2=TRUE, type="class") plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 6 3 4.45 1.4 > plotmo(lda, SHOWCALL=TRUE, all2=TRUE, type="class") plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 6 3 4.45 1.4 > > plotmo(classif.lda$learner.model, SHOWCALL=TRUE, all2=TRUE, type="response", nresponse="LD1") plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 6 3 4.45 1.4 > plotmo(lda, SHOWCALL=TRUE, all2=TRUE, type="response", nresponse="LD1") plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 6 3 4.45 1.4 > > cat("==test recursive call to plotmo_prolog for learner.model===============\n") ==test recursive call to plotmo_prolog for learner.model=============== > > set.seed(2018) > n <- 100 > data <- data.frame( + x1 = rnorm(n), + x2 = rnorm(n), + x3 = rnorm(n), + x4 = rnorm(n), + x5 = rnorm(n), + x6 = rnorm(n), + x7 = rnorm(n), + x8 = rnorm(n), + x9 = rnorm(n)) > > data$y <- sin(data$x3) + sin(data$x4) + 2 * cos(data$x5) > > set.seed(2018) > library(gbm) Loaded gbm 2.2.2 This version of gbm is no longer under development. Consider transitioning to gbm3, https://github.com/gbm-developers/gbm3 > # reference model > gbm = gbm(y~., data=data, n.trees=300) Distribution not specified, assuming gaussian ... > plotmo(gbm, trace=-1, SHOWCALL=TRUE) > > set.seed(2018) > task <- makeRegrTask(data=data, target="y") > lrn <- makeLearner("regr.gbm", n.trees=300, keep.data=TRUE) > regr.gbm = train.with.call(lrn, task) > plotmo(regr.gbm, trace=-1, SHOWCALL=TRUE) > > set.seed(2018) > lrn <- makeLearner("regr.gbm", n.trees=300) > regr.gbm.nokeepdata = train.with.call(lrn, task) > # expect message: use keep.data=TRUE in the call to gbm (cannot determine the variable importances) > plotmo(regr.gbm.nokeepdata, trace=1, SHOWCALL=TRUE) Error : use keep.data=TRUE in the call to gbm (cannot determine the variable importances) plotmo.prolog(object$learner.model) failed, continuing anyway stats::fitted(object=WrappedModel.object) fitted() was unsuccessful, will use predict() instead got model response from object$y plotmo grid: x1 x2 x3 x4 x5 x6 -0.07231869 0.1672582 0.1278179 -0.03757131 -0.2269232 -0.08124337 x7 x8 x9 0.06208072 0.04337176 0.02863955 > > plotres(regr.gbm, SHOWCALL=TRUE) > > cat("==example from makeClassificationViaRegressionWrapper help page ===============\n") ==example from makeClassificationViaRegressionWrapper help page =============== > # this tests that plotmo.prolog can access the learner.model at object$learner.model$next.model$learner.model > > set.seed(2018) > lrn = makeLearner("regr.rpart") > lrn = makeClassificationViaRegressionWrapper(lrn) > ClassificationViaRegression = train.with.call(lrn, sonar.task, subset = 1:140) > plotmo(ClassificationViaRegression, SHOWCALL=TRUE) plotmo grid: V1 V2 V3 V4 V5 V6 V7 V8 V9 0.0228 0.0309 0.03415 0.0436 0.06185 0.0898 0.10905 0.1079 0.12425 V10 V11 V12 V13 V14 V15 V16 V17 V18 V19 0.14675 0.17765 0.20415 0.23515 0.284 0.34475 0.4347 0.42945 0.4559 0.4763 V20 V21 V22 V23 V24 V25 V26 V27 V28 V29 0.55465 0.60735 0.6532 0.6704 0.7206 0.70165 0.68745 0.65975 0.63945 0.56105 V30 V31 V32 V33 V34 V35 V36 V37 V38 V39 0.52325 0.468 0.3803 0.3608 0.37695 0.3663 0.41885 0.3821 0.3153 0.2847 V40 V41 V42 V43 V44 V45 V46 V47 V48 V49 0.28085 0.2602 0.23295 0.2066 0.1694 0.13395 0.09905 0.08755 0.0645 0.0362 V50 V51 V52 V53 V54 V55 V56 V57 V58 V59 0.0173 0.01325 0.01005 0.01105 0.01035 0.00835 0.0074 0.0072 0.0063 0.00705 V60 0.0059 > > source("test.epilog.R") plotmo/inst/slowtests/test.partykit.R0000644000176200001440000001251014664212517017567 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.modguide.Rout.save0000644000176200001440000005402214563614021021200 0ustar liggesusers> # test.modguide.bat: test model1 and model2 (linmod examples) in modguide.pdf > > source("test.prolog.R") > options(warn=1) # print warnings as they occur > almost.equal <- function(x, y, max=1e-8) + { + stopifnot(max >= 0 && max < .01) + length(x) == length(y) && max(abs(x - y)) < max + } > # check that fit model matches ref lm model in all essential details > check.lm <- function(fit, ref, newdata=trees[3:5,], + check.coef.names=TRUE, + check.casenames=TRUE, + check.newdata=TRUE) + { + check.names <- function(fit.names, ref.names) + { + if(check.casenames && + # lm always adds rownames even if "1", "2", "3" + # this seems wasteful of resources, so linmod doesn't do this + !is.null(fit.names) && + !identical(fit.names, ref.names)) { + print(fit.names) + print(ref.names) + stop(deparse(substitute(fit.names)), " != ", + deparse(substitute(ref.names))) + } + } + cat("check ", deparse(substitute(fit)), " vs ", + deparse(substitute(ref)), "\n", sep="") + + stopifnot(coef(fit) == coef(ref)) + if(check.coef.names) + stopifnot(identical(names(coef(fit)), names(coef(ref)))) + + stopifnot(identical(dim(fit$coefficients), dim(ref$coefficients))) + stopifnot(length(fit$coefficients) == length(ref$coefficients)) + stopifnot(almost.equal(fit$coefficients, ref$coefficients)) + + stopifnot(identical(dim(fit$residuals), dim(ref$residuals))) + stopifnot(length(fit$residuals) == length(ref$residuals)) + stopifnot(almost.equal(fit$residuals, ref$residuals)) + + stopifnot(identical(dim(fit$fitted.values), dim(ref$fitted.values))) + stopifnot(length(fit$fitted.values) == length(ref$fitted.values)) + stopifnot(almost.equal(fit$fitted.values, ref$fitted.values)) + + if(!is.null(fit$vcov) && !is.null(ref$vcov)) { + stopifnot(identical(dim(fit$vcov), dim(ref$vcov))) + stopifnot(length(fit$vcov) == length(ref$vcov)) + stopifnot(almost.equal(fit$vcov, ref$vcov)) + } + ref.sigma <- ref$sigma + if(is.null(ref.sigma)) # in lm models, sigma is only available from summary() + ref.sigma <- summary(ref)$sigma + stopifnot(almost.equal(fit$sigma, ref.sigma)) + + stopifnot(almost.equal(fit$df, ref$df)) + + stopifnot(almost.equal(fitted(fit), fitted(ref))) + check.names(names(fitted(fit)), names(fitted(ref))) + + stopifnot(almost.equal(residuals(fit), residuals(ref))) + check.names(names(residuals(fit)), names(residuals(ref))) + + stopifnot(almost.equal(predict(fit), predict(ref))) + check.names(names(predict(fit)), names(predict(ref))) + if(check.newdata) { + stopifnot(almost.equal(predict(fit, newdata=newdata), + predict(ref, newdata=newdata))) + check.names(names(predict(fit, newdata=newdata)), + names(predict(ref, newdata=newdata))) + } + } > ### Model 1: original code from Friedrich Leisch tutorial > > source("modguide.model1.R") > > cat("==example issues with predict with functions in the tutorial\n") ==example issues with predict with functions in the tutorial > data(trees) > tr <- trees # trees data but with rownames > rownames(tr) <- paste("tree", 1:nrow(trees), sep="") > fit1 <- linmod(Volume~., data=tr) > expect.err(try(predict(fit1, newdata=data.frame(Girth=10, Height=80))), "object 'Volume' not found") Error in eval(predvars, data, env) : object 'Volume' not found Got expected error from try(predict(fit1, newdata = data.frame(Girth = 10, Height = 80))) > expect.err(try(predict(fit1, newdata=as.matrix(tr[1:3,]))), "'data' must be a data.frame, not a matrix or an array") Error in model.frame.default(object, data, xlev = xlev) : 'data' must be a data.frame, not a matrix or an array Got expected error from try(predict(fit1, newdata = as.matrix(tr[1:3, ]))) > library(plotmo) Loading required package: Formula Loading required package: plotrix > expect.err(try(plotmo(fit1)), "object 'Volume' not found") stats::predict(linmod.object, data.frame[3,2], type="response") Error in eval(predvars, data, env) : object 'Volume' not found Got expected error from try(plotmo(fit1)) > fit2 <- linmod(cbind(1, tr[,1:2]), tr[,3]) > stopifnot(coef(fit1) == coef(fit2)) > # following fail because newdata is a data.frame not a matrix > expect.err(try(predict(fit2, newdata=tr[,1:2])), "requires numeric/complex matrix/vector arguments") Error in x %*% coef(object) : requires numeric/complex matrix/vector arguments Got expected error from try(predict(fit2, newdata = tr[, 1:2])) > expect.err(try(predict(fit2, newdata=data.frame(Girth=10, Height=80))), "requires numeric/complex matrix/vector arguments") Error in x %*% coef(object) : requires numeric/complex matrix/vector arguments Got expected error from try(predict(fit2, newdata = data.frame(Girth = 10, Height = 80))) > expect.err(try(predict(fit2, newdata=as.matrix(data.frame(Girth=10, Height=80)))), "non-conformable arguments") Error in x %*% coef(object) : non-conformable arguments Got expected error from try(predict(fit2, newdata = as.matrix(data.frame(Girth = 10, Height = 80)))) > expect.err(try(plotmo(fit2)), "requires numeric/complex matrix/vector arguments") stats::predict(linmod.object, data.frame[3,3], type="response") Error in x %*% coef(object) : requires numeric/complex matrix/vector arguments Got expected error from try(plotmo(fit2)) > > cat("==a plotmo method function can deal with the issues\n") ==a plotmo method function can deal with the issues > plotmo.predict.linmod <- function(object, newdata, ...) + { + if(is.null(object$formula)) # x,y interface? + plotmo:::plotmo.predict.defaultm(object, newdata, ...) # pass matrix not data.frame + else { + # add dummy response column to newdata + newdata[[as.character(as.list(object$formula)[[2]])]] <- 1 + plotmo:::plotmo.predict.default(object, newdata, ...) + } + } > plotmo(fit1, pt.col=2, caption="fit1 with original tutorial code and plotmo.predict.linmod") plotmo grid: Girth Height 12.9 76 > plotmo(fit2, pt.col=2, caption="fit2 with original tutorial code and plotmo.predict.linmod") plotmo grid: 1 Girth Height 1 12.9 76 > remove(plotmo.predict.linmod) > > ### Model 2: minimal changes version for vignette "Guidelines for S3 Regression Models" > > source("modguide.model2.R") > > cat("==check that example issues with functions in the tutorial have gone\n") ==check that example issues with functions in the tutorial have gone > fit1.form <- linmod(Volume~., data=tr) > cat("==print(summary(fit1.form))\n") ==print(summary(fit1.form)) > print(summary(fit1.form)) Call: linmod.formula(formula = Volume ~ ., data = tr) Estimate StdErr t.value p.value (Intercept) -57.98766 8.63823 -6.7129 2.75e-07 *** Girth 4.70816 0.26426 17.8161 < 2.2e-16 *** Height 0.33925 0.13015 2.6066 0.01449 * --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 > stopifnot(abs(predict(fit1.form, newdata=data.frame(Girth=10, Height=80)) - 16.234045) < 1e-5) > stopifnot(sum(abs(predict(fit1.form, newdata=as.matrix(tr[1:3,])) - c(4.8376597, 4.5538516, 4.8169813))) < 1e-5) > > lm.tr <- lm(Volume~., data=tr) > check.lm(fit1.form, lm.tr) check fit1.form vs lm.tr > > fit1.mat <- linmod(tr[,1:2], tr[,3]) # note no need for intercept term > cat("==print(summary(fit1.mat))\n") ==print(summary(fit1.mat)) > print(summary(fit1.mat)) Call: linmod.default(x = tr[, 1:2], y = tr[, 3]) Estimate StdErr t.value p.value (Intercept) -57.98766 8.63823 -6.7129 2.75e-07 *** Girth 4.70816 0.26426 17.8161 < 2.2e-16 *** Height 0.33925 0.13015 2.6066 0.01449 * --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 > stopifnot(abs(predict(fit1.mat, newdata=data.frame(Girth=10, Height=80)) - 16.234045) < 1e-5) > stopifnot(sum(abs(predict(fit1.mat, newdata=tr[1:3,1:2]) - c(4.8376597, 4.5538516, 4.8169813))) < 1e-5) > stopifnot(abs(predict(fit1.mat, newdata=as.matrix(data.frame(Girth=10, Height=80))) - 16.234045) < 1e-5) > > check.lm(fit1.mat, lm.tr, newdata=trees[3:5,1:2]) check fit1.mat vs lm.tr > > cat("==example plots\n") ==example plots > > library(plotmo) > data(trees) > > fit1.form <- linmod(Volume~., data=trees) > print(fit1.form) Call: linmod.formula(formula = Volume ~ ., data = trees) Coefficients: (Intercept) Girth Height -57.9876589 4.7081605 0.3392512 > print(summary(fit1.form)) Call: linmod.formula(formula = Volume ~ ., data = trees) Estimate StdErr t.value p.value (Intercept) -57.98766 8.63823 -6.7129 2.75e-07 *** Girth 4.70816 0.26426 17.8161 < 2.2e-16 *** Height 0.33925 0.13015 2.6066 0.01449 * --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 > > fit1.mat <- linmod(trees[,1:2], trees[,3]) > print(fit1.mat) Call: linmod.default(x = trees[, 1:2], y = trees[, 3]) Coefficients: (Intercept) Girth Height -57.9876589 4.7081605 0.3392512 > print(summary(fit1.mat)) Call: linmod.default(x = trees[, 1:2], y = trees[, 3]) Estimate StdErr t.value p.value (Intercept) -57.98766 8.63823 -6.7129 2.75e-07 *** Girth 4.70816 0.26426 17.8161 < 2.2e-16 *** Height 0.33925 0.13015 2.6066 0.01449 * --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 > > plotmo(fit1.form) plotmo grid: Girth Height 12.9 76 > plotmo(fit1.mat) plotmo grid: Girth Height 12.9 76 > > plotres(fit1.form) > plotres(fit1.mat) > > cat("==test model building with different numeric args\n") ==test model building with different numeric args > > x <- tr[,1:2] > y <- tr[,3] > fit2.mat <- linmod(x, y) > check.lm(fit2.mat, lm.tr, newdata=trees[3:5,1:2]) check fit2.mat vs lm.tr > > # check consistency with lm > expect.err(try(linmod(y~x)), "invalid type (list) for variable 'x'") Error in model.frame.default(formula = formula, data = data) : invalid type (list) for variable 'x' Got expected error from try(linmod(y ~ x)) > expect.err(try(lm(y~x)), "invalid type (list) for variable 'x'") Error in model.frame.default(formula = y ~ x, drop.unused.levels = TRUE) : invalid type (list) for variable 'x' Got expected error from try(lm(y ~ x)) > > fit3.mat <- linmod(as.matrix(x), as.matrix(y)) > check.lm(fit3.mat, lm.tr, newdata=trees[3:5,1:2]) check fit3.mat vs lm.tr > > fit4.form <- linmod(y ~ as.matrix(x)) > lm4 <- linmod(y ~ as.matrix(x)) > check.lm(fit4.form, lm4) check fit4.form vs lm4 > stopifnot(coef(fit4.form) == coef(lm.tr), + gsub("as.matrix(x)", "", names(coef(fit4.form)), fixed=TRUE) == names(coef(lm.tr))) > > xm <- as.matrix(x) > fit5.form <- linmod(y ~ xm) > lm5 <- linmod(y ~ xm) > check.lm(fit5.form, lm5) check fit5.form vs lm5 > stopifnot(coef(fit5.form) == coef(lm.tr), + gsub("xm", "", names(coef(fit5.form)), fixed=TRUE) == names(coef(lm.tr))) > > cat("==test correct use of global x1 and y1\n") ==test correct use of global x1 and y1 > x1 <- tr[,1] > y1 <- tr[,3] > linmod1 <- linmod(y1~x1) > > fit6.mat <- linmod(x1, y1) > check.lm(fit6.mat, linmod1, newdata=x1[3:5], + check.newdata=FALSE, # TODO needed because linmod1 ignores newdata(!) + check.coef.names=FALSE, check.casenames=FALSE) check fit6.mat vs linmod1 > print(predict(fit6.mat, newdata=x1[3:5])) [1] 7.636077 16.248033 17.261205 > stopifnot(almost.equal(predict(fit6.mat, newdata=x1[3]), 7.63607739644657)) > # production version only: > # stopifnot(coef(fit6.mat) == coef(linmod1), > # names(coef(fit6.mat)) == c("(Intercept)", "V1")) # names(coef(linmod1) are "(Intercept)" "x1" > > fit6.form <- linmod(y1~x1) > check.lm(fit6.form, linmod1) check fit6.form vs linmod1 > > cat("==check integer input (sibsp is an integer) \n") ==check integer input (sibsp is an integer) > > library(earth) # for etitanic data > data(etitanic) > tit <- etitanic[seq(1, nrow(etitanic), by=60), ] # small set of data for tests (18 cases) > tit$survived <- tit$survived != 0 # convert to logical > rownames(tit) <- paste("pas", 1:nrow(tit), sep="") > cat(paste(colnames(tit), "=", sapply(tit, class), sep="", collapse=", "), "\n") pclass=factor, survived=logical, sex=factor, age=numeric, sibsp=integer, parch=integer > > fit7.mat <- linmod(tit$age, tit$sibsp) > lm7 <- lm.fit(cbind(1, tit$age), tit$sibsp) > stopifnot(coef(fit7.mat) == coef(lm7)) # coef names will differ > > fit7.form <- linmod(sibsp~age, data=tit) > lm7.form <- lm(sibsp~age, data=tit) > check.lm(fit7.form, lm7.form, newdata=tit[3:5,]) check fit7.form vs lm7.form > > fit8.mat <- linmod(tit$sibsp, tit$age) > lm8 <- lm.fit(cbind(1, tit$sibsp), tit$age) > stopifnot(coef(fit8.mat) == coef(lm8)) # coef names will differ > > fit8.form <- linmod(age~sibsp, data=tit) > lm8.form <- lm(age~sibsp, data=tit) > check.lm(fit8.form, lm8.form, newdata=tit[3:5,]) check fit8.form vs lm8.form > > # drop=FALSE so response is a data frame > fit1a.mat <- linmod(trees[,1:2], trees[, 3, drop=FALSE]) > print(fit1a.mat) Call: linmod.default(x = trees[, 1:2], y = trees[, 3, drop = FALSE]) Coefficients: (Intercept) Girth Height -57.9876589 4.7081605 0.3392512 > print(summary(fit1.mat)) Call: linmod.default(x = trees[, 1:2], y = trees[, 3]) Estimate StdErr t.value p.value (Intercept) -57.98766 8.63823 -6.7129 2.75e-07 *** Girth 4.70816 0.26426 17.8161 < 2.2e-16 *** Height 0.33925 0.13015 2.6066 0.01449 * --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 > plotres(fit1a.mat) # plot caption shows response name "Volume" > > cat("==test model building with different non numeric args\n") ==test model building with different non numeric args > > library(earth) # for etitanic data > data(etitanic) > tit <- etitanic[seq(1, nrow(etitanic), by=60), ] # small set of data for tests (18 cases) > tit$survived <- tit$survived != 0 # convert to logical > rownames(tit) <- paste("pas", 1:nrow(tit), sep="") > cat(paste(colnames(tit), "=", sapply(tit, class), sep="", collapse=", "), "\n") pclass=factor, survived=logical, sex=factor, age=numeric, sibsp=integer, parch=integer > > lm9 <- lm(survived~., data=tit) > fit9.form <- linmod(survived~., data=tit) > check.lm(fit9.form, lm9, newdata=tit[3:5,]) check fit9.form vs lm9 > > options(warn=2) # treat warnings as errors > # factors in x > expect.err(try(linmod(tit[,c(1,3,4,5,6)], tit[,"survived"])), "NAs introduced by coercion") Error in storage.mode(x) <- "double" : (converted from warning) NAs introduced by coercion Got expected error from try(linmod(tit[, c(1, 3, 4, 5, 6)], tit[, "survived"])) > options(warn=1) # print warnings as they occur > expect.err(try(linmod(tit[,c(1,3,4,5,6)], tit[,"survived"])), "NA/NaN/Inf in foreign function call (arg 1)") Warning in storage.mode(x) <- "double" : NAs introduced by coercion Error in qr.default(x) : NA/NaN/Inf in foreign function call (arg 1) Got expected error from try(linmod(tit[, c(1, 3, 4, 5, 6)], tit[, "survived"])) > > options(warn=2) # treat warnings as errors > expect.err(try(lm(pclass~., data=tit)), "using type = \"numeric\" with a factor response will be ignored") Error in model.response(mf, "numeric") : (converted from warning) using type = "numeric" with a factor response will be ignored Got expected error from try(lm(pclass ~ ., data = tit)) > # minimal version > expect.err(try(linmod(pclass~., data=tit)), "(converted from warning) NAs introduced by coercion") Error in storage.mode(y) <- "double" : (converted from warning) NAs introduced by coercion Got expected error from try(linmod(pclass ~ ., data = tit)) > expect.err(try(linmod(tit$pclass, tit$survived)), "(converted from warning) NAs introduced by coercion") Error in storage.mode(x) <- "double" : (converted from warning) NAs introduced by coercion Got expected error from try(linmod(tit$pclass, tit$survived)) > # # production version > # expect.err(try(linmod(pclass~., data=tit)), "'y' is not numeric or logical") > options(warn=1) > > lm10 <- lm(pclass~., data=tit) # will give warnings Warning in model.response(mf, "numeric") : using type = "numeric" with a factor response will be ignored Warning in Ops.factor(y, z$residuals) : '-' not meaningful for factors > fit10.form <- linmod(as.numeric(pclass)~., data=tit) > stopifnot(coef(fit10.form) == coef(lm10)) > stopifnot(names(coef(fit10.form)) == names(coef(lm10))) > # check.lm(fit10.form, lm10) # fails because lm10 fitted is all NA > > # production version: (minimal version just gives warnings and builds lousy model) > # expect.err(try(linmod(pclass~., data=tit)), "'y' is not numeric or logical") > # expect.err(try(linmod(tit[,-1], tit[,1])), "'y' is not numeric or logical") > # expect.err(try(linmod(1:10, paste(1:10))), "'y' is not numeric or logical") > > fit10a.form <- linmod(survived~pclass, data=tit) > lm10a <- lm(survived~pclass, data=tit) > check.lm(fit10a.form, lm10a, newdata=tit[3:5,]) check fit10a.form vs lm10a > > expect.err(try(linmod(paste(1:10), 1:10)), "requires numeric/complex matrix/vector arguments") Error in x %*% coef : requires numeric/complex matrix/vector arguments Got expected error from try(linmod(paste(1:10), 1:10)) > > lm11 <- lm(as.numeric(pclass)~., data=tit) > fit11.form <- linmod(as.numeric(pclass)~., data=tit) > check.lm(fit11.form, lm11, newdata=tit[3:5,]) check fit11.form vs lm11 > > cat("==data.frame with strings\n") ==data.frame with strings > > df.with.string <- + data.frame(1:5, + c(1,2,-1,4,5), + c("a", "b", "a", "a", "b"), + stringsAsFactors=FALSE) > colnames(df.with.string) <- c("num1", "num2", "string") > > fit30.form <- linmod(num1~num2, df.with.string) > lm30 <- lm(num1~num2, df.with.string) > check.lm(fit30.form, lm30, check.newdata=FALSE) check fit30.form vs lm30 > > fit31.form <- linmod(num1~., df.with.string) > lm31 <- lm(num1~., df.with.string) > check.lm(fit31.form, lm31, check.newdata=FALSE) check fit31.form vs lm31 > > expect.err(try(linmod(string~., df.with.string)), "non-numeric argument to binary operator") Warning in storage.mode(y) <- "double" : NAs introduced by coercion Error in y - x %*% coef : non-numeric argument to binary operator Got expected error from try(linmod(string ~ ., df.with.string)) > # production version > # expect.err(try(linmod(string~., df.with.string)), "'y' is not numeric or logical") > > vec <- c(1,2,3,4,3) > options(warn=2) # treat warnings as errors > expect.err(try(linmod(df.with.string, vec)), "NAs introduced by coercion") Error in storage.mode(x) <- "double" : (converted from warning) NAs introduced by coercion Got expected error from try(linmod(df.with.string, vec)) > options(warn=1) > # minimal version > expect.err(try(linmod(df.with.string, vec)), "NA/NaN/Inf in foreign function call (arg 1)") Warning in storage.mode(x) <- "double" : NAs introduced by coercion Error in qr.default(x) : NA/NaN/Inf in foreign function call (arg 1) Got expected error from try(linmod(df.with.string, vec)) > # production version > # expect.err(try(linmod(df.with.string, vec)), "NA in 'x'") > > options(warn=2) # treat warnings as errors > expect.err(try(linmod(df.with.string, vec)), "NAs introduced by coercion") Error in storage.mode(x) <- "double" : (converted from warning) NAs introduced by coercion Got expected error from try(linmod(df.with.string, vec)) > options(warn=1) > # minimal version > expect.err(try(linmod(df.with.string, vec)), "NA/NaN/Inf in foreign function call (arg 1)") Warning in storage.mode(x) <- "double" : NAs introduced by coercion Error in qr.default(x) : NA/NaN/Inf in foreign function call (arg 1) Got expected error from try(linmod(df.with.string, vec)) > # production version > # expect.err(try(linmod(df.with.string, vec)), "NA in 'x'") > > cat("==more variables than cases\n") ==more variables than cases > > set.seed(1) > x2 <- matrix(rnorm(6), nrow=2) > y2 <- c(1,2) > # production version > # expect.err(try(linmod(y2~x2)), "more variables than cases") > # minimal version > expect.err(try(linmod(y2~x2)), "'size' cannot exceed nrow(x) = 2") Error in chol2inv(qx$qr) : 'size' cannot exceed nrow(x) = 2 Got expected error from try(linmod(y2 ~ x2)) > > x3 <- matrix(1:10, ncol=2) > y3 <- c(1,2,9,4,5) > # production version will give a better error message > expect.err(try(linmod(y3~x3)), "singular matrix 'a' in 'solve'") Error in solve.qr(qx, y) : singular matrix 'a' in 'solve' Got expected error from try(linmod(y3 ~ x3)) > > cat("==nrow(x) does not match length(y)\n") ==nrow(x) does not match length(y) > # note that the production version gives better error messages > > x4 <- matrix(1:10, ncol=2) > y4 <- c(1,2,9,4) > expect.err(try(linmod(x4, y4)), "singular matrix 'a' in 'solve'") Error in solve.qr(qx, y) : singular matrix 'a' in 'solve' Got expected error from try(linmod(x4, y4)) > > x5 <- matrix(1:10, ncol=2) > y5 <- c(1,2,9,4,5,9) > expect.err(try(linmod(x5, y5)), "singular matrix 'a' in 'solve'") Error in solve.qr(qx, y) : singular matrix 'a' in 'solve' Got expected error from try(linmod(x5, y5)) > > cat("==y has multiple columns\n") ==y has multiple columns > > vec <- c(1,2,3,4,3) > y2 <- cbind(c(1,2,3,4,9), vec^2) > expect.err(try(linmod(vec, y2)), "'qr' and 'y' must have the same number of rows") Error in qr.coef(a, b) : 'qr' and 'y' must have the same number of rows Got expected error from try(linmod(vec, y2)) > # following does not issue any error message, it should > # expect.err(try(linmod(y2~vec)), "error message") > > ### Model 3: production version of linmod is tested in test.linmod.R > > source("test.epilog.R") plotmo/inst/slowtests/test.plotmo.R0000644000176200001440000010461513727235376017251 0ustar liggesusers# test.plotmo.R: regression tests for plotmo # Stephen Milborrow, Petaluma Jan 2007 print(R.version.string) source("test.prolog.R") library(earth) options(warn=1) # print warnings as they occur data(etitanic) make.space.for.caption <- function(caption="CAPTION") { oma <- par("oma") needed <- 3 # adjust for newlines in caption newlines <- grep("\n", caption) if(length(newlines) > 0) needed <- needed + .5 * newlines # .5 seems enough although 1 in theory if(!is.null(caption) && any(nchar(caption)) && oma[3] <= needed) { oma[3] <- needed par(oma=oma) } } dopar <- function(nrows, ncols, caption = "") { cat(" ", caption, "\n") make.space.for.caption(caption) par(mfrow=c(nrows, ncols)) par(mar = c(3, 3, 1.7, 0.5)) par(mgp = c(1.6, 0.6, 0)) par(cex = 0.7) } example(plotmo) caption <- "basic earth test of plotmo" a <- earth(O3 ~ ., data=ozone1, degree=2) plotmo(a, degree1=2, degree2=4, caption=caption, trace=-1) caption <- "test 5 x 5 layout" dopar(1,1,caption) a <- earth(O3 ~ ., data=ozone1, nk=51, pmethod="n", degree=2) plotmo(a, caption=caption, trace=1) caption <- "test 4 x 4 layout with ylab" dopar(1,1,caption) a <- earth(O3 ~ ., data=ozone1, nk=30, pmethod="n", degree=2) plotmo(a, caption=caption, trace=2) caption <- "test 3 x 3 layout" dopar(1,1,caption) a <- earth(O3 ~ ., data=ozone1, nk=16, pmethod="n", degree=2) plotmo(a, caption=caption, trace=3) caption <- "test 2 x 2 layout" dopar(1,1,caption) a <- earth(O3 ~ ., data=ozone1, nk=9, pmethod="n", degree=2) plotmo(a, caption=caption) caption <- "test 1 x 1 layout" dopar(1,1,caption) a <- earth(O3 ~ ., data=ozone1, nk=4, pmethod="n", degree=2) plotmo(a, caption=caption) caption <- "test plotmo basic params" a <- earth(O3 ~ ., data=ozone1, degree=2) dopar(3,2,caption) plotmo(a, do.par=FALSE, degree1=1, nrug=-1, degree2=F, caption=caption, main="test main", xlab="test xlab", ylab="test ylab") plotmo(a, do.par=FALSE, degree1=F, degree2=4, grid.func=mean, persp.col="white", ngrid2=10, persp.phi=40) set.seed(2016) plotmo(a, do.par=FALSE, degree1=1, degree1.lty=2, degree1.lwd=4, degree1.col=2, nrug=TRUE, degree2=F, main="nrug=300") plotmo(a, do.par=FALSE, degree1=1, nrug=-1, degree2=F, main="nrug=TRUE") set.seed(2016) plotmo(a, do.par=FALSE, degree1=1, nrug=10, ngrid1=50, degree2=F, main="ngrid1=50 nrug=10") plotmo(a, do.par=FALSE, degree1=NA, degree2=1, persp.phi=60) # graph args caption <- "test plotmo xlim and ylim" a <- earth(O3 ~ ., data=ozone1, degree=2) dopar(5,3,caption) plotmo(a, do.par=FALSE, degree1=2:3, degree2=4, caption=caption, xlab="ylim=default") plotmo(a, do.par=FALSE, degree1=2:3, degree2=4, ylim=NA, xlab="ylim=NA") plotmo(a, do.par=FALSE, degree1=2:3, degree2=4, ylim=c(0,20), xlab="ylim=c(0,20)") plotmo(a, do.par=FALSE, degree1=2:3, degree2=4, xlim=c(190,250), xlab="xlim=c(190,250)") plotmo(a, do.par=FALSE, degree1=2:3, degree2=4, xlim=c(190,250), ylim=c(11,18), xlab="xlim=c(190,250), ylim=c(11,18)") # check various types of predictors with grid.func and ndiscrete varied.type.data <- data.frame( y = 1:13, num = c(1, 3, 2, 3, 4, 5, 6, 4, 5, 6.5, 3, 6, 5), # 7 unique values (but one is non integral) int = c(1L, 1L, 3L, 3L, 4L, 4L, 3L, 5L, 3L, 6L, 7L, 8L, 10L), # 8 unique values bool = c(F, F, F, F, F, T, T, T, T, T, T, T, T), date = as.Date( c("2018-08-01", "2018-08-02", "2018-08-03", "2018-08-04", "2018-08-05", "2018-08-06", "2018-08-07", "2018-08-08", "2018-08-08", "2018-08-08", "2018-08-10", "2018-08-11", "2018-08-11")), ord = ordered(c("ord3", "ord3", "ord3", "ord1", "ord2", "ord3", "ord1", "ord2", "ord3", "ord1", "ord1", "ord1", "ord1"), levels=c("ord1", "ord3", "ord2")), fac = as.factor(c("fac1", "fac1", "fac1", "fac2", "fac2", "fac2", "fac3", "fac3", "fac3", "fac1", "fac2", "fac3", "fac3")), str = c("str1", "str1", "str1", # will be treated like a factor "str2", "str2", "str2", "str3", "str3", "str3", "str3", "str3", "str3", "str3")) varied.type.lm <- lm(y ~ ., data = varied.type.data) print(summary(varied.type.lm)) set.seed(2018) plotres(varied.type.lm, info=TRUE) plotmo(varied.type.lm, pmethod="apartdep", all2=TRUE, ticktype="d", col.response="red", caption="varied.type.lm\npmethod=\"apartdep\" default grid func") plotmo(varied.type.lm, all2=TRUE, ticktype="d", col.response="red", caption="varied.type.lm\ndefault grid func") plotmo(varied.type.lm, all2=TRUE, ndiscre=1, caption="varied.type.lm\nndiscrete=1") plotmo(varied.type.lm, all2=TRUE, ndiscr=2, caption="varied.type.lm\nndiscrete=2") plotmo(varied.type.lm, all2=TRUE, ndis=100, caption="varied.type.lm\nndiscrete=100") cat("grid.func=median:\n") plotmo(varied.type.lm, all2=TRUE, grid.func=median, caption="varied.type.lm\ngrid.func=median") cat("grid.func=quantile:\n") plotmo(varied.type.lm, all2=TRUE, grid.func=function(x, ...) quantile(x, 0.5), caption="varied.type.lm\ngrid.func=function(x, ...) quantile(x, 0.5)") cat("grid.func=mean:\n") plotmo(varied.type.lm, all2=TRUE, grid.func=mean, caption="varied.type.lm\ngrid.func=mean") varied.type.earth <- earth(y ~ ., data = varied.type.data, thresh=0, penalty=-1, trace=1) print(summary(varied.type.earth)) set.seed(2018) plotres(varied.type.earth, info=TRUE) plotmo(varied.type.earth, all1=TRUE, all2=TRUE, persp.ticktype="d", col.response="red") # term.plot calls predict.earth with an se parameter, even with termplot(se=FALSE) caption <- "basic earth test against termplot" dopar(4,4,caption) make.space.for.caption("test caption1") a <- earth(O3 ~ ., data=ozone1, degree=2) plotmo(a, do.par=FALSE, ylim=NA, caption=caption, degree2=FALSE) cat("Ignore warning: predict.earth ignored argument \"se.fit\"\n") termplot(a) caption <- "test change order of earth predictors and cex" dopar(4,4,caption) # minspan=1 to force two degree2 graphs for the test (wasn't necessary in old versions of earth) a <- earth(doy ~ humidity + temp + wind, data=ozone1, degree=2, minspan=1) plotmo(a, do.par=FALSE, ylim=NA, caption=caption, degree2=c(1,2), cex=1.2) termplot(a) caption <- "test all1=TRUE" a <- earth(doy ~ humidity + temp + wind, data=ozone1, degree=2) plotmo(a, caption=caption, all1=TRUE, persp.ticktype="d", persp.nticks=2) caption <- "test all2=TRUE" print(summary(a)) plotmo(a, caption=caption, all2=TRUE) oz <- ozone1[150:200,c("O3","temp","humidity","ibh")] a.glob <- earth(O3~temp+humidity, data=oz, degree=2) ad.glob <- earth(oz[,2:3], oz[,1], degree=2) func1 <- function() { caption <- "test environments and finding the correct data" dopar(4,4,caption) set.seed(2016) plotmo(a.glob, do.par=FALSE, main="a.glob oz", degree1=1, all2=1, degree2=1, type2="im", col.response=3, pt.pch=20, trace=2) mtext(caption, outer=TRUE, font=2, line=1.5, cex=1) plotmo(ad.glob, do.par=FALSE, main="ad.glob oz", degree1=1, all2=1, degree2=1, type2="im", col.response=3, pch.response=20, trace=2) # pch.response test backcompat a <- earth(O3~temp+humidity, data=oz, degree=2) plotmo(a, do.par=FALSE, main="a oz", degree1=1, all2=1, degree2=1, type2="im", col.response=3, pt.pch=20) ad <- earth(oz[,2:3], oz[,1], degree=2) plotmo(ad, do.par=FALSE, main="ad oz", degree1=1, all2=1, degree2=1, type2="im", col.response=3, pt.pch=20) oz.org <- oz oz10 <- 10 * oz # multiply by 10 so we can see by the axis labels if right data is being used oz <- oz10 # oz is now local to this function, but multiplied by 10 a.oz10 <- earth(O3~temp+humidity, data=oz, degree=2) a.oz10.keep <- earth(O3~temp+humidity, data=oz, degree=2, keepxy=TRUE) plotmo(a.oz10, do.par=FALSE, main="a oz10", degree1=1, all2=1, degree2=1, type2="im", col.response=3, pt.pch=20) ad.oz10 <- earth(oz[,2:3], oz[,1], degree=2) ad.oz10.keep <- earth(oz[,2:3], oz[,1], degree=2, keepxy=TRUE) plotmo(ad.oz10, do.par=FALSE, main="ad oz10", degree1=1, all2=1, degree2=1, type2="im", col.response=3, pt.pch=20) func2 <- function() { a.func <- earth(O3 ~ temp + humidity, data=oz10, degree=2) plotmo(a.func, do.par=FALSE, main="a.func oz10", degree1=1, all2=1, degree2=1, type2="im", col.response=3, pt.pch=20) ad.func <- earth(oz10[,2:3], oz10[,1], degree=2) plotmo(ad.func, do.par=FALSE, main="ad.func oz10", degree1=1, all2=1, degree2=1, type2="im", col.response=3, pt.pch=20) caption <- "test environments and finding the correct data, continued" dopar(4,4,caption) oz <- .1 * oz.org a.func <- earth(O3~temp+ humidity , data=oz, degree=2) plotmo(a.func, do.par=FALSE, main="a.func oz.1", degree1=1, all2=1, degree2=1, type2="im", col.response=3, pt.pch=20) ad.func <- earth(oz[,2:3], oz[,1], degree=2) plotmo(ad.func, do.par=FALSE, main="ad.func oz.1", degree1=1, all2=1, degree2=1, type2="im", col.response=3, pt.pch=20) plotmo(a.oz10.keep, do.par=FALSE, main="func1:a.oz10.keep", degree1=1, all2=1, degree2=1, type2="im", col.response=3, pt.pch=20) plotmo(ad.oz10.keep, do.par=FALSE, main="func1:ad.oz10.keep", degree1=1, all2=1, degree2=1, type2="im", col.response=3, pt.pch=20) cat("Expect error msg: formal argument \"do.par\" matched by multiple actual arguments\n") expect.err(try(plotmo(a.oz10, do.par=FALSE, main="func1:a.oz10", degree1=1, all2=1, degree2=1, type2="im", col.response=3, pt.pch=20, do.par=FALSE))) } func2() y <- 3:11 x1 <- c(1,3,2,4,5,6,6,6,6) x2 <- c(2,3,4,5,6,7,8,9,10) frame <- data.frame(y=y, x1=x1, x2=x2) foo <- function() { lm.18.out <- lm(y~x1+x2, model=FALSE) x1[2] <- 18 y[3] <- 19 frame <- data.frame(y=y, x1=x1, x2=x2) list(lm.18.out = lm.18.out, lm.18 = lm(y~x1+x2), lm.18.keep = lm(y~x1+x2, x=TRUE, y=TRUE), lm.18.frame = lm(y~x1+x2, data=frame)) } temp <- foo() lm.18.out <- temp$lm.18.out lm.18 <- temp$lm.18 lm.18.keep <- temp$lm.18.keep lm.18.frame <- temp$lm.18.frame # following should all use the x1 and y inside foo cat("==lm.18.out\n") plotmo(lm.18.out, main="lm.18.out", do.par=FALSE, degree1=1, clip=FALSE, ylim=c(0,20), col.response=2, pt.pch=20) cat("==lm.18\n") plotmo(lm.18, main="lm.18", do.par=FALSE, degree1=1, clip=FALSE, ylim=c(0,20), col.response=2, pt.pch=20) cat("==lm.18.keep\n") plotmo(lm.18.keep, main="lm.18.keep", trace=2, do.par=FALSE, degree1=1, clip=FALSE, ylim=c(0,20), col.response=2, pt.pch=20) cat("==lm.18.frame\n") plotmo(lm.18.frame, main="lm.18.frame", do.par=FALSE, degree1=1, clip=FALSE, ylim=c(0,20), col.response=2, pt.pch=20) } func1() caption <- "test earth formula versus x,y model" # dopar(4,4,caption) # mtext(caption, outer=TRUE, font=2, line=1.5, cex=1) a <- earth(O3 ~ ., data=ozone1, degree=2) plotmo(a, caption="test earth formula versus xy model (formula)") a <- earth(ozone1[, -1], ozone1[,1], degree=2) plotmo(a, caption="test earth formula versus xy model (xy)") # single predictor caption <- "test earth(O3~wind, data=ozone1, degree=2), single predictor" dopar(2,2,caption) a <- earth(O3~wind, data=ozone1, degree=2) plotmo(a) caption = "se=2, earth(doy~humidity+temp+wind, data=ozone1) versus termplot (expect no se lines)" dopar(3,3,caption) mtext(caption, outer=TRUE, font=2, line=1.5, cex=1) # minspan=1 to force two degree2 graphs for the test (wasn't necessary in old versions of earth) a <- earth(doy~humidity + temp + wind, data=ozone1, degree=2, minspan=1) cat("Ignore warning: predict.earth ignored argument \"se\"\n") termplot(a) plotmo(a, do.par=FALSE, ylim=NA, degree2=c(1:2), clip=FALSE, caption=caption) # test fix to bug reported by Joe Retzer, FIXED Dec 7, 2007 N <- 650 set.seed(2007) q_4 <- runif(N, -1, 1) q_2102 <- runif(N, -1, 1) q_2104 <- runif(N, -1, 1) q_3105 <- runif(N, -1, 1) q_3106 <- runif(N, -1, 1) q_4104 <- runif(N, -1, 1) q_6101 <- runif(N, -1, 1) q_6103 <- runif(N, -1, 1) q_7104 <- runif(N, -1, 1) q_3109 <- runif(N, -1, 1) q_4103 <- runif(N, -1, 1) q_2111 <- runif(N, -1, 1) q_3107 <- runif(N, -1, 1) q_3101 <- runif(N, -1, 1) q_3104 <- runif(N, -1, 1) q_7107 <- runif(N, -1, 1) depIndex <- sin(1.0 * q_4 + rnorm(650, sd=.8)) + sin(1.8 * q_2102 + rnorm(650, sd=.8)) + sin(1.3 * q_2104 + rnorm(650, sd=.8)) + sin(1.4 * q_3105 + rnorm(650, sd=.8)) + sin(1.5 * q_3106 + rnorm(650, sd=.8)) + sin(1.6 * q_4104 + rnorm(650, sd=.8)) + sin(1.8 * q_6101 + rnorm(650, sd=.8)) + sin(1.8 * q_6103 + rnorm(650, sd=.8)) + sin(1.9 * q_7104 + rnorm(650, sd=.8)) + sin(2.0 * q_3109 + rnorm(650, sd=.8)) regDatCWD <- as.data.frame(cbind(depIndex, q_4, q_2102, q_2104, q_3105, q_3106, q_4104, q_6101, q_6103, q_7104, q_3109, q_4103, q_2111, q_3107, q_3101, q_3104, q_7107)) cat("--plotmo(earthobj5)--\n") earthobj5 <- earth(depIndex ~ q_4+q_2102+q_2104+q_3105+q_3106+q_4104+q_6101+q_6103+q_7104+q_3109+q_4103+q_2111+q_3107+q_3101+q_3104+q_7107, data=regDatCWD) print(summary(earthobj5, digits = 2)) plotmo(earthobj5) # long predictor names a.rather.long.in.fact.very.long.name.q_4 <- q_4 a.rather.long.in.fact.very.long.name.q_2102 <- q_2102 a.rather.long.in.fact.very.long.name.q_2104 <- q_2104 a.rather.long.in.fact.very.long.name.q_3105 <- q_3105 a.rather.long.in.fact.very.long.name.q_3106 <- q_3106 a.rather.long.in.fact.very.long.name.q_4104 <- q_4104 a.rather.long.in.fact.very.long.name.q_6101 <- q_6101 a.rather.long.in.fact.very.long.name.q_6103 <- q_6103 a.rather.long.in.fact.very.long.name.q_7104 <- q_7104 a.rather.long.in.fact.very.long.name.q_3109 <- q_3109 a.rather.long.in.fact.very.long.name.q_4103 <- q_4103 a.rather.long.in.fact.very.long.name.q_2111 <- q_2111 a.rather.long.in.fact.very.long.name.q_3107 <- q_3107 a.rather.long.in.fact.very.long.name.q_3101 <- q_3101 a.rather.long.in.fact.very.long.name.q_3104 <- q_3104 a.rather.long.in.fact.very.long.name.q_7107 <- q_7107 a.rather.long.in.fact.very.long.name.for.the.response <- depIndex a.rather.long.in.fact.very.long.name.for.the.dataframe <- as.data.frame(cbind( a.rather.long.in.fact.very.long.name.for.the.response, a.rather.long.in.fact.very.long.name.q_4, a.rather.long.in.fact.very.long.name.q_2102, a.rather.long.in.fact.very.long.name.q_2104, a.rather.long.in.fact.very.long.name.q_3105, a.rather.long.in.fact.very.long.name.q_3106, a.rather.long.in.fact.very.long.name.q_4104, a.rather.long.in.fact.very.long.name.q_6101, a.rather.long.in.fact.very.long.name.q_6103, a.rather.long.in.fact.very.long.name.q_7104, a.rather.long.in.fact.very.long.name.q_3109, a.rather.long.in.fact.very.long.name.q_4103, a.rather.long.in.fact.very.long.name.q_2111, a.rather.long.in.fact.very.long.name.q_3107, a.rather.long.in.fact.very.long.name.q_3101, a.rather.long.in.fact.very.long.name.q_3104, a.rather.long.in.fact.very.long.name.q_7107)) cat("--a.rather.long.in.fact.very.long.name.for.the...A--\n") a.rather.long.in.fact.very.long.name.for.the.modelA <- earth(a.rather.long.in.fact.very.long.name.for.the.response ~ a.rather.long.in.fact.very.long.name.q_4 + a.rather.long.in.fact.very.long.name.q_2102 + a.rather.long.in.fact.very.long.name.q_2104 + a.rather.long.in.fact.very.long.name.q_3105 + a.rather.long.in.fact.very.long.name.q_3106 + a.rather.long.in.fact.very.long.name.q_4104 + a.rather.long.in.fact.very.long.name.q_6101 + a.rather.long.in.fact.very.long.name.q_6103 + a.rather.long.in.fact.very.long.name.q_7104 + a.rather.long.in.fact.very.long.name.q_3109 + a.rather.long.in.fact.very.long.name.q_4103 + a.rather.long.in.fact.very.long.name.q_2111 + a.rather.long.in.fact.very.long.name.q_3107 + a.rather.long.in.fact.very.long.name.q_3101 + a.rather.long.in.fact.very.long.name.q_3104 + a.rather.long.in.fact.very.long.name.q_7107, data = a.rather.long.in.fact.very.long.name.for.the.dataframe) print(summary(a.rather.long.in.fact.very.long.name.for.the.modelA, digits = 2)) plot(a.rather.long.in.fact.very.long.name.for.the.modelA) plotmo(a.rather.long.in.fact.very.long.name.for.the.modelA) cat("--a.rather.long.in.fact.very.long.name.for.the...C--\n") a.rather.long.in.fact.very.long.name.for.the.modelC <- earth(x = a.rather.long.in.fact.very.long.name.for.the.dataframe[,-1], y = a.rather.long.in.fact.very.long.name.for.the.response, degree = 3) print(summary(a.rather.long.in.fact.very.long.name.for.the.modelC, digits = 2)) plot(a.rather.long.in.fact.very.long.name.for.the.modelC) plotmo(a.rather.long.in.fact.very.long.name.for.the.modelC) a <- earth(survived ~ pclass+sex+age, data=etitanic, degree=2) print(summary(a)) plotmo(a, caption="plotmo with facs: pclass+sex+age") plotmo(a, caption="plotmo with facs: pclass+sex+age, all1=T, grid.col=\"gray\"", all1=T, grid.col="gray") plotmo(a, caption="plotmo with facs: pclass+sex+age, all2=T, col.grid=\"green\"", all2=T, col.grid="green") plotmo(a, caption="plotmo with facs: pclass+sex+age, all1=T, all2=T, grid=2", all1=T, all2=T, grid.col=2) plotmo(a, clip=FALSE, degree2=FALSE, caption="plotmo (no degree2) with facs: pclass+sex+age") plotmo(a, clip=FALSE, grid.levels=list(pclass="2n", sex="ma"), caption="plotmo with grid.levels: pclass+sex+age") # in above tests, all degree2 terms use facs # now build a model with some degree2 term that use facs, some that don't a <- earth(survived ~ pclass+age+sibsp, data=etitanic, degree=2) print(summary(a)) plotmo(a, caption="plotmo with mixed fac and non-fac degree2 terms", persp.border=NA) plotmo(a, caption="plotmo with mixed fac and non-fac degree2 terms and grid.levels", grid.levels=list(pclass="2n", age=20), # test partial matching of grid levels, and numeric preds persp.ticktype="d", persp.nticks=2) # check detection of illegal grid.levels argument expect.err(try(plotmo(a, grid.levels=list(pcla="1", pclass="2"))), 'illegal grid.levels argument ("pcla" and "pclass" both match "pclass")') expect.err(try(plotmo(a, grid.levels=list(pclass="1", pcla="2"))), 'illegal grid.levels argument ("pclass" and "pcla" both match "pclass")') expect.err(try(plotmo(a, grid.levels=list(pcla="nonesuch"))), 'illegal level "nonesuch" for "pclass" in grid.levels (allowed levels are "1st" "2nd" "3rd")') expect.err(try(plotmo(a, grid.levels=list(pcla="1sx"))), 'illegal level "1sx" for "pclass" in grid.levels (allowed levels are "1st" "2nd" "3rd")') expect.err(try(plotmo(a, grid.levels=list(pcla=1))), 'illegal level for "pclass" in grid.levels (specify factor levels with a string)') expect.err(try(plotmo(a, grid.levels=list(pcla=c("ab", "cd")))), "length(pclass) in grid.levels is not 1") expect.err(try(plotmo(a, grid.levels=list(pcla=NA))), 'pclass in grid.levels is NA') expect.err(try(plotmo(a, grid.levels=list(pcla=Inf))), 'pclass in grid.levels is infinite') expect.err(try(plotmo(a, grid.levels=list(pcla=9))), 'illegal level for "pclass" in grid.levels (specify factor levels with a string)') options(warn=2) expect.err(try(plotmo(a, grid.levels=list(age="ab"))), 'grid.levels returned class \"character\" for age, so will use the default grid.func for age') options(warn=1) expect.err(try(plotmo(a, grid.levels=list(age=NA))), 'age in grid.levels is NA') expect.err(try(plotmo(a, grid.levels=list(age=Inf))), 'age in grid.levels is infinite') expect.err(try(plotmo(a, grid.lev=list(age=list(1,2)))), 'length(age) in grid.levels is not 1') # more-or-less repeat above, but with glm models a <- earth(survived ~ pclass+age+sibsp, data=etitanic, degree=2, glm=list(family=binomial)) print(summary(a)) plotmo(a, ylim=c(0, 1), caption="plotmo glm with mixed fac and non-fac degree2 terms") plotmo(a, ylim=c(0, 1), caption="plotmo glm with mixed fac and non-fac degree2 terms and grid.levels", grid.levels=list(pcl="2nd")) # test partial matching of variable name in grid levels plotmo(a, type="earth", ylim=c(0, 1), caption="type=\"earth\" plotmo glm with mixed fac and non-fac degree2 terms") plotmo(a, type="link", ylim=c(0, 1), clip=FALSE, caption="type=\"link\" plotmo glm with mixed fac and non-fac degree2 terms") plotmo(a, type="class", ylim=c(0, 1), caption="type=\"class\" plotmo glm with mixed fac and non-fac degree2 terms") plotmo(a, ylim=c(0, 1), caption="default type (\"response\")\nplotmo glm with mixed fac and non-fac degree2 terms") # now with different type2s set.seed(2016) plotmo(a, do.par=FALSE, type2="persp", persp.theta=-20, degree1=FALSE, grid.levels=list(pclass="2nd")) mtext("different type2s", outer=TRUE, font=2, line=1.5, cex=1) plotmo(a, do.par=FALSE, type2="contour", degree1=FALSE, grid.levels=list(pclass="2nd")) plotmo(a, do.par=FALSE, type2="image", degree1=FALSE, grid.levels=list(pclass="2nd"), col.response=as.numeric(etitanic$survived)+2, pt.pch=20) plotmo(a, do.par=FALSE, type="earth", type2="image", degree1=FALSE, grid.levels=list(pclass="2")) # grid.levels with partdep set.seed(2018) x1 <- (1:11) + runif(11) x2 <- (1:11) + runif(11) x3 <- as.integer((1:11) + runif(11)) x4 <- runif(11) > .5 # logical y <- x1 - x2 + x3 + x4 data <- data.frame(y=y, x1=x1, x2=x2, x3=x3, x4=x4) lm.x1.x2.x3 <- lm(y ~ x1 + x2 + x3 + x4 + x1*x2 + x1*x3, data=data) cat("summary(lm.x1.x2.x3):\n") print(summary(lm.x1.x2.x3)) par(mfrow = c(5, 6), mar = c(2, 3, 2, 1), mgp = c(1.5, 0.5, 0), cex = 0.6, oma=c(0,0,8,0)) plotmo(lm.x1.x2.x3, do.par=0, ylim=c(0,16), pt.col=2, caption="row1 default\nrow2 grid.levels=list(x3=15)\nrow3 partdep\nrow4 partdetp grid.levels=list(x3=15)") plotmo(lm.x1.x2.x3, do.par=0, ylim=c(0,16), pt.col=2, grid.levels=list(x3=15)) plotmo(lm.x1.x2.x3, do.par=0, ylim=c(0,16), pt.col=2, pmethod="partdep") plotmo(lm.x1.x2.x3, do.par=0, ylim=c(0,16), pt.col=2, pmethod="partdep", grid.levels=list(x3=15)) # check auto type convert in grid.levels plotmo(lm.x1.x2.x3, degree1="x1", degree2=0, main="x1 (x2=5L))", ylim=c(0,16), do.par=0, pmethod="partdep", grid.levels=list(x2=15L)) # integer to numeric plotmo(lm.x1.x2.x3, degree1="x1", degree2=0, main="x1 (x3=5))", ylim=c(0,16), do.par=0, pmethod="partdep", grid.levels=list(x3=15)) # numeric to integer plotmo(lm.x1.x2.x3, degree1="x1", degree2=0, main="x1 (x4=1))", ylim=c(0,16), do.par=0, pmethod="partdep", grid.levels=list(x4=1)) # numeric to logical expect.err(try(plotmo(lm.x1.x2.x3, degree1="x1", degree2=0, main="x1 (x4=1))", ylim=c(0,16), do.par=0, pmethod="partdep", grid.levels=list(x4="x"))), "expected a logical value in grid.levels for x4") # char to logical expect.err(try(plotmo(lm.x1.x2.x3, degree1="x2", do.par=0, pmethod="partdep", grid.levels=list(x1="1"))), "the class \"character\" of \"x1\" in grid.levels does not match its class \"numeric\" in the input data") par(org.par) # test vector main a20 <- earth(O3 ~ humidity + temp + doy, data=ozone1, degree=2, glm=list(family=Gamma)) dopar(2, 2) plotmo(a20, nrug=-1) set.seed(2016) plotmo(a20, nrug=10, caption="Test plotmo with a vector main (and npoints=200)", main=c("Humidity", "Temperature", "Day of year", "Humidity: Temperature", "Temperature: Day of Year"), col.response="darkgray", pt.pch=".", cex.response=3, npoints=200) # cex.response tests back compat cat("Expect warning below (missing double titles)\n") plotmo(a20, nrug=-1, caption="Test plotmo with a vector main (and plain smooth)", main=c("Humidity", "Temperature", "Day of year", "Humidity: Temperature", "Temp: Doy"), smooth.col="indianred") cat("Expect warning below (missing single titles)\n") plotmo(a20, nrug=-1, caption="Test plotmo with a vector main (and smooth args)", main=c("Humidity", "Temperature"), smooth.col="indianred", smooth.lwd=2, smooth.lty=2, smooth.f=.1, col.response="gray", npoints=500) plotmo(a20, nrug=-1, caption="Test plotmo with pt.pch=paste(1:nrow(ozone1))", type2="im", col.response=2, pt.cex=.8, pt.pch=paste(1:nrow(ozone1)), npoints=100) aflip <- earth(O3~vh + wind + humidity + temp, data=ozone1, degree=2) # test all1 and all2, with and without degree1 and degree2 plotmo(aflip, all2=T, caption="all2=T", npoints=TRUE) plotmo(aflip, all2=T, degree2=c(4, 2), caption="all2=T, degree2=c(4, 2)") plotmo(aflip, all1=T, caption="all1=T") plotmo(aflip, all1=T, degree1=c(3,1), degree2=NA, caption="all1=T, degree1=c(3,1), degree2=NA") options(warn=2) expect.err(try(plotmo(aflip, no.such.arg=9)), "(converted from warning) predict.earth ignored argument 'no.such.arg'") expect.err(try(plotmo(aflip, ycolumn=1)), "(converted from warning) predict.earth ignored argument 'ycolumn'") expect.err(try(plotmo(aflip, title="abc")), "(converted from warning) predict.earth ignored argument 'title'") expect.err(try(plotmo(aflip, persp.ticktype="d", persp.ntick=3, tic=3, tick=9)), "(converted from warning) predict.earth ignored argument 'tic'") expect.err(try(plotmo(aflip, persp.ticktype="d", ntick=3, tic=3)), "(converted from warning) predict.earth ignored argument 'ntick'") options(warn=1) # expect.err(try(plotmo(aflip, adj1=8, adj2=9))) # Error : plotmo: illegal argument "adj1" # expect.err(try(plotmo(aflip, yc=8, x2=9))) # "ycolumn" is no longer legal, use "nresponse" instead # expect.err(try(plotmo(aflip, persp.ticktype="d", ntick=3, ti=3))) # Error : "title" is illegal, use "caption" instead ("ti" taken to mean "title") # expect.err(try(plotmo(aflip, persp.ticktype="d", ntick=3, title=3))) # Error : "title" is illegal, use "caption" instead # expect.err(try(plotmo(aflip, persp.ticktype="d", ntick=3, tit=3, titl=7))) # Error : "title" is illegal, use "caption" instead ("tit" taken to mean "title") # expect.err(try(plotmo(aflip, zlab="abc"))) # "zlab" is illegal, use "ylab" instead # expect.err(try(plotmo(aflip, z="abc"))) # "zlab" is illegal, use "ylab" instead ("z" taken to mean "zlab") expect.err(try(plotmo(aflip, degree1=c(4,1))), "'degree1' is out of range, allowed values are 1 to 2") # expect.err(try(plotmo(aflip, none.such=TRUE))) # illegal argument "all1" # expect.err(try(plotmo(aflip, ntick=3, type2="im"))) # the ntick argument is illegal for type2="image" # expect.err(try(plotmo(aflip, breaks=3, type2="persp"))) # the breaks argument is illegal for type2="persp" # expect.err(try(plotmo(aflip, breaks=99, type2="cont"))) # the breaks argument is illegal for type2="contour" # Test error handling when accessing the original data lm.bad <- lm.fit(as.matrix(ozone1[,-1]), as.matrix(ozone1[,1])) expect.err(try(plotmo(lm.bad)), "'lm.bad' is a plain list, not an S3 model") expect.err(try(plotmo(99)), "'99' is not an S3 model") x <- matrix(c(1,3,2,4,5,6,7,8,9,10, 2,3,4,5,6,7,8,9,8,9), ncol=2) colnames(x) <- c("c1", "c2") x1 <- x[,1] x2 <- x[,2] y <- 3:12 df <- data.frame(y=y, x1=x1, x2=x2) foo1 <- function() { a.foo1 <- lm(y~x1+x2, model=FALSE) x1 <- NULL expect.err(try(plotmo(a.foo1)), "cannot get the original model predictors") } foo1() foo2 <- function() { a.foo2 <- lm(y~x1+x2, data=df, model=FALSE) df <- 99 # note that df <- NULL here will not cause an error msg y <- 99 # also needed else model.frame in plotmo will find the global y expect.err(try(plotmo(a.foo2)), "cannot get the original model predictors") } foo2() foo3 <- function() { a.foo3 <- lm(y~x) # lm() builds an lm model for which predict doesn't work expect.err(try(plotmo(a.foo3)), "predict returned the wrong length (got 10 but expected 50)") } foo3() foo3a <- function() { a.foo3a <- lm(y~x) # lm() builds an lm model for which predict doesn't work # this tests "ngrid1 <- ngrid1 + 1" in plotmo.R expect.err(try(plotmo(a.foo3a, ngrid1=nrow(x))), "predict returned the wrong length (got 10 but expected 11)") } foo3a() foo4 <- function() { a.foo4 <- lm(y~x[,1]+x[,2]) # builds an lm model for which predict doesn't work # causes 'newdata' had 8 rows but variables found have 10 rows expect.err(try(plotmo(a.foo4)), "predict returned the wrong length (got 10 but expected 50)") } foo4() foo5 <- function() { a.foo5 <- lm(y~x1+x2, model=FALSE) x1 <- c(1,2,3) # causes Error in model.frame.default: variable lengths differ (found for 'x1') expect.err(try(plotmo(a.foo5)), "cannot get the original model predictors") } foo5() foo6 <- function() { a.foo6 <- lm(y~x1+x2, model=FALSE) y[1] <- NA # Error in na.fail.default: missing values in object expect.err(try(plotmo(a.foo6, col.response=3)), "cannot get the original model predictors") } foo6() foo7 <- function() { a.foo7 <- lm(y~x1+x2, model=FALSE) y[1] <- Inf options <- options("warn") on.exit(options(warn=options$warn)) options(warn=2) expect.err(try(plotmo(a.foo7, col.response=3)), "non-finite values returned by plotmo_y") } foo7() options(warn=1) foo8 <- function() { i <- 1 a.foo8 <- lm(y~x[,i]+x[,2]) options <- options("warn") on.exit(options(warn=options$warn)) options(warn=2) expect.err(try(plotmo(a.foo8)), "Cannot determine which variables to plot in degree2 plots (use all2=TRUE?)") options(warn=options$warn) expect.err(try(plotmo(a.foo8)), "predict returned the wrong length (got 10 but expected 50)") } foo8() options(warn=1) foo9 <- function() { my.list <- list(j=2) a.foo9 <- lm(y~x[,1]+x[,my.list$j]) expect.err(try(plotmo(a.foo9)), "cannot get the original model predictors") } foo9() foo9a <- function() { df <- data.frame(y=y, x1=x[,1], x2=x[,2]) a.foo9a <- lm(y~x1+x2, data=df) par(mfrow = c(2, 2), oma=c(0,0,4,0)) set.seed(2018) plotmo(a.foo9a, col.resp=2, do.par=FALSE, caption="top two plots should be identical to bottom two plots") x2 <- rep(99, length(x2)) a.foo9b <- lm(y~x1+x2, data=df) x2 <- rep(199, length(x2)) plotmo(a.foo9b, col.resp=2, do.par=FALSE) } foo9a() par(org.par) foo20.func <- function() { par(mfrow = c(2, 2), oma=c(0,0,4,0)) foo20 <- lm(y~x1+x2) set.seed(2018) plotmo(foo20, degree1=1:2, col.resp=2, do.par=FALSE, caption="top two plots should be identical to bottom two plots\nbecause we use saved lm$model") x1 <- 99 plotmo(foo20, degree1=1:2, col.resp=2, do.par=FALSE) } foo20.func() par(org.par) set.seed(1235) tit <- etitanic tit <- tit[c(30:80,330:380,630:680), ] a <- earth(survived~., data=tit, glm=list(family=binomial), degree=2) plotmo(a, grid.levels=list(sex="ma"), caption="smooth: survived, sex=\"m\" jitter=1", smooth.col="indianred", smooth.lwd=2, col.response=as.numeric(tit$survived)+2, pt.pch=".", type2="im", pt.cex=3, jitter=1) # big jitter set.seed(1238) a <- earth(pclass~., data=tit) plotmo(a, type="class", nresponse=1, grid.levels=list(sex="ma"), caption="smooth: pclass, sex=\"m\"", SHOWCALL=TRUE, smooth.col="indianred", smooth.lwd=2, col.response=as.numeric(tit$pclass)+1, type2="im", pt.pch=".", pt.cex=3) plotmo(a, type="class", nresponse=1, grid.levels=list(sex="ma"), caption="smooth: pclass, sex=\"m\" jitter=.3", SHOWCALL=TRUE, smooth.col="indianred", smooth.lwd=2, col.response=as.numeric(tit$pclass)+1, type2="im", pt.pch="x", jit=.3) # small jitter plotmo(a, nresponse=1, type="class", grid.levels=list(sex="ma"), caption="smooth: pclass, sex=\"m\"", SHOWCALL=TRUE, smooth.col="indianred", smooth.lwd=2, col.response=as.numeric(tit$pclass)+1, type2="im", pt.pch=paste(1:nrow(tit))) # test the extend argument plotmo(a, nresponse=1, pt.col=2, degree2=0, SHOWCALL=TRUE, caption="test extend: extend=0 (reference plot)") plotmo(a, nresponse=1, extend=.5, pt.col=2, SHOWCALL=TRUE, caption="test extend: extend=.5") plotmo(a, nresponse=1, degree1=0, extend=.2, pt.col=2, SHOWCALL=TRUE) # nothing to plot a <- earth(survived~pclass+age, data=etitanic, degree=2) # expect warning: extend=.5 not degree2 plots plotmo(a, extend=.5, pt.col=2, SHOWCALL=TRUE, caption="test extend: extend=.5") # intercept only models dopar(2, 2, caption = "intercept-only models") set.seed(1) x <- 1:10 y <- runif(length(x)) earth.intercept.only <- earth(x, y) plotmo(earth.intercept.only, do.par=FALSE, main="earth intercept-only model") plotmo(earth.intercept.only, do.par=FALSE, col.response=1, pt.pch=20) # TODO following draws a plot but it shouldn't (very minor bug because int-only model with a bad degree1 spec) plotmo(earth.intercept.only, do.par=FALSE, degree1=3) # expect warning: 'degree1' specified but no degree1 plots plotmo(earth.intercept.only, do.par=FALSE, degree1=0) # expect warning: plotmo: nothing to plot library(rpart) rpart.intercept.only <- rpart(y~x) plotmo(rpart.intercept.only, do.par=FALSE, main="rpart.plot intercept-only model") plotmo(rpart.intercept.only, do.par=FALSE, degree1=0) par(org.par) # nrug argument par(mfrow=c(3,3), mar=c(3,3,3,1), mgp=c(1.5, 0.5, 0)) mod.nrug <- earth(survived~age, data=etitanic) set.seed(2016) plotmo(mod.nrug, do.par=0, nrug=-1, main="nrug=-1") plotmo(mod.nrug, do.par=0, nrug=TRUE, main="nrug=TRUE") plotmo(mod.nrug, do.par=0, nrug=10, rug.col=2, main="nrug=10, rug.col=2") plotmo(mod.nrug, do.par=0, nrug=5, rug.col=2, rug.lwd=2, main="nrug=5, rug.col=2, rug.lwd=2") plotmo(mod.nrug, do.par=0, nrug="density", main="nrug=\"density\"") plotmo(mod.nrug, do.par=0, nrug="density", density.col=2, density.lwd=2, main="nrug=\"density\"\ndensity.col=2, density.lwd=2") plotmo(mod.nrug, do.par=0, nrug="density", density.adj=.2, density.col=1, main="nrug=\"density\"\ndensity.adj=.2, density.col=1") par(org.par) # a <- earth(ozone1[,3]~ozone1[,1]+ozone1[,2]+ozone1[,4]+ozone1[,5]+ozone1[,6], data=ozone1) # # TODO fails: actual.nrows=330 expected.nrows=50 fitted.nrows=330 # plotmo(a) # # TODO following fails in plotmo with # # Error : get.earth.x from model.matrix.earth from predict.earth: x has 2 columns, expected 4 to match: 1 2 3 Girth # a <- earth(Volume~poly(Height, degree=3)+Girth, data=trees, subset=4:23, linpreds=TRUE) # plotmo(a, trace=-1, do.par=FALSE, caption="all three rows should be the same") source("test.epilog.R") plotmo/inst/slowtests/test.mlr.bat0000755000176200001440000000142314655214117017061 0ustar liggesusers@rem test.mlr.bat: mlr tests for plotmo and plotres @echo test.mlr.bat @"C:\PROGRA~1\R\R-4.4.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.parsnip.Rout.save0000644000176200001440000010707114664170304021065 0ustar liggesusers> # test.parsnip.R: test the parsnip package with earth and other models > # Stephen Milborrow Sep 2020 Petaluma > > source("test.prolog.R") > options(warn=1) # print warnings as they occur > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix > cat("loading parsnip libraries\n") # these libraries take several seconds to load loading parsnip libraries > library(tidymodels, quietly=TRUE, verbose=FALSE) ── Attaching packages ────────────────────────────────────── tidymodels 1.2.0 ── ✔ broom 1.0.6 ✔ recipes 1.1.0 ✔ dials 1.3.0 ✔ rsample 1.2.1 ✔ dplyr 1.1.4 ✔ tibble 3.2.1 ✔ ggplot2 3.5.1 ✔ tidyr 1.3.1 ✔ infer 1.0.7 ✔ tune 1.2.1 ✔ modeldata 1.4.0 ✔ workflows 1.1.4 ✔ parsnip 1.2.1 ✔ workflowsets 1.1.0 ✔ purrr 1.0.2 ✔ yardstick 1.3.1 ── Conflicts ───────────────────────────────────────── tidymodels_conflicts() ── ✖ purrr::%||%() masks base::%||%() ✖ purrr::discard() masks scales::discard() ✖ dplyr::filter() masks stats::filter() ✖ dplyr::lag() masks stats::lag() ✖ recipes::step() masks stats::step() > library(timetk) Attaching package: 'timetk' The following object is masked from 'package:base': %||% > library(lubridate) Attaching package: 'lubridate' The following objects are masked from 'package:base': date, intersect, setdiff, union > cat("loaded parsnip libraries\n") loaded parsnip libraries > cat("parsnip version:", as.character(packageVersion("parsnip")[[1]]), "\n") parsnip version: 1.2.1 > > vdata <- data.frame( + resp = 1:23, + bool = c(F, F, F, F, F, T, T, T, T, T, T, T, T, F, F, T, T, T, T, T, T, T, T), + ord = ordered(c("ORD1", "ORD1", "ORD1", + "ORD1", "ORD1", "ORD1", + "ORD1", "ORD3", "ORD1", + "ORD2", "ORD2", "ORD2", "ORD2", + "ORD2", "ORD2", "ORD2", + "ORD3", "ORD3", "ORD3", + "ORD2", "ORD2", "ORD2", "ORD2"), + levels=c("ORD1", "ORD3", "ORD2")), + fac = as.factor(c("FAC1", "FAC1", "FAC1", + "FAC2", "FAC2", "FAC2", + "FAC3", "FAC1", "FAC1", + "FAC1", "FAC2", "FAC2", "FAC2", + "FAC2", "FAC2", "FAC2", + "FAC3", "FAC3", "FAC3", + "FAC1", "FAC3", "FAC3", "FAC3")), + str = c("STR1", "STR1", "STR1", # WILL BE TREATED LIKE A FACTOR + "STR1", "STR1", "STR1", + "STR2", "STR2", "STR2", + "STR3", "STR3", "STR2", "STR3", + "STR2", "STR3", "STR2", + "STR3", "STR3", "STR3", + "STR3", "STR3", "STR3", "STR3"), + num = c(1, 9, 2, 3, 14, 5, 6, 4, 5, 6.5, 3, 6, 5, + 3, 4, 5, 6, 4, 5, 16.5, 3, 16, 15), + sqrt_num = sqrt( + c(1, 9, 2, 3, 14, 5, 6, 4, 5, 6.5, 3, 6, 5, + 3, 4, 5, 6, 4, 5, 16.5, 3, 16, 15)), + int = c(1L, 1L, 3L, 3L, 4L, 4L, 3L, 5L, 3L, 6L, 7L, 8L, 10L, + 13L, 14L, 3L, 13L, 5L, 13L, 16L, 17L, 18L, 11L), + date = as.Date( + c("2018-08-01", "2018-08-02", "2018-08-03", + "2018-08-04", "2018-08-05", "2018-08-06", + "2018-08-07", "2018-08-08", "2018-08-08", + "2018-08-10", "2018-08-10", "2018-08-11", "2018-08-11", + "2018-08-11", "2018-08-12", "2018-08-13", + "2018-08-10", "2018-08-15", "2018-08-17", + "2018-08-04", "2018-08-19", "2018-08-03", "2018-08-18")), + date_num = as.numeric(as.Date( + c("2018-08-01", "2018-08-02", "2018-08-03", + "2018-08-04", "2018-08-05", "2018-08-06", + "2018-08-07", "2018-08-08", "2018-08-08", + "2018-08-10", "2018-08-10", "2018-08-11", "2018-08-11", + "2018-08-11", "2018-08-12", "2018-08-13", + "2018-08-10", "2018-08-15", "2018-08-17", + "2018-08-04", "2018-08-19", "2018-08-03", "2018-08-18")))) > > set.seed(2020) > splits <- initial_time_split(vdata, prop=.9) > > #--- lm ---------------------------------------------------------------------- > > lm1 <- lm(resp~num+fac:int+date+ord+str, data=training(splits)) > cat("lm1:\n") lm1: > print(summary(lm1)) Call: lm(formula = resp ~ num + fac:int + date + ord + str, data = training(splits)) Residuals: Min 1Q Median 3Q Max -3.9119 -0.6559 -0.0438 0.7549 3.1946 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) -1.396e+04 5.559e+03 -2.511 0.0309 * num 1.818e-01 1.883e-01 0.966 0.3571 date 7.867e-01 3.132e-01 2.512 0.0308 * ord.L 1.254e+00 2.009e+00 0.624 0.5465 ord.Q 3.783e-01 1.910e+00 0.198 0.8470 strSTR2 5.801e-01 2.381e+00 0.244 0.8124 strSTR3 3.341e-01 3.136e+00 0.107 0.9173 facFAC1:int 6.908e-01 3.066e-01 2.253 0.0479 * facFAC2:int 2.891e-01 2.116e-01 1.366 0.2018 facFAC3:int 5.818e-01 2.621e-01 2.220 0.0507 . --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 2.341 on 10 degrees of freedom Multiple R-squared: 0.9176, Adjusted R-squared: 0.8435 F-statistic: 12.38 on 9 and 10 DF, p-value: 0.0002531 > set.seed(2020) > lmpar <- linear_reg(mode = "regression") %>% + set_engine("lm") %>% + fit(resp~num+fac:int+date+ord+str, data = training(splits)) > stopifnot(identical(lm1$coeff, lmpar$fit$coeff)) > > predict.lm1 <- predict(lm1, testing(splits)) > predict.lmpar <- lmpar %>% predict(testing(splits)) > stopifnot(all(predict.lm1 == predict.lmpar)) > > par(mfrow = c(3, 3), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) > plotmo(lm1, do.par=2, SHOWCALL=TRUE) plotmo grid: num fac int date ord str 5 FAC2 5 2018-08-09 ORD1 STR3 > plotres(lm1, which=c(3,1), do.par=FALSE) > plotmo(lmpar, do.par=2, SHOWCALL=TRUE) plotmo grid: num fac int date ord str 5 FAC2 5 2018-08-09 ORD1 STR3 > plotres(lmpar, which=c(3,1), do.par=FALSE) > plotmo(lmpar$fit, do.par=2, SHOWCALL=TRUE) plotmo grid: num fac int date ord str 5 FAC2 5 2018-08-09 ORD1 STR3 > plotres(lmpar$fit, which=c(3,1), do.par=FALSE) > par(org.par) > > lmpar.sqrtnum <- linear_reg(mode = "regression") %>% + set_engine("lm") %>% + fit(resp~sqrt(num), data = training(splits)) > #$$ TODO > # expect.err(try(plotmo(lmpar.sqrtnum)), > # "cannot get the original model predictors") > > #--- earth ------------------------------------------------------------------- > > # note that sqrt(num) is ok, unlike parsnip models for lm and rpart > earth1 <- earth(resp~sqrt(num)+int+ord:bool+fac+str+date, degree=2, + data=training(splits), pmethod="none") > cat("earth1:\n") earth1: > print(summary(earth1)) Call: earth(formula=resp~sqrt(num)+int+ord:bool+fac+str+date, data=training(splits), pmethod="none", degree=2) coefficients (Intercept) 7.86702 ordORD2:boolTRUE -0.81733 h(5-int) 0.46965 h(int-5) 2587.95933 h(17751-date) -1.23206 h(date-17751) 1.48020 h(int-5) * facFAC2 -0.35097 h(int-5) * date -0.14573 Selected 8 of 8 terms, and 4 of 13 predictors (pmethod="none") Termination condition: GRSq -Inf at 8 terms Importance: int, date, facFAC2, ordORD2:boolTRUE, sqrt(num)-unused, ... Number of terms at each degree of interaction: 1 5 2 GCV 19.29495 RSS 2.170681 GRSq 0.47628 RSq 0.9967358 > set.seed(2020) > earthpar <- mars(mode = "regression", prune_method="none", prod_degree=2) %>% + set_engine("earth") %>% + fit(resp~sqrt(num)+int+ord:bool+fac+str+date, data = training(splits)) > cat("earthpar:\n") earthpar: > print(earthpar) parsnip model object Selected 8 of 8 terms, and 4 of 13 predictors (pmethod="none") Termination condition: GRSq -Inf at 8 terms Importance: int, date, facFAC2, ordORD2:boolTRUE, sqrt(num)-unused, ... Number of terms at each degree of interaction: 1 5 2 GCV 19.29495 RSS 2.170681 GRSq 0.47628 RSq 0.9967358 > cat("summary(earthpar$fit)\n") summary(earthpar$fit) > print(summary(earthpar$fit)) Call: earth(formula=resp~sqrt(num)+int+ord:bool+fac+str+date, data=data, pmethod=~"none", keepxy=TRUE, degree=~2) coefficients (Intercept) 7.86702 ordORD2:boolTRUE -0.81733 h(5-int) 0.46965 h(int-5) 2587.95933 h(17751-date) -1.23206 h(date-17751) 1.48020 h(int-5) * facFAC2 -0.35097 h(int-5) * date -0.14573 Selected 8 of 8 terms, and 4 of 13 predictors (pmethod="none") Termination condition: GRSq -Inf at 8 terms Importance: int, date, facFAC2, ordORD2:boolTRUE, sqrt(num)-unused, ... Number of terms at each degree of interaction: 1 5 2 GCV 19.29495 RSS 2.170681 GRSq 0.47628 RSq 0.9967358 > stopifnot(identical(earth1$coeff, earthpar$fit$coeff)) > > predict.earth1 <- predict(earth1, testing(splits)) > predict.earthpar <- earthpar %>% predict(testing(splits)) > stopifnot(all(predict.earth1 == predict.earthpar)) > > par(mfrow = c(3, 3), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) > plotmo(earth1, do.par=2, pt.col=3, SHOWCALL=TRUE) plotmo grid: num int ord bool fac str date 5 5 ORD1 TRUE FAC2 STR3 2018-08-09 > set.seed(2020) > plotres(earth1, which=c(1,3), do.par=FALSE, pt.col=3, legend.pos="topleft") > par(org.par) > > par(mfrow = c(3, 3), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) > plotmo(earthpar, do.par=2, pt.col=3, SHOWCALL=TRUE) plotmo grid: num int ord bool fac str date 5 5 ORD1 TRUE FAC2 STR3 2018-08-09 > set.seed(2020) > plotres(earthpar, which=c(1,3), do.par=FALSE, pt.col=3, legend.pos="topleft") > par(org.par) > > par(mfrow = c(3, 3), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) > plotmo(earthpar$fit, do.par=2, pt.col=3, SHOWCALL=TRUE) plotmo grid: num int ord bool fac str date 5 5 ORD1 TRUE FAC2 STR3 2018-08-09 > set.seed(2020) > plotres(earthpar$fit, which=c(1,3), do.par=FALSE, pt.col=3, legend.pos="topleft") > par(org.par) > > #--- rpart ------------------------------------------------------------------- > > library(rpart) Attaching package: 'rpart' The following object is masked from 'package:dials': prune > library(rpart.plot) > rpart1 <- rpart(resp~num+fac+int+date+ord+str, data=training(splits), + control=rpart.control(minsplit=1, cp=.0001)) > cat("\nrpart.rules(rpart1)\n") rpart.rules(rpart1) > print(rpart.rules(rpart1)) resp 1 when ord is ORD1 & date < 17748 & num < 5.0 & int < 2 2 when ord is ORD1 & date < 17748 & num >= 5.0 & int < 2 3 when ord is ORD1 & date < 17748 & num < 2.5 & int >= 2 4 when ord is ORD1 & date < 17748 & num >= 2.5 & int >= 2 5 when ord is ORD1 & date >= 17748 & num >= 10.0 & fac is FAC2 or FAC3 6 when ord is ORD1 & date >= 17748 & num < 5.5 & fac is FAC2 or FAC3 7 when ord is ORD1 & date >= 17748 & num is 5.5 to 10.0 & fac is FAC2 or FAC3 9 when ord is ORD1 & date >= 17748 & fac is FAC1 14 when ord is ORD3 or ORD2 > > set.seed(2020) > # TODO note need of model=TRUE below (needed only for further processing with e.g. plotmo) > rpartpar <- decision_tree(mode = "regression", min_n=1, cost_complexity=.0001) %>% + set_engine("rpart", model=TRUE) %>% + fit(resp~num+fac+int+date+ord+str, data = training(splits)) > cat("\nrpart.rules(rpartpar$fit)\n") rpart.rules(rpartpar$fit) > print(rpart.rules(rpartpar$fit)) resp 1 when ord is ORD1 & date < 17748 & num < 5.0 & int < 2 2 when ord is ORD1 & date < 17748 & num >= 5.0 & int < 2 3 when ord is ORD1 & date < 17748 & num < 2.5 & int >= 2 4 when ord is ORD1 & date < 17748 & num >= 2.5 & int >= 2 5 when ord is ORD1 & date >= 17748 & num >= 10.0 & fac is FAC2 or FAC3 6 when ord is ORD1 & date >= 17748 & num < 5.5 & fac is FAC2 or FAC3 7 when ord is ORD1 & date >= 17748 & num is 5.5 to 10.0 & fac is FAC2 or FAC3 9 when ord is ORD1 & date >= 17748 & fac is FAC1 14 when ord is ORD3 or ORD2 > > predict.rpart1 <- predict(rpart1, testing(splits)) > predict.rpartpar <- rpartpar %>% predict(testing(splits)) > stopifnot(all(predict.rpart1 == predict.rpartpar)) > > par(mfrow = c(3, 3), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) > plotmo(rpart1, do.par=2, SHOWCALL=TRUE, trace=0) plotmo grid: num fac int date ord str 5 FAC2 5 2018-08-09 ORD1 STR3 > plotres(rpart1, which=c(3,1), do.par=FALSE) > plotmo(rpartpar, do.par=2, SHOWCALL=TRUE, trace=0) plotmo grid: num fac int date ord str 5 FAC2 5 2018-08-09 ORD1 STR3 > plotres(rpartpar, which=c(3,1), do.par=FALSE) > plotmo(rpartpar$fit, do.par=2, SHOWCALL=TRUE) plotmo grid: num fac int date ord str 5 FAC2 5 2018-08-09 ORD1 STR3 > plotres(rpartpar$fit, which=c(3,1), do.par=FALSE) > par(org.par) > > # TODO note that this differs from the above rpart model in that we don't use model=TRUE > rpartpar.nosavemodel <- decision_tree(mode = "regression", min_n=1, cost_complexity=.0001) %>% + set_engine("rpart") %>% + fit(resp~num+fac+int+date+str, data = training(splits)) > > cat("\nrpart.rules(rpartpar.nosavemodel$fit)\n") rpart.rules(rpartpar.nosavemodel$fit) > options(warn=2) > expect.err(try(rpart.rules(rpartpar.nosavemodel$fit)), + "Cannot retrieve the data used to build the model") Error : (converted from warning) Cannot retrieve the data used to build the model (so cannot determine roundint and is.binary for the variables). To silence this warning: Call rpart.rules with roundint=FALSE, or rebuild the rpart model with model=TRUE. Got expected error from try(rpart.rules(rpartpar.nosavemodel$fit)) > options(warn=1) > expect.err(try(plotmo(rpartpar.nosavemodel)), + "Cannot plot parsnip rpart model: need model=TRUE in call to rpart") Error : Cannot plot parsnip rpart model: need model=TRUE in call to rpart Do it like this: set_engine("rpart", model=TRUE) Got expected error from try(plotmo(rpartpar.nosavemodel)) > > rpart.sqrtnum <- decision_tree(mode = "regression", min_n=1, cost_complexity=.0001) %>% + set_engine("rpart", model=TRUE) %>% + fit(resp~sqrt(num)+fac+int+date+ord+str, data = training(splits)) > cat("\nrpart.rules(rpart.sqrtnum$fit)\n") rpart.rules(rpart.sqrtnum$fit) > print(rpart.rules(rpart.sqrtnum$fit)) # ok resp 1 when ord is ORD1 & date < 17748 & sqrt(num) < 2.0 & int < 2 2 when ord is ORD1 & date < 17748 & sqrt(num) >= 2.0 & int < 2 3 when ord is ORD1 & date < 17748 & sqrt(num) < 1.6 & int >= 2 4 when ord is ORD1 & date < 17748 & sqrt(num) >= 1.6 & int >= 2 5 when ord is ORD1 & date >= 17748 & sqrt(num) >= 3.1 & fac is FAC2 or FAC3 6 when ord is ORD1 & date >= 17748 & sqrt(num) < 2.3 & fac is FAC2 or FAC3 7 when ord is ORD1 & date >= 17748 & sqrt(num) is 2.3 to 3.1 & fac is FAC2 or FAC3 9 when ord is ORD1 & date >= 17748 & fac is FAC1 14 when ord is ORD3 or ORD2 > #$$ TODO > # expect.err(try(plotmo(rpart.sqrtnum)), > # "cannot get the original model predictors") > > #----------------------------------------------------------------------------------- > # Test fix for github bug report https://github.com/tidymodels/parsnip/issues/341 > # (fixed Sep 2020) > > cat("===m750a first example===\n") ===m750a first example=== > set.seed(2020) > m750a <- m4_monthly %>% + filter(id == "M750") %>% + select(-id) > print(m750a) # a tibble # A tibble: 306 × 2 date value 1 1990-01-01 6370 2 1990-02-01 6430 3 1990-03-01 6520 4 1990-04-01 6580 5 1990-05-01 6620 6 1990-06-01 6690 7 1990-07-01 6000 8 1990-08-01 5450 9 1990-09-01 6480 10 1990-10-01 6820 # ℹ 296 more rows > set.seed(2020) > splits_a <- initial_time_split(m750a, prop = 0.9) > earth_m750a <- earth(log(value) ~ as.numeric(date) + month(date, label = TRUE), data = training(splits_a), degree=2) > print(summary(earth_m750a)) Call: earth(formula=log(value)~as.numeric(date)+month(date,label=TRUE), data=training(splits_a), degree=2) coefficients (Intercept) 1.000000e+01 h(as.numeric(date)-7639) 0.000000e+00 h(as.numeric(date)-9100) 0.000000e+00 h(12022-as.numeric(date)) 0.000000e+00 h(as.numeric(date)-13483) 0.000000e+00 h(as.numeric(date)-14579) 0.000000e+00 h(0.370142-month(date, label = TRUE)^7) 0.000000e+00 h(month(date, label = TRUE)^7-0.370142) 0.000000e+00 h(month(date, label = TRUE)^10-0.491049) -3.077492e+12 h(as.numeric(date)-9100) * h(-0.254544-month(date, label = TRUE)^8) 0.000000e+00 h(as.numeric(date)-13483) * h(month(date, label = TRUE)^11- -0.392904) 0.000000e+00 h(as.numeric(date)-13483) * h(-0.392904-month(date, label = TRUE)^11) 0.000000e+00 h(0.491049-month(date, label = TRUE)^10) * h(month(date, label = TRUE)^11-0.065484) 0.000000e+00 h(0.491049-month(date, label = TRUE)^10) * h(0.065484-month(date, label = TRUE)^11) 0.000000e+00 Selected 14 of 17 terms, and 5 of 12 predictors Termination condition: RSq changed by less than 0.001 at 17 terms Importance: as.numeric(date), month(date, label = TRUE)^10, ... Number of terms at each degree of interaction: 1 8 5 GCV 0.0004725457 RSS 0.1002179 GRSq 0.9834104 RSq 0.9871125 > set.seed(2020) > model_m750a <- mars(mode = "regression", prod_degree=2) %>% + set_engine("earth") %>% + fit(log(value) ~ as.numeric(date) + month(date, label = TRUE), data = training(splits_a)) > print(summary(model_m750a$fit)) Call: earth(formula=log(value)~as.numeric(date)+month(date,label=TRUE), data=data, keepxy=TRUE, degree=~2) coefficients (Intercept) 1.000000e+01 h(as.numeric(date)-7639) 0.000000e+00 h(as.numeric(date)-9100) 0.000000e+00 h(12022-as.numeric(date)) 0.000000e+00 h(as.numeric(date)-13483) 0.000000e+00 h(as.numeric(date)-14579) 0.000000e+00 h(0.370142-month(date, label = TRUE)^7) 0.000000e+00 h(month(date, label = TRUE)^7-0.370142) 0.000000e+00 h(month(date, label = TRUE)^10-0.491049) -3.077492e+12 h(as.numeric(date)-9100) * h(-0.254544-month(date, label = TRUE)^8) 0.000000e+00 h(as.numeric(date)-13483) * h(month(date, label = TRUE)^11- -0.392904) 0.000000e+00 h(as.numeric(date)-13483) * h(-0.392904-month(date, label = TRUE)^11) 0.000000e+00 h(0.491049-month(date, label = TRUE)^10) * h(month(date, label = TRUE)^11-0.065484) 0.000000e+00 h(0.491049-month(date, label = TRUE)^10) * h(0.065484-month(date, label = TRUE)^11) 0.000000e+00 Selected 14 of 17 terms, and 5 of 12 predictors Termination condition: RSq changed by less than 0.001 at 17 terms Importance: as.numeric(date), month(date, label = TRUE)^10, ... Number of terms at each degree of interaction: 1 8 5 GCV 0.0004725457 RSS 0.1002179 GRSq 0.9834104 RSq 0.9871125 > stopifnot(identical(earth_m750a$coeff, model_m750a$fit$coeff)) > predict_earth_m750a <- predict(earth_m750a, newdata=testing(splits_a)[1:3,]) > predict_m750a <- model_m750a %>% predict(testing(splits_a)[1:3,]) > stopifnot(max(c(9.238049628, 9.240535151, 9.232361834) - predict_m750a) < 1e-8) > stopifnot(max(predict_earth_m750a - predict_m750a) < 1e-20) > > par(mfrow = c(2, 2), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) > set.seed(2020) > plotmo(model_m750a, trace=2, do.par=FALSE, pt.col="green", main="model_m750a", SHOWCALL=TRUE) plotmo trace 2: plotmo(object=model_m750a, pt.col="green", do.par=FALSE, trace=2, main="model_m750a", SHOWCALL=TRUE) --get.model.env for object with class _earth plotmo parsnip model: will plot model_m750a$fit, not 'model_m750a' itself object call is earth(formula=log(value)~as.numeric(date)+month(date, label=TRUE), data=data, keepxy=TRUE, degree=~2) using the environment saved in $terms of the earth model: env(data, weights) --plotmo_prolog for _earth object 'model_m750a' --plotmo_x for earth object get.object.x: object$x is NULL (and it has no colnames) object call is earth(formula=log(value)~as.numeric(date)+month(date, label=TRUE), data=data,... get.x.from.model.frame: formula(object) is log(value) ~ as.numeric(date) + month(date, label = TRUE) naked formula is log(value) ~ date formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) object$data is usable and has column names date value na.action(object) is "na.fail" stats::model.frame(log(value) ~ date, data=object$data, na.action="na.fail") x=model.frame[,-1] is usable and has column name date plotmo_x returned[275,1]: date 1 1990-01-01 2 1990-02-01 3 1990-03-01 ... 1990-04-01 275 2012-11-01 ----Metadata: plotmo_predict with nresponse=NULL and newdata=NULL calling predict.earth with NULL newdata stats::predict(earth.object, NULL, type="response") predict returned[275,1]: log(value) 1 8.779940 2 8.777069 3 8.795003 ... 8.799953 275 9.244442 predict after processing with nresponse=NULL is [275,1]: log(value) 1 8.779940 2 8.777069 3 8.795003 ... 8.799953 275 9.244442 ----Metadata: plotmo_fitted with nresponse=NULL stats::fitted(object=earth.object) fitted(object) returned[275,1]: log(value) 1 8.779940 2 8.777069 3 8.795003 ... 8.799953 275 9.244442 fitted(object) after processing with nresponse=NULL is [275,1]: log(value) 1 8.779940 2 8.777069 3 8.795003 ... 8.799953 275 9.244442 ----Metadata: plotmo_y with nresponse=NULL --plotmo_y with nresponse=NULL for earth object get.object.y: object$y is usable and has column name log(value) plotmo_y returned[275,1]: log(value) 1 8.759355 2 8.768730 3 8.782630 ... 8.791790 275 9.271435 plotmo_y after processing with nresponse=NULL is [275,1]: log(value) 1 8.759355 2 8.768730 3 8.782630 ... 8.791790 275 9.271435 converted nresponse=NA to nresponse=1 nresponse=1 (was NA) ncol(fitted) 1 ncol(predict) 1 ncol(y) 1 ----Metadata: plotmo_y with nresponse=1 --plotmo_y with nresponse=1 for earth object get.object.y: object$y is usable and has column name log(value) got model response from object$y plotmo_y returned[275,1]: log(value) 1 8.759355 2 8.768730 3 8.782630 ... 8.791790 275 9.271435 plotmo_y after processing with nresponse=1 is [275,1]: log(value) 1 8.759355 2 8.768730 3 8.782630 ... 8.791790 275 9.271435 got response name "log(value)" from yhat resp.levs is NULL ----Metadata: done number of x values: date 275 ----plotmo_singles for earth object singles: 1 date ----plotmo_pairs for earth object no pairs ----Figuring out ylim --get.ylim.by.dummy.plots --plot.degree1(draw.plot=FALSE) degree1 plot1 (pmethod "plotmo") variable date newdata[50,1]: date 1 1990-01-01 2 1990-06-20 3 1990-12-07 ... 1991-05-26 50 2012-11-01 stats::predict(earth.object, data.frame[50,1], type="response") predict returned[50,1]: log(value) 1 8.779940 2 8.797283 3 8.835027 ... 8.843453 50 9.244442 predict after processing with nresponse=1 is [50,1]: log(value) 1 8.779940 2 8.797283 3 8.835027 ... 8.843453 50 9.244442 --done get.ylim.by.dummy.plots ylim c(8.603, 9.289) clip TRUE --plot.degree1(draw.plot=TRUE) graphics::plot.default(x=Date:1990-01-01 1990-06-20 1990-12..., y=c(8.78,8.797,8...), type="n", main="model_m750a", xlab="", ylab="", xaxt="s", yaxt="s", xlim=Date:1990-01-01 2012-11-01, ylim=c(8.603,9.289)) > set.seed(2020) > plotmo(model_m750a$fit, trace=1, do.par=FALSE, pt.col="green", main="model_m750a$fit", SHOWCALL=TRUE) stats::predict(earth.object, NULL, type="response") stats::fitted(object=earth.object) got model response from object$y > set.seed(2020) > plotmo(earth_m750a, trace=1, do.par=FALSE, pt.col="green", main="earth_m750a", SHOWCALL=TRUE) stats::predict(earth.object, NULL, type="response") stats::fitted(object=earth.object) got model response from model.frame(log(value) ~ as.numeric(date) + month..., data=call$data, na.action="na.fail") > par(org.par) > > cat("===m750a second example===\n") ===m750a second example=== > set.seed(2020) > m750b <- m4_monthly %>% + filter(id == "M750") %>% + select(-id) %>% + rename(date2 = date) > print(m750b) # tibble # A tibble: 306 × 2 date2 value 1 1990-01-01 6370 2 1990-02-01 6430 3 1990-03-01 6520 4 1990-04-01 6580 5 1990-05-01 6620 6 1990-06-01 6690 7 1990-07-01 6000 8 1990-08-01 5450 9 1990-09-01 6480 10 1990-10-01 6820 # ℹ 296 more rows > set.seed(2020) > splits_b <- initial_time_split(m750b, prop = 0.9) > set.seed(2020) > model_m750b <- mars(mode = "regression") %>% + set_engine("earth") %>% + fit(log(value) ~ as.numeric(date2) + month(date2, label = TRUE), data = training(splits_b)) > # new data that only contains the feature "date" as a predictor > future_data <- m750b %>% future_frame(date2, .length_out = "3 years") > print(future_data) # a tibble with a single column of class "Date" # A tibble: 36 × 1 date2 1 2015-07-01 2 2015-08-01 3 2015-09-01 4 2015-10-01 5 2015-11-01 6 2015-12-01 7 2016-01-01 8 2016-02-01 9 2016-03-01 10 2016-04-01 # ℹ 26 more rows > stopifnot(class(future_data[,1,drop=TRUE]) == "Date") > predict_m750a <- model_m750b %>% predict(new_data = future_data) > > par(mfrow = c(2, 2), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) > set.seed(2020) > plotmo(model_m750b, trace=2, do.par=FALSE, pt.col="green", main="model_m750b", SHOWCALL=TRUE) plotmo trace 2: plotmo(object=model_m750b, pt.col="green", do.par=FALSE, trace=2, main="model_m750b", SHOWCALL=TRUE) --get.model.env for object with class _earth plotmo parsnip model: will plot model_m750b$fit, not 'model_m750b' itself object call is earth(formula=log(value)~as.numeric(date2)+month(date2, label=TRUE), data=data, keepxy=TRUE) using the environment saved in $terms of the earth model: env(data, weights) --plotmo_prolog for _earth object 'model_m750b' --plotmo_x for earth object get.object.x: object$x is NULL (and it has no colnames) object call is earth(formula=log(value)~as.numeric(date2)+month(date2, label=TRUE), data=dat... get.x.from.model.frame: formula(object) is log(value) ~ as.numeric(date2) + month(date2, label = TRUE) naked formula is log(value) ~ date2 formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) object$data is usable and has column names date2 value na.action(object) is "na.fail" stats::model.frame(log(value) ~ date2, data=object$data, na.action="na.fail") x=model.frame[,-1] is usable and has column name date2 plotmo_x returned[275,1]: date2 1 1990-01-01 2 1990-02-01 3 1990-03-01 ... 1990-04-01 275 2012-11-01 ----Metadata: plotmo_predict with nresponse=NULL and newdata=NULL calling predict.earth with NULL newdata stats::predict(earth.object, NULL, type="response") predict returned[275,1]: log(value) 1 8.773349 2 8.779320 3 8.797022 ... 8.803553 275 9.243245 predict after processing with nresponse=NULL is [275,1]: log(value) 1 8.773349 2 8.779320 3 8.797022 ... 8.803553 275 9.243245 ----Metadata: plotmo_fitted with nresponse=NULL stats::fitted(object=earth.object) fitted(object) returned[275,1]: log(value) 1 8.773349 2 8.779320 3 8.797022 ... 8.803553 275 9.243245 fitted(object) after processing with nresponse=NULL is [275,1]: log(value) 1 8.773349 2 8.779320 3 8.797022 ... 8.803553 275 9.243245 ----Metadata: plotmo_y with nresponse=NULL --plotmo_y with nresponse=NULL for earth object get.object.y: object$y is usable and has column name log(value) plotmo_y returned[275,1]: log(value) 1 8.759355 2 8.768730 3 8.782630 ... 8.791790 275 9.271435 plotmo_y after processing with nresponse=NULL is [275,1]: log(value) 1 8.759355 2 8.768730 3 8.782630 ... 8.791790 275 9.271435 converted nresponse=NA to nresponse=1 nresponse=1 (was NA) ncol(fitted) 1 ncol(predict) 1 ncol(y) 1 ----Metadata: plotmo_y with nresponse=1 --plotmo_y with nresponse=1 for earth object get.object.y: object$y is usable and has column name log(value) got model response from object$y plotmo_y returned[275,1]: log(value) 1 8.759355 2 8.768730 3 8.782630 ... 8.791790 275 9.271435 plotmo_y after processing with nresponse=1 is [275,1]: log(value) 1 8.759355 2 8.768730 3 8.782630 ... 8.791790 275 9.271435 got response name "log(value)" from yhat resp.levs is NULL ----Metadata: done number of x values: date2 275 ----plotmo_singles for earth object singles: 1 date2 ----plotmo_pairs for earth object no pairs ----Figuring out ylim --get.ylim.by.dummy.plots --plot.degree1(draw.plot=FALSE) degree1 plot1 (pmethod "plotmo") variable date2 newdata[50,1]: date2 1 1990-01-01 2 1990-06-20 3 1990-12-07 ... 1991-05-26 50 2012-11-01 stats::predict(earth.object, data.frame[50,1], type="response") predict returned[50,1]: log(value) 1 8.773349 2 8.797894 3 8.831375 ... 8.848941 50 9.243245 predict after processing with nresponse=1 is [50,1]: log(value) 1 8.773349 2 8.797894 3 8.831375 ... 8.848941 50 9.243245 --done get.ylim.by.dummy.plots ylim c(8.603, 9.289) clip TRUE --plot.degree1(draw.plot=TRUE) graphics::plot.default(x=Date:1990-01-01 1990-06-20 1990-12..., y=c(8.773,8.798,8...), type="n", main="model_m750b", xlab="", ylab="", xaxt="s", yaxt="s", xlim=Date:1990-01-01 2012-11-01, ylim=c(8.603,9.289)) > set.seed(2020) > plotmo(model_m750b$fit, trace=1, do.par=FALSE, pt.col="green", main="model_m750b$fit", SHOWCALL=TRUE) stats::predict(earth.object, NULL, type="response") stats::fitted(object=earth.object) got model response from object$y > par(org.par) > > #----------------------------------------------------------------------------------- > # multiple response earth model > > data(etitanic) > > etit <- etitanic > etit$survived <- factor(ifelse(etitanic$survived == 1, "yes", "no"), + levels = c("yes", "no")) > etit$notsurvived <- factor(ifelse(etitanic$survived == 0, "notsurvived", "survived"), + levels = c("notsurvived", "survived")) > set.seed(2020) > earth_tworesp <- earth(survived + notsurvived ~ ., data=etit, degree=2) > print(summary(earth_tworesp)) Call: earth(formula=survived+notsurvived~., data=etit, degree=2) survived notsurvived (Intercept) 0.03829050 0.96170950 pclass3rd 0.81545352 -0.81545352 sexmale 0.57003496 -0.57003496 h(age-32) 0.00471938 -0.00471938 pclass2nd * sexmale 0.26568920 -0.26568920 pclass3rd * sexmale -0.19310203 0.19310203 pclass3rd * h(4-sibsp) -0.10222181 0.10222181 sexmale * h(16-age) -0.04505232 0.04505232 Selected 8 of 17 terms, and 5 of 6 predictors Termination condition: Reached nk 21 Importance: sexmale, pclass3rd, pclass2nd, age, sibsp, parch-unused Number of terms at each degree of interaction: 1 3 4 GCV RSS GRSq RSq survived 0.1404529 141.7629 0.4197106 0.4389834 notsurvived 0.1404529 141.7629 0.4197106 0.4389834 All 0.2809057 283.5258 0.4197106 0.4389834 > > # TODO following commented out because parsnip (version 0.1.5) says "'+' not meaningful for factors" > # set.seed(2020) > # mars_tworesp <- mars(mode = "regression", prod_degree=2) %>% > # set_engine("earth") %>% > # fit(survived + notsurvived~., data=etit) > # print(summary(mars_tworesp)) > # print(summary(mars_tworesp$fit)) > # > # stopifnot(identical(earth_tworesp$coeff, mars_tworesp$fit$coeff)) > # > # predict.earth_tworesp <- predict(earth_tworesp, etit[3:6,]) > # predict.mars_tworesp <- mars_tworesp %>% predict(etit[3:6,]) > # stopifnot(all(predict.earth_tworesp == predict.mars_tworesp)) > # > # plotmo(earth_tworesp, trace=0, nresponse=1, SHOWCALL=TRUE) > # plotmo(mars_tworesp, trace=0, nresponse=1, SHOWCALL=TRUE) > # plotmo(mars_tworesp, trace=0, nresponse=2, SHOWCALL=TRUE) > > source("test.epilog.R") plotmo/inst/slowtests/test.non.earth.R0000644000176200001440000007155313740162254017624 0ustar liggesusers# test.non.earth.R: test plotmo on non-earth models # Stephen Milborrow, Basley KwaZulu-Natal Mar 2011 source("test.prolog.R") library(plotmo) library(earth) data(ozone1) data(etitanic) dopar <- function(nrows, ncols, caption = "") { cat(" ", caption, "\n") par(mfrow=c(nrows, ncols)) par(oma = c(0, 0, 3, 0)) par(mar = c(3, 3, 1.7, 0.5)) par(mgp = c(1.6, 0.6, 0)) par(cex = 0.7) } caption <- "test lm(log(doy) ~ vh+wind+humidity+temp+log(ibh), data=ozone1)" dopar(4,5,caption) a <- lm(log(doy) ~ vh + wind + humidity + temp + log(ibh), data=ozone1) set.seed(2020) plotmo(a, do.par=FALSE, caption=caption, ylim=NA, col.response=3, pt.pch=20, smooth.col="indianred", trace=2) termplot(a) par(org.par) caption <- "test lm(log(doy) ~ vh+wind+humidity+I(wind*humidity)+temp+log(ibh), data=ozone1)" dopar(4,5,caption) a <- lm(log(doy) ~ vh + wind + humidity + temp + log(ibh), data=ozone1) set.seed(2020) plotmo(a, do.par=FALSE, caption=caption, ylim=NA, col.resp=3, pt.pch=20, clip=FALSE, smooth.col="indianred") termplot(a) par(org.par) caption <- "test lm(doy ~ (vh+wind+humidity)^2, data=ozone1)" dopar(4,3,caption) a <- lm(doy ~ (vh+wind+humidity)^2, data=ozone1) plotmo(a, do.par=FALSE, caption=caption, ylim=NULL) # termplot(a) # termplot fails with Error in `[.data.frame`(mf, , i): undefined columns selected par(org.par) caption <- "test lm(doy^2 ~ vh+wind+humidity+I(wind*humidity)+temp+log(ibh), data=ozone1)" dopar(4,3,caption) a <- lm(doy^2 ~ vh+wind+humidity+I(wind*humidity)+temp+log(ibh), data=ozone1) plotmo(a, do.par=FALSE, caption=caption, ylim=NULL) termplot(a) # termplot draws a funky second wind plot par(org.par) caption <- "test lm with data=ozone versus attach(ozone)" dopar(4,3,caption) a <- lm(log(doy) ~ I(vh*wind) + wind + I(humidity*temp) + log(ibh), data=ozone1) plotmo(a, do.par=FALSE, caption=caption, degree1=c(1,2,4,5)) attach(ozone1) a <- lm(log(doy) ~ I(vh*wind) + wind + I(humidity*temp) + log(ibh)) plotmo(a, do.par=FALSE, degree1=c(1,2,4,5)) detach(ozone1) par(org.par) # commented out because "$" in names is not yet supported # a <- lm(log(ozone1$doy) ~ I(ozone1$vh*ozone1$wind) + log(ozone1$ibh)) # plotmo(a) set.seed(1) caption <- "test lm and glm a900..a902: damage~temp family=binomial data=orings" dopar(2,3,caption) library(faraway) data(orings) a900 <- lm(I(damage/6) ~ temp, data=orings) plotmo(a900, do.par=FALSE, caption=caption, col.response=2, nrug=-1, main="lm(damage/6~temp)", smooth.col="indianred", trace=0) response <- cbind(orings$damage, 6-orings$damage) a901 <- glm(response ~ temp, family="binomial", data=orings) set.seed(2020) plotmo(a901, do.par=FALSE, col.response=2, nrug=-1, main="glm(response~temp)", smooth.col="indianred", trace=2) a902 <- glm(cbind(damage, 6-damage)~temp, family="binomial", data=orings) set.seed(2020) plotmo(a902, do.par=FALSE, col.response=2, nrug=TRUE, main="glm(cbind(damage,6-damage)~temp)", trace=0) termplot(a902, main="termplot") plotmo(a902, type="link", main="type=\"link\"", do.par=F) set.seed(2020) plotmo(a902, type="response", main="type=\"response\"", col.response=2, do.par=F) par(org.par) set.seed(1) caption <- "test glm(lot2~log(u),data=clotting,family=Gamma)" dopar(2,2,caption) u = c(5,10,15,20,30,40,60,80,100) lota = c(118,58,42,35,27,25,21,19,18) clotting <- data.frame(u = u, lota = lota) a <- glm(lota ~ log(u), data=clotting, family=Gamma) set.seed(2020) plotmo(a, do.par=FALSE, caption=caption, col.response=3, clip=FALSE, nrug=-1) termplot(a) plotmo(a, type="link", caption=paste("type=\"link\"", caption)) par(org.par) if(length(grep("package:gam", search()))) detach("package:gam") library(mgcv) set.seed(1) caption <- "test plot.gam, with mgcv::gam(y ~ s(x) + s(x,z)) with response and func (and extra image plot)" dopar(3,2,caption) par(mar = c(3, 5, 1.7, 0.5)) # more space for left and bottom axis test1 <- function(x,sx=0.3,sz=0.4) (pi**sx*sz)*(1.2*exp(-(x[,1]-0.2)^2/sx^2-(x[,2]-0.3)^2/sz^2)+ 0.8*exp(-(x[,1]-0.7)^2/sx^2-(x[,2]-0.8)^2/sz^2)) n <- 100 set.seed(1) x <- runif(n); z1 <- runif(n); y <- test1(cbind(x,z1)) + rnorm(n) * 0.1 a <- gam(y ~ s(x) + s(x,z1)) set.seed(2020) plotmo(a, do.par=FALSE, type2="contour", caption=caption, col.response=3, smooth.col="indianred", func=test1, func.col="indianred", func.lwd=5, func.lty=2, smooth.lwd=3) plotmo(a, do.par=FALSE, degree1=F, degree2=1, type2="image", ylim=NA) plot(a, select=1) plot(a, select=2) plot(a, select=3) n<-400 sig<-2 set.seed(1) x0 <- runif(n, 0, 1) x1 <- runif(n, 0, 1) x2 <- runif(n, 0, 1) x3 <- runif(n, 0, 1) f0 <- function(x) 2 * sin(pi * x) f1 <- function(x) exp(2 * x) f2 <- function(x) 0.2*x^11*(10*(1-x))^6+10*(10*x)^3*(1-x)^10 f <- f0(x0) + f1(x1) + f2(x2) e <- rnorm(n, 0, sig) y <- f + e test.func <- function(x) f0(x[,1]) + f1(x[,2]) + f2(x[,3]) library(mgcv) caption <- "test mgcv::gam(y~s(x0,x1,k=12)+s(x2)+s(x3,k=20,fx=20)) (and extra persp plot)" dopar(3,3,caption) a <- gam(y~s(x0,x1,k=12)+s(x2)+s(x3,k=20,fx=20)) plot(a, select=2) plot(a, select=3) plot(a, select=1) plotmo(a, do.par=FALSE, type2="contour", caption=caption, xlab=NULL, main="", func=test.func, ngrid2=10, contour.drawlabels=FALSE) plotmo(a, do.par=FALSE, degree1=F, degree2=1, persp.the=-35) par(org.par) set.seed(1) caption <- "test plot.gam, with mgcv::gam(doy~s(wind)+s(humidity,wind)+s(vh)+temp,data=ozone1)" dopar(3,3,caption) a <- gam(doy ~ s(wind) + s(humidity,wind) + s(vh) + temp, data=ozone1) plotmo(a, do.par=FALSE, caption=caption, type2="contour", degree1=c("wind","vh"), swapxy=T, xlab=NULL, main="", clip=FALSE) plot(a, select=1) plot(a, select=3) plot(a, select=2) plot(a, select=4) par(org.par) detach("package:mgcv") library(gam) caption <- "test gam:gam(Ozone^(1/3)~lo(Solar.R)+lo(Wind, Temp),data=airquality)" set.seed(1) dopar(3,2,caption) data(airquality) airquality <- na.omit(airquality) # plotmo doesn't know how to deal with NAs yet a <- gam(Ozone^(1/3) ~ lo(Solar.R) + lo(Wind, Temp), data = airquality) set.seed(2020) plotmo(a, do.par=FALSE, caption=caption, ylim=NA, col.response=3) # termplot gives fishy looking wind plot, plotmo looks ok # termplot(a) #TODO this fails with R2.5: dim(data) <- dim: attempt to set an attribute on NULL detach("package:gam") par(org.par) library(mda) caption <- "test mars and earth (expect not a close match)" dopar(6,3,caption) a <- mars( ozone1[, -1], ozone1[,1], degree=2) b <- earth(ozone1[, -1], ozone1[,1], degree=2) # this also tests trace=2 on a non formula model plotmo(a, do.par=FALSE, caption=caption, trace=2) plotmo(b, do.par=FALSE) par(org.par) caption <- "test mars and mars.to.earth(mars) (expect no degree2 for mars)" dopar(6,3,caption) a <- mars(ozone1[, -1], ozone1[,1], degree=2) b <- mars.to.earth(a) plotmo(a, do.par=FALSE, caption=caption, ylim=NA) plotmo(b, do.par=FALSE, ylim=NA) par(org.par) # check fix for bug reported by Martin Maechler: # form <- Volume ~ .; a <- earth(form, data = trees); plotmo(a) fails dopar(4,4, "test f <- O3 ~ .; a <- earth(f, data=ozone1)") fa <- log(O3) ~ . a <- earth(fa, data=ozone1, degree=2) print(summary(a)) plot(a, do.par=FALSE) set.seed(2020) plotmo(a, do.par=FALSE, degree1=2:3, degree2=c(1,2), col.response = "pink", smooth.col="indianred") a <- lm(log(doy) ~ I(vh*wind) + I(humidity*temp) + log(ibh), data=ozone1) plotmo(a, do.par=FALSE, degree1=1:2) fa <- log(doy) ~ I(vh*wind) + I(humidity*temp) + log(ibh) a <- lm(fa, data=ozone1) plotmo(a, do.par=FALSE, degree1=1:2) par(org.par) # test inverse.func and func caption <- "test inverse.func=exp" a <- lm(log(Volume) ~ Girth + Height + I(Girth*Height), data=trees) my.func <- function(x) -60 + 5 * x[,1] + x[,2] / 3 set.seed(2020) plotmo(a, caption=caption, inverse.func = exp, col.response = "pink", func=my.func, func.col="gray", ngrid1=1000, type2="p", smooth.col="indianred") par(org.par) # se testing caption = "level=.95, lm(doy~., data=ozone1) versus termplot" dopar(6,3,caption) a <- lm(doy~., data=ozone1) plotmo(a, level=.95, do.par=FALSE, caption=caption) termplot(a, se=2) par(org.par) caption <- "test different se options, level=.95, lm(log(doy)~vh+wind+log(humidity),data=ozone1)" dopar(4,3,caption) a <- lm(log(doy) ~ vh + wind + log(humidity), data=ozone1) plotmo(a, do.par=FALSE, caption=caption, ylim=NA, level=.95) plotmo(a, do.par=FALSE, caption=caption, ylim=NA, level=.95, level.shade="pink", level.shade2=3) plotmo(a, do.par=FALSE, caption=caption, ylim=NA, level=.95, level.shade=3) plotmo(a, do.par=FALSE, caption=caption, ylim=NULL, level=.95, level.shade=3) par(org.par) caption <- "test level=.95, lm(log(doy)~vh+wind+log(humidity),data=ozone1)" dopar(2,3,caption) a <- lm(log(doy) ~ vh + wind + log(humidity), data=ozone1) plotmo(a, do.par=FALSE, caption=caption, ylim=NA, level=.95) termplot(a, se=2) par(org.par) caption <- "test level=.95 and inverse.func, lm(log(doy)~vh+wind+log(humidity),data=ozone1)" dopar(3,3,caption) a <- lm(log(doy) ~ vh + wind + log(humidity), data=ozone1) plotmo(a, do.par=FALSE, caption=caption, ylim=NA, level=.95) plotmo(a, do.par=FALSE, caption=caption, ylim=NULL, level=.95, inverse.func=exp) termplot(a, se=2) par(org.par) caption <- "test level=.95, glm(lot2~log(u),data=clotting,family=Gamma)" set.seed(1) dopar(2,2,caption) u = c(5,10,15,20,30,40,60,80,100) lota = c(118,58,42,35,27,25,21,19,18) clotting <- data.frame(u = u, lota = lota) a <- glm(lota ~ log(u), data=clotting, family=Gamma) set.seed(2020) plotmo(a, do.par=FALSE, caption=caption, col.response=4, pt.pch=7, clip=FALSE, nrug=-1, level=.95, smooth.col="indianred") termplot(a, se=2) par(org.par) if(length(grep("package:gam", search()))) detach("package:gam") library(mgcv) set.seed(1) caption <- "test level=.95, plot.gam, with mgcv::gam(y ~ s(x) + s(x,z1)) with response and func (and extra image plot)" dopar(3,2,caption) par(mar = c(3, 5, 1.7, 0.5)) # more space for left and bottom axis test1 <- function(x,sx=0.3,sz=0.4) (pi**sx*sz)*(1.2*exp(-(x[,1]-0.2)^2/sx^2-(x[,2]-0.3)^2/sz^2)+ 0.8*exp(-(x[,1]-0.7)^2/sx^2-(x[,2]-0.8)^2/sz^2)) n <- 100 set.seed(1) x <- runif(n); z1 <- runif(n); y <- test1(cbind(x,z1)) + rnorm(n) * 0.1 a <- gam(y ~ s(x) + s(x,z1)) set.seed(2020) plotmo(a, do.par=FALSE, type2="contour", caption=caption, col.response=3, func=test1, func.col="magenta", level=.95) plotmo(a, do.par=FALSE, degree1=F, degree2=1, type2="image", image.col=topo.colors(10), ylim=NA, level=.95, main="topo.colors") plot(a, select=1) plot(a, select=2) plot(a, select=3) par(org.par) # TODO Following commented out because it causes: # Error: gam objects in the "gam" package do not support confidence intervals on new data # detach("package:mgcv") # library(gam) # set.seed(1) # caption <- "test level=.95, gam:gam(Ozone^(1/3)~lo(Solar.R)+lo(Wind, Temp),data=airquality)" # dopar(3,2,caption) # data(airquality) # airquality <- na.omit(airquality) # plotmo doesn't know how to deal with NAs yet # a <- gam(Ozone^(1/3) ~ lo(Solar.R) + lo(Wind, Temp), data = airquality) # set.seed(2020) # plotmo(a, do.par=FALSE, caption=caption, ylim=NA, col.response=3, level=.95) # # termplot(a) #TODO this fails with R2.5: dim(data) <- dim: attempt to set an attribute on NULL # detach("package:gam") # par(org.par) # test factors by changing wind to a factor ozone2 <- ozone1 ozone2[,"wind"] <- factor(ozone2[,"wind"], labels=c( "wind0", "wind2", "wind3", "wind4", "wind5", "wind6", "wind7", "wind8", "wind9", "wind10", "wind11")) # commented out because factors are not yet supported by plotmo.earth # caption <- "test wind=factor, earth(O3 ~ ., data=ozone2)" # a <- earth(doy ~ ., data=ozone2) # set.seed(1) # dopar(4,3,caption) # set.seed(2020) # plotmo(a, col.response="gray", level=.95, nrug=-1, do.par=FALSE, caption=caption) # termplot(a) # par(org.par) caption <- "test wind=factor, lm(doy ~ vh + wind + I(humidity*temp) + log(ibh), data=ozone2)" a <- lm(doy ~ vh + wind + I(humidity*temp) + log(ibh), data=ozone2) set.seed(1) dopar(4,3,caption) plotmo(a, col.response="gray", level=.95, nrug=-1, do.par=FALSE, caption=caption, smooth.col="indianred") termplot(a, se=2) par(org.par) caption <- "test level options" dopar(2,2,caption) plotmo(a, do.par=FALSE, degree1=2, degree2=FALSE, level=.95, level.shade=0, caption=caption) plotmo(a, do.par=FALSE, degree1=2, degree2=FALSE, level=.95, level.shade="orange") plotmo(a, do.par=FALSE, degree1=2, degree2=FALSE, level=.95, level.shade2=0) par(org.par) caption <- "test wind=factor, glm(y ~ i + j, family=poisson())" y <- c(18,17,15,20,10,20,25,13,12) i <- gl(3,1,9) j <- gl(3,3) a <- glm(y ~ i + j, family=poisson()) set.seed(1) dopar(2,2,caption) plotmo(a, do.par=F, level=.95, nrug=1, caption=caption) termplot(a, se=1, rug=T) par(org.par) if(length(grep("package:gam", search()))) detach("package:gam") caption <- "test wind=factor, gam(doy ~ vh + wind + s(humidity) + s(vh) + temp, data=ozone2)" library(mgcv) a <- gam(doy ~ vh + wind + s(humidity) + s(vh) + temp, data=ozone2) plotmo(a, level=.95, caption=caption) caption <- "test wind=factor, clip=TRUE, gam(doy ~ vh + wind + s(humidity) + s(vh) + temp, data=ozone2)" plotmo(a, level=.95, caption=caption, clip=FALSE) # termplot doesn't work here so code commented out # dopar(3,3,caption) # plotmo(a, do.par=FALSE) # termplot(a) par(org.par) # test lda and qda, and also col.response, pt.pch, and jitter library(MASS) etitanic2 <- etitanic etitanic2$pclass <- as.numeric(etitanic$pclass) etitanic2$sex <- as.numeric(etitanic$sex) etitanic2$sibsp <- NULL etitanic2$parch <- NULL lda.model <- lda(survived ~ ., data=etitanic2) set.seed(7) plotmo(lda.model, caption="lda", clip=F, col.response=as.numeric(etitanic2$survived)+2, type="posterior", nresponse=1, smooth.col="indianred", all2=TRUE, type2="image") set.seed(8) plotmo(lda.model, caption="lda with no jitter", clip=F, col.response=as.numeric(etitanic2$survived)+2, type="posterior", nresponse=1, all2=TRUE, type2="image", jitter=0) qda.model <- qda(survived ~ ., data=etitanic2) set.seed(9) plotmo(qda.model, caption="qda", clip=F, col.response=as.numeric(etitanic2$survived)+2, type="post", nresponse=2, smooth.col="indianred", all2=TRUE, type2="image", jitter.resp=.6, pch.resp=20) # test plotmo.y from the 2nd argument of the model function (non-formula interface) lcush <- data.frame(Type=as.numeric(Cushings$Type), log(Cushings[,1:2]))[1:21,] a <- qda(lcush[,2:3], lcush[,1]) set.seed(2020) plotmo(a, type="class", all2=TRUE, caption= "plotmo.y from 2nd argument of call (qda)", type2="contour", ngrid2=100, contour.nlevels=2, contour.drawlabels=FALSE, col.response=as.numeric(lcush$Type)+1, pt.pch=as.character(lcush$Type)) par(org.par) # # example from MASS (works, but removed because unnecessary test) # predplot <- function(object, main="", len = 100, ...) # { # plot(Cushings[,1], Cushings[,2], log="xy", type="n", # xlab = "Tetrahydrocortisone", ylab = "Pregnanetriol", main = main) # for(il in 1:4) { # set <- Cushings$Type==levels(Cushings$Type)[il] # text(Cushings[set, 1], Cushings[set, 2], # labels=as.character(Cushings$Type[set]), col = 2 + il) } # xp <- seq(0.6, 4.0, length=len) # yp <- seq(-3.25, 2.45, length=len) # cushT <- expand.grid(Tetrahydrocortisone = xp, # Pregnanetriol = yp) # Z <- predict(object, cushT, ...); zp <- as.numeric(Z$class) # zp <- Z$post[,3] - pmax(Z$post[,2], Z$post[,1]) # contour(exp(xp), exp(yp), matrix(zp, len), # add = TRUE, levels = 0, labex = 0) # zp <- Z$post[,1] - pmax(Z$post[,2], Z$post[,3]) # contour(exp(xp), exp(yp), matrix(zp, len), # add = TRUE, levels = 0, labex = 0) # invisible() # } # par(mfrow=c(2,2)) # cush <- log(as.matrix(Cushings[, -3])) # tp <- Cushings$Type[1:21, drop = TRUE] # set.seed(203) # cush.data <- data.frame(tp, cush[1:21,]) # a <- qda(tp~., data=cush.data) # predplot(a, "QDA example from MASS") # set.seed(2020) # plotmo(a, type="class", all2=TRUE, type2="contour", degree1=NA, do.par=FALSE, # col.response=as.numeric(cush.data$tp)+1) # set.seed(2020) # plotmo(a, type="class", all2=TRUE, type2="contour", degree1=NA, do.par=FALSE, # col.response=as.numeric(cush.data$tp)+1, drawlabels=F, nlevels=2) # set.seed(2020) # plotmo(a, type="class", all2=TRUE, type2="contour", degree1=NA, do.par=FALSE, # col.response=as.numeric(cush.data$tp)+1, drawlabels=F, nlevels=2, ngrid2=100) # par(org.par) library(rpart) data(kyphosis) # kyphosis data, earth model a <- earth(Kyphosis ~ ., data=kyphosis, degree=2, glm=list(family=binomial)) cat("summary(a): (Kyphosis)\n") print(summary(a)) par(mfrow=c(3, 3)) par(mar=c(3, 3, 2, .5)) # small margins to pack figs in set.seed(9) # for jitter set.seed(2020) plotmo(a, do.par=F, type2="image", col.response=ifelse(kyphosis$Kyphosis=="present", "red", "lightblue"), clip=F) plotmo(a, do.par=F, clip=F, degree1=0) par(org.par) # kyphosis data, rpart models (also test ngrid2) fit1 <- rpart(Kyphosis ~ ., data=kyphosis) plotres(fit1, SHOWCALL=TRUE) par(mfrow=c(3, 3)) par(mar=c(.5, 0.5, 2, .5), mgp = c(1.6, 0.6, 0)) # b l t r small margins to pack figs in library(rpart.plot) prp(fit1, main="rpart kyphosis\nno prior") plotmo(fit1, degree1=NA, do.par=F, main="", persp.theta=220, nresponse=2) par(mar=c(4, 4, 2, .5)) set.seed(2020) plotmo(fit1, nresp=2, degree1=FALSE, do.par=F, main="", type2="image", # test default type="prob" col.response=ifelse(kyphosis$Kyphosis=="present", "red", "lightblue"), pt.pch=ifelse(kyphosis$Kyphosis=="present", "p", "a"), image.col=gray(10:4/10), ngrid2=30) par(mar=c(.5, 0.5, 2, .5)) # b l t r small margins to pack figs in plotmo(fit1, type="class", degree1=NA, do.par=F, main="type=\"class\"") # with type="prob" and response has two columns, # nresponse should automatically default to column 2 plotmo(fit1, type="prob", degree1=0, do.par=F, main="type=\"prob\"", clip=F, ngrid2=50, persp.border=NA, trace=1) set.seed(2020) plotmo(fit1, type="prob", nresp=2, degree1=NA, do.par=F, main="", type2="image", col.response=ifelse(kyphosis$Kyphosis=="present", "red", "lightblue"), pt.pch=20, image.col=gray(10:4/10), ngrid2=5) # better rpart model with prior fit2 <- rpart(Kyphosis ~ ., data=kyphosis, parms=list(prior=c(.65,.35))) prp(fit2, main="rpart kyphosis\nwith prior, better model") plotmo(fit2, type="v", degree1=NA, do.par=F, main="", persp.theta=220, ngrid2=10) par(mar=c(4, 4, 2, .5)) set.seed(2020) plotmo(fit2, type="v", degree1=NA, do.par=F, main="", type2="image", col.response=ifelse(kyphosis$Kyphosis=="present", "red", "lightblue"), pt.pch=20, image.col=gray(10:4/10), ngrid2=100) par(org.par) plotmo(fit1, type="prob", nresponse=1, persp.border=NA, persp.col="pink", all1=TRUE, all2=TRUE, caption="plotmo rpart fit1, all1=TRUE, all2=TRUE") expect.err(try(plotmo(fit1, type="none.such1"))) # rpart model with ozone data data(ozone1) par(mfrow=c(4,4)) par(mar=c(.5, 0.5, 2, .5), cex=.6, mgp = c(1.6, 0.6, 0)) # b l t r small margins to pack figs in a1 <- rpart(O3~temp+humidity, data=ozone1) prp(a1, main="rpart model with ozone data\n(temp and humidity only)\n") plotmo(a1, do.par=F, degree1=0, main="rpart", persp.ticktype="detail", persp.nticks=2) expect.err(try(plotmo(a1, type="class"))) # compare to a linear and earth model a3 <- lm(O3~temp+humidity, data=ozone1) plotmo(a3, do.par=F, clip=F, main="lm", degree1=0, all2=TRUE, persp.ticktype="detail", persp.nticks=2) expect.err(try(plotmo(a3, type="none.such2"))) a <- earth(O3~temp+humidity, data=ozone1, degree=2) plotmo(a, do.par=F, clip=F, main="earth", degree1=NA, persp.ticktype="detail", persp.nticks=2) expect.err(try(plotmo(a, type="none.such3"))) expect.err(try(plotmo(a, type=c("abc", "def")))) par(org.par) # detailed rpart model par(mfrow=c(3,3)) a1 <- rpart(O3~., data=ozone1) prp(a1, cex=.9, main="rpart model with full ozone data") plotmo(a1, type="vector", do.par=F, degree1=NA, persp.ticktype="detail", persp.nticks=3, degree2=2:3) par(org.par) plotmo(a1, persp.border=NA, all1=TRUE, all2=TRUE, caption="plotmo rpart a1, all1=TRUE, all2=TRUE") library(tree) tree1 <- tree(O3~., data=ozone1) plotmo(tree1) plotres(tree1) # rpart data with NAs rpart.airquality <- rpart(Ozone~., data=airquality) # airquality has NAs in response and variables plotmo <- plotmo(rpart.airquality, trace=0, SHOWCALL=TRUE) print(rpart.rules(rpart.airquality)) airquality.nonaOzone <- subset(airquality, !is.na(Ozone)) # no NAs in response but NAs in variables rpart.nonaOzone <- rpart(Ozone~., data=airquality.nonaOzone) print(rpart.rules(rpart.nonaOzone)) plotmo.nonaOzone <- plotmo(rpart.nonaOzone, trace=0, SHOWCALL=TRUE) airquality.nonaOzone$Ozone <- NULL stopifnot(identical(plotmo.nonaOzone, airquality.nonaOzone)) # test xflip and yflip par(mfrow=c(4, 4)) par(mgp = c(1.6, 0.6, 0)) par(mar=c(4, 4, 2, .5)) flip.test1 <- rpart(Kyphosis ~ ., data=kyphosis) set.seed(2020) plotmo(flip.test1, type="prob", nresp=2, degree1=NA, do.par=F, main="", type2="image", col.response=ifelse(kyphosis$Kyphosis=="present", "red", "lightblue"), pt.pch=20, image.col=gray(10:4/10)) set.seed(2020) plotmo(flip.test1, type="prob", nresp=2, degree1=NA, do.par=F, main="xflip", type2="image", col.response=ifelse(kyphosis$Kyphosis=="present", "red", "lightblue"), pt.pch=20, image.col=gray(10:4/10), xflip=T) set.seed(2020) plotmo(flip.test1, type="prob", nresp=2, degree1=NA, do.par=F, main="yflip", type2="image", col.response=ifelse(kyphosis$Kyphosis=="present", "red", "lightblue"), pt.pch=20, image.col=gray(10:4/10), yflip=T) set.seed(2020) plotmo(flip.test1, type="prob", nresp=2, degree1=NA, do.par=F, main="xflip and yflip", type2="image", col.response=ifelse(kyphosis$Kyphosis=="present", "red", "lightblue"), pt.pch=20, image.col=gray(10:4/10), xflip=T, yflip=T) flip.test2 <- earth(O3~., data=ozone1, degree=2) plotmo(flip.test2, degree1=NA, degree2=2, do.par=F, main="", type2="cont") plotmo(flip.test2, degree1=NA, degree2=2, do.par=F, main="xflip", type2="cont", xflip=T) plotmo(flip.test2, degree1=NA, degree2=2, do.par=F, main="yflip", type2="cont", yflip=T) plotmo(flip.test2, degree1=NA, degree2=2, do.par=F, main="xflip and yflip", type2="cont", xflip=T, yflip=T) cat("Expect warnings: ignoring xflip=TRUE for persp plot\n") plotmo(flip.test2, degree1=NA, degree2=2, do.par=F, main="xflip and yflip", type2="persp", xflip=T, yflip=T) library(randomForest) data(etitanic) etit <- etitanic[1:300,] cat("=== rf.regression ===\n") set.seed(2016) # Expect Warning: The response has five or fewer unique values. Are you sure you want to do regression? rf.regression <- randomForest(survived~., data=etit, ntree=100, importance = FALSE) plotmo(rf.regression, trace=1) cat("=== rf.regression.importance ===\n") set.seed(2016) # Expect Warning: The response has five or fewer unique values. Are you sure you want to do regression? rf.regression.importance <- randomForest(survived~., data=etit, ntree=100, importance = TRUE) plotmo(rf.regression.importance, trace=1) etit <- etitanic[1:300,] etit$survived <- factor(ifelse(etit$survived == 1, "survived", "died"), levels = c("survived", "died")) cat("=== rf.classification ===\n") set.seed(2016) rf.classification <- randomForest(survived~., data=etit, ntree=100, importance = FALSE) plotmo(rf.classification, trace=1, type="prob", nresponse="surv", SHOWCALL=TRUE) plotmo(rf.classification, trace=1, type="prob", nresponse="died", degree2=0, SHOWCALL=TRUE) cat("=== rf.classification.importance ===\n") set.seed(2016) rf.classification.importance <- randomForest(survived~., data=etit, ntree=100, importance = TRUE) plotmo(rf.classification.importance, trace=1, type="prob", nresponse="surv", SHOWCALL=TRUE) cat("=== plotres randomForest ===\n") plotres(rf.regression) plotres(rf.regression.importance) # TODO residuals are in range 0 to 1 plotres(rf.classification, type="prob", nresponse="surv") plotres(rf.classification.importance, type="prob", nresponse="surv") #--- fda ------------------------------------------------------------------------------ par(org.par) par(mfrow=c(4,5)) par(mar = c(3, 2, 3, .1)) # b, l, t, r par(mgp = c(1.5, .5, 0)) fda.earth <- fda(Species~., data=iris, keep.fitted=TRUE, method=earth, keepxy=TRUE) fda.polyreg <- fda(Species~., data=iris, keep.fitted=TRUE, keepxy=TRUE) fda.bruto <- fda(Species~., data=iris, keep.fitted=TRUE, method=bruto) # 'fda.polyreg$fit' does not have a 'call' field or 'x' and 'y' fields expect.err(try(plotmo(fda.polyreg$fit, type="variates", nresponse=1, clip=F, do.par=F))) plot(1, main="plotmo with fda", xaxt="n", yaxt="n", xlab="", ylab="", type="n", bty="n", cex.main=1.2, xpd=NA) plotmo(fda.earth, type="variates", nresponse=1, clip=F, do.par=F) plot(1, main="plotmo with fda.earth$fit", xaxt="n", yaxt="n", xlab="", ylab="", type="n", bty="n", cex.main=1.2, xpd=NA) plotmo(fda.earth$fit, nresponse=1, clip=F, do.par=F) plot(1, main="", xaxt="n", yaxt="n", xlab="", ylab="", type="n", bty="n", cex.main=1.5, xpd=NA) plot(fda.earth) plotmo(fda.earth, clip=F, do.par=F) # default type is class plot(fda.polyreg) plotmo(fda.polyreg, type="variates", nresponse=1, clip=F, do.par=F, degree1=c(1,3,4)) plot(1, main="", xaxt="n", yaxt="n", xlab="", ylab="", type="n", bty="n", cex.main=1.5, xpd=NA) par(mfrow=c(3,3)) par(mar = c(3, 2, 3, .1)) # b, l, t, r par(mgp = c(1.5, .5, 0)) plot(fda.bruto) plotmo(fda.bruto, type="variates", nresponse=1, do.par=F) par(org.par) # neural net package # for speed we use artificial data because neuralnet is very slow on say trees library(neuralnet) n <- 20 set.seed(3) x1 <- runif(n, min=-1, max=1) x2 <- runif(n, min=-1, max=1) # x2 is noise y <- x1^2 data <- data.frame(y=y, x1=x1, x2=x2) colnames(data) <- c("y","x1", "x2") set.seed(3) nn <- neuralnet(y~x1+x2, data=data, hidden=3, rep=3) print(head(plotmo:::predict.nn(nn, rep="best", trace=TRUE))) set.seed(2020) plotmo(nn, trace=1, col.response=2, all2=TRUE, SHOWCALL=TRUE) # trace=0 below to test hushing of message "assuming "y" in the model.frame is the response, because object$terms is NULL" set.seed(2020) plotmo(nn, trace=0, col.response=2, predict.rep="best", SHOWCALL=TRUE) plotres(nn, trace=0, info=TRUE, SHOWCALL=TRUE) plotres(nn, trace=1, info=TRUE, predict.rep="best", SHOWCALL=TRUE) library(nnet) data(iris3) set.seed(301) samp <- c(sample(1:50,25), sample(51:100,25), sample(101:150,25)) ird <- data.frame(rbind(iris3[,,1], iris3[,,2], iris3[,,3]), species=factor(c(rep("seto",50), rep("vers", 50), rep("virg", 50)))) ir.nn2 <- nnet(species ~ ., data = ird, subset = samp, size = 2, rang = 0.1, decay = 5e-4, maxit = 20) plotmo(ir.nn2, nresponse=1, type="class", all2=T, degree2=2:6) plotmo(ir.nn2, nresponse=2, clip=F, all2=T, degree2=1:5) plotres(ir.nn2, nresponse=2) library(biglm) data(trees) ff <- log(Volume)~log(Girth)+log(Height) chunk1 <- trees[1:20,] chunk2 <- trees[20:31,] biglm <- biglm(ff,chunk1) biglm <- update(biglm, chunk2) plotmo(biglm, pt.col=2, SHOWCALL=TRUE) plotres(biglm, SHOWCALL=TRUE) library(adabag) data(iris) set.seed(2015) # mfinal=3 for speed during testing mod.boosting <- boosting(Species~., data=iris, mfinal=3) mod.bagging <- bagging(Species~., data=iris, mfinal=3) dopar(4, 4, caption="adabag package") plotmo(mod.boosting, nresponse=1, ylim=c(0,1), do.par=FALSE) # default type="prob" plotmo(mod.boosting, type="class", do.par=FALSE) plotmo(mod.bagging, nresponse=1, ylim=c(0,1), do.par=FALSE) plotmo(mod.bagging, nresponse=1, type="votes", do.par=FALSE) par(org.par) library(e1071) data(iris) x.iris <- subset(iris, select=-Species) y.iris <- iris$Species set.seed(2016) svm.xy <- svm(x.iris, y.iris, probability=FALSE) par(mfrow = c(3, 3), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) expect.err(try(plotmo(svm.xy, prob=TRUE, nresponse="vers", do.par=TRUE, all2=TRUE))) # probability=FALSE in call to svm plotmo(svm.xy, decision=TRUE, nresponse="vers", do.par=FALSE, all2=TRUE, degree1=2:3, degree2=6) svm.xy <- svm(x.iris, y.iris, probability=TRUE) plotmo(svm.xy, prob=TRUE, nresponse="vers", do.par=FALSE, all2=TRUE, degree1=2:3, degree2=6) set.seed(2016) svm.form <- svm(Species ~ ., data=iris, probability=T) plotmo(svm.form, predict.p=TRUE, nresponse="vers", do.par=FALSE, all2=TRUE, degree1=2:3, degree2=6) expect.err(try(plotmo(svm.form, decision.values=TRUE, probab=TRUE))) # not both plotres(svm.form, predict.prob=TRUE, nresponse="vers", info=TRUE) plotres(svm.form, jitter=5, info=TRUE) par(org.par) source("test.epilog.R") plotmo/inst/slowtests/test.printcall.Rout.save0000644000176200001440000002372714563614021021403 0ustar liggesusers> # test.printcall.R > # > # TODO we don't test use of printcall in a namespace > > source("test.prolog.R") > options(warnPartialMatchArgs=FALSE) > library(plotmo) Loading required package: Formula Loading required package: plotrix > for(all in c(FALSE, TRUE)) { + for(EVAL in c(FALSE, TRUE)) { + printf("=== Test printcall with all=%s EVAL=%s ===\n", all, EVAL) + + foo30 <- function() { plotmo:::printcall(all=all) } + foo30() + + foo32 <- function(...) { plotmo:::printcall(all=all); plotmo:::printdots(..., EVAL=EVAL) } + foo32() + foo32(a=31) + + + foo34 <- function(aa=1, ...) { plotmo:::printcall(all=all); plotmo:::printdots(..., EVAL=EVAL) } + foo34() + foo34(a=31) # argname a will be expanded to aa + foo34(a=31, x=1:10, y=NULL) + foo34(a=31, y=NULL) + foo34(x=stopifnot(TRUE), y=NULL) + + foo36 <- function(aa=NULL, ...) { plotmo:::printcall(all=all); plotmo:::printdots(..., EVAL=EVAL) } + foo36() + foo36(a=NULL) + foo36(a=1) + foo36(a=1:3) + foo36(a=1:3, x=NULL) + + # check formatting of various argument types + # note that we correctly don't call stopifnot(FALSE) (which would call stop) + + foo38 <- function(aa=1:3, bb=4:6, cc=print.default, + dd=stopifnot(FALSE), + ee=function(m=1) cat(m), ff=7, ...) + { plotmo:::printcall(all=all); plotmo:::printdots(..., EVAL=EVAL) } + foo38(x=matrix(ncol=1, nrow=3)) + + list1 <- list(aa=1:3, bb=4:6, cc=print.default, + dd=stopifnot(TRUE), + ee=function(m=1) cat(m), ff=7) + + cat("list1 ", plotmo:::list.as.char(list1), "\n", sep="") + + list2 <- list(lmmod=lm(Volume~Girth, data=trees), + boolean=c(TRUE, FALSE, TRUE, TRUE, FALSE, TRUE), env=parent.frame(), + chars=c("a", "b", "c", "a", "b", "c"), + trees=trees, l=list(x=1, y="2", z=foo38)) + + cat("list2 ", plotmo:::list.as.char(list2), "\n", sep="") + + # test unnamed arguments + + foo40 <- function(aa, ...) { plotmo:::printcall(all=all); plotmo:::printdots(..., EVAL=EVAL) } + foo40() + foo40(aa=b, c) + foo40(b, c) + + # test printcall when called in an S3 method + + foo.s3 <- function(a=NULL, ...) { UseMethod("foo.s3") } + foo.s3.list <- function(a=NULL, ...) { + cat("in foo.s3.list: "); plotmo:::printcall(all=all) + plotmo:::printdots(..., EVAL=EVAL) + } + foo.s3.default <- function(a=NULL, ...) { + cat("in foo.s3.default: "); plotmo:::printcall(all=all) + plotmo:::printdots(..., EVAL=EVAL) + } + foo.s3(a=list(m=1, n=2)) + foo.s3(a=NULL) + foo.s3(a=list(m=1, n=2, o=3, p=4, q=5, r=6, s=7, t=8, u=9), b=30) + + # test formatting with long argument list + + foo46 <- function(mmmmmmmmmmm=1000, nnnnnnnnnnn=2000, ooooooooooo=3000, ppppppppppp=4000, + qqqqqqqqqqq=5000, rrrrrrrrrrr=6000, sssssssssss=7000, ttttttttttt=8000, + uuuuuuuuuuu=9000, vvvvvvvvvvv=1000, wwwwwwwwwww=2000, xxxxxxxxxxx=3000, + ...) { plotmo:::printcall(all=all); plotmo:::printdots(..., EVAL=EVAL) } + foo46(a=30) + + # test call.as.char + + foo47 <- function(aa=1, ...) { s <- plotmo:::call.as.char(all=all); cat(s, "\n", sep="") } + foo47(b=30) + + # create a variable named foo48 in foo48 + foo48 <- function(aa=1, ...) { foo48 <- 99; s <- plotmo:::call.as.char(all=all); cat(s, "\n", sep="") } + foo48(b=30) + + # Note that the following doesn't do what you might expect. + # The calling function is print(), not foo50() as you may expecty. + + foo50 <- function(...) { print(plotmo:::call.as.char(all=all)) } + foo50(a=1) + } + } === Test printcall with all=FALSE EVAL=FALSE === foo30() foo32() foo32 dots: no dots foo32(a=31) foo32 dots: a=31 foo34() foo34 dots: no dots foo34(aa=31) foo34 dots: no dots foo34(aa=31, x=1:10, y=NULL) foo34 dots: x=..1, y=..2 foo34(aa=31, y=NULL) foo34 dots: y=..1 foo34(x=stopifnot(TRUE), y=NULL) foo34 dots: x=..1, y=..2 foo36() foo36 dots: no dots foo36(aa=NULL) foo36 dots: no dots foo36(aa=1) foo36 dots: no dots foo36(aa=1:3) foo36 dots: no dots foo36(aa=1:3, x=NULL) foo36 dots: x=..1 foo38(x=matrix(ncol=1,nrow=3)) foo38 dots: x=..1 list1 aa=c(1,2,3), bb=c(4,5,6), cc=function.object, dd=NULL, ee=function.object, ff=7 list2 lmmod=lm.object, boolean=c(TRUE,FALSE,TR...), env=R_GlobalEnv, chars=c("a","b","c","...), trees=data.frame[31,3], l=list(x=1, y="2", z=function.object) foo40() foo40 dots: no dots foo40(aa=b, c) foo40 dots: ..1 foo40(aa=b, c) foo40 dots: ..1 in foo.s3.list: foo.s3.list(a=list(m=1,n=2)) foo.s3.list dots: no dots in foo.s3.default: foo.s3.default(a=NULL) foo.s3.default dots: no dots in foo.s3.list: foo.s3.list(a=list(m=1,n=2,o=3,p=4,q=5,r=6,s=7,t=8,u=9), b=30) foo.s3.list dots: b=30 foo46(a=30) foo46 dots: a=30 foo47(b=30) foo48(b=30) [1] "print(x=plotmo:::call.as.char(all=all))" attr(,"fname") [1] "print" === Test printcall with all=FALSE EVAL=TRUE === foo30() foo32() foo32 dots: no dots foo32(a=31) foo32 dots: a=31 foo34() foo34 dots: no dots foo34(aa=31) foo34 dots: no dots foo34(aa=31, x=1:10, y=NULL) foo34 dots: x=c(1,2,3,4,5,6,7...), y=NULL foo34(aa=31, y=NULL) foo34 dots: y=NULL foo34(x=stopifnot(TRUE), y=NULL) foo34 dots: x=NULL, y=NULL foo36() foo36 dots: no dots foo36(aa=NULL) foo36 dots: no dots foo36(aa=1) foo36 dots: no dots foo36(aa=1:3) foo36 dots: no dots foo36(aa=1:3, x=NULL) foo36 dots: x=NULL foo38(x=matrix(ncol=1,nrow=3)) foo38 dots: x=c(NA,NA,NA) list1 aa=c(1,2,3), bb=c(4,5,6), cc=function.object, dd=NULL, ee=function.object, ff=7 list2 lmmod=lm.object, boolean=c(TRUE,FALSE,TR...), env=R_GlobalEnv, chars=c("a","b","c","...), trees=data.frame[31,3], l=list(x=1, y="2", z=function.object) foo40() foo40 dots: no dots foo40(aa=b, c) foo40 dots: function.object foo40(aa=b, c) foo40 dots: function.object in foo.s3.list: foo.s3.list(a=list(m=1,n=2)) foo.s3.list dots: no dots in foo.s3.default: foo.s3.default(a=NULL) foo.s3.default dots: no dots in foo.s3.list: foo.s3.list(a=list(m=1,n=2,o=3,p=4,q=5,r=6,s=7,t=8,u=9), b=30) foo.s3.list dots: b=30 foo46(a=30) foo46 dots: a=30 foo47(b=30) foo48(b=30) [1] "print(x=plotmo:::call.as.char(all=all))" attr(,"fname") [1] "print" === Test printcall with all=TRUE EVAL=FALSE === foo30() foo32() foo32 dots: no dots foo32(a=31) foo32 dots: a=31 foo34(aa=1) foo34 dots: no dots foo34(aa=31) foo34 dots: no dots foo34(aa=31, x=1:10, y=NULL) foo34 dots: x=..1, y=..2 foo34(aa=31, y=NULL) foo34 dots: y=..1 foo34(aa=1, x=stopifnot(TRUE), y=NULL) foo34 dots: x=..1, y=..2 foo36(aa=NULL) foo36 dots: no dots foo36(aa=NULL) foo36 dots: no dots foo36(aa=1) foo36 dots: no dots foo36(aa=1:3) foo36 dots: no dots foo36(aa=1:3, x=NULL) foo36 dots: x=..1 foo38(aa=1:3, bb=4:6, cc=print.default, dd=stopifnot(FALSE), ee=function(m=1)cat(m), ff=7, x=matrix(ncol=1,nrow=3)) foo38 dots: x=..1 list1 aa=c(1,2,3), bb=c(4,5,6), cc=function.object, dd=NULL, ee=function.object, ff=7 list2 lmmod=lm.object, boolean=c(TRUE,FALSE,TR...), env=R_GlobalEnv, chars=c("a","b","c","...), trees=data.frame[31,3], l=list(x=1, y="2", z=function.object) foo40(aa=) foo40 dots: no dots foo40(aa=b, c) foo40 dots: ..1 foo40(aa=b, c) foo40 dots: ..1 in foo.s3.list: foo.s3.list(a=list(m=1,n=2)) foo.s3.list dots: no dots in foo.s3.default: foo.s3.default(a=NULL) foo.s3.default dots: no dots in foo.s3.list: foo.s3.list(a=list(m=1,n=2,o=3,p=4,q=5,r=6,s=7,t=8,u=9), b=30) foo.s3.list dots: b=30 foo46(mmmmmmmmmmm=1000, nnnnnnnnnnn=2000, ooooooooooo=3000, ppppppppppp=4000, qqqqqqqqqqq=5000, rrrrrrrrrrr=6000, sssssssssss=7000, ttttttttttt=8000, uuuuuuuuuuu=9000, vvvvvvvvvvv=1000, wwwwwwwwwww=2000, xxxxxxxxxxx=3000, a=30) foo46 dots: a=30 foo47(aa=1, b=30) foo48(aa=1, b=30) [1] "print(x=plotmo:::call.as.char(all=all))" attr(,"fname") [1] "print" === Test printcall with all=TRUE EVAL=TRUE === foo30() foo32() foo32 dots: no dots foo32(a=31) foo32 dots: a=31 foo34(aa=1) foo34 dots: no dots foo34(aa=31) foo34 dots: no dots foo34(aa=31, x=1:10, y=NULL) foo34 dots: x=c(1,2,3,4,5,6,7...), y=NULL foo34(aa=31, y=NULL) foo34 dots: y=NULL foo34(aa=1, x=stopifnot(TRUE), y=NULL) foo34 dots: x=NULL, y=NULL foo36(aa=NULL) foo36 dots: no dots foo36(aa=NULL) foo36 dots: no dots foo36(aa=1) foo36 dots: no dots foo36(aa=1:3) foo36 dots: no dots foo36(aa=1:3, x=NULL) foo36 dots: x=NULL foo38(aa=1:3, bb=4:6, cc=print.default, dd=stopifnot(FALSE), ee=function(m=1)cat(m), ff=7, x=matrix(ncol=1,nrow=3)) foo38 dots: x=c(NA,NA,NA) list1 aa=c(1,2,3), bb=c(4,5,6), cc=function.object, dd=NULL, ee=function.object, ff=7 list2 lmmod=lm.object, boolean=c(TRUE,FALSE,TR...), env=R_GlobalEnv, chars=c("a","b","c","...), trees=data.frame[31,3], l=list(x=1, y="2", z=function.object) foo40(aa=) foo40 dots: no dots foo40(aa=b, c) foo40 dots: function.object foo40(aa=b, c) foo40 dots: function.object in foo.s3.list: foo.s3.list(a=list(m=1,n=2)) foo.s3.list dots: no dots in foo.s3.default: foo.s3.default(a=NULL) foo.s3.default dots: no dots in foo.s3.list: foo.s3.list(a=list(m=1,n=2,o=3,p=4,q=5,r=6,s=7,t=8,u=9), b=30) foo.s3.list dots: b=30 foo46(mmmmmmmmmmm=1000, nnnnnnnnnnn=2000, ooooooooooo=3000, ppppppppppp=4000, qqqqqqqqqqq=5000, rrrrrrrrrrr=6000, sssssssssss=7000, ttttttttttt=8000, uuuuuuuuuuu=9000, vvvvvvvvvvv=1000, wwwwwwwwwww=2000, xxxxxxxxxxx=3000, a=30) foo46 dots: a=30 foo47(aa=1, b=30) foo48(aa=1, b=30) [1] "print(x=plotmo:::call.as.char(all=all))" attr(,"fname") [1] "print" > source("test.epilog.R") plotmo/inst/slowtests/test.plotmo3.R0000644000176200001440000005007413737416454017332 0ustar liggesusers# test.plotmo3.R: extra tests for plotmo version 3 and higher source("test.prolog.R") library(earth) data(ozone1) data(etitanic) options(warn=1) # print warnings as they occur # check check.numeric.scalar xtest <- NA expect.err(try(plotmo:::check.numeric.scalar(xtest)), "'xtest' is NA") xtest <- NULL expect.err(try(plotmo:::check.numeric.scalar(xtest)), "'xtest' is NULL") expect.err(try(plotmo:::check.numeric.scalar(NA)), "argument is NA") expect.err(try(plotmo:::check.numeric.scalar(NULL)), "argument is NULL") expect.err(try(plotmo:::check.numeric.scalar(try)), "'try' must be numeric (whereas its current class is \"function\")") expect.err(try(plotmo:::check.numeric.scalar('try')), "\"try\" must be numeric (whereas its current class is \"character\")") expect.err(try(plotmo:::check.numeric.scalar(NULL)), "argument is NULL") expect.err(try(plotmo:::check.numeric.scalar(1234, min=2, max=3)), "argument=1234 but it should be between 2 and 3") expect.err(try(plotmo:::check.numeric.scalar(0.1234, min=2, max=3)), "argument=0.1234 but it should be between 2 and 3") expect.err(try(plotmo:::check.numeric.scalar(.1234, min=2, max=3)), "argument=0.1234 but it should be between 2 and 3") expect.err(try(plotmo:::check.numeric.scalar(+1234, min=2, max=3)), "argument=1234 but it should be between 2 and 3") expect.err(try(plotmo:::check.numeric.scalar(-1234, min=2, max=3)), "argument=-1234 but it should be between 2 and 3") expect.err(try(plotmo:::check.numeric.scalar(+.1234, min=2, max=3)), "argument=0.1234 but it should be between 2 and 3") expect.err(try(plotmo:::check.numeric.scalar(-.1234, min=2, max=3)), "argument=-0.1234 but it should be between 2 and 3") expect.err(try(plotmo:::check.numeric.scalar("", min=0, max=3)), "\"\" must be numeric (whereas its current class is \"character\"") x.numeric.scalar <- 1234 expect.err(try(plotmo:::check.numeric.scalar(x.numeric.scalar, min=0, max=3)), "x.numeric.scalar=1234 but it should be between 0 and 3") stopifnot(identical(plotmo:::check.numeric.scalar(x.numeric.scalar, min=2, max=1235), 1234)) stopifnot(identical(plotmo:::check.numeric.scalar(1234, min=2, max=1235), 1234)) # check check.integer.scalar xtest <- NA expect.err(try(plotmo:::check.integer.scalar(xtest)), "'xtest' is NA") xtest <- NULL expect.err(try(plotmo:::check.integer.scalar(xtest)), "'xtest' is NULL") expect.err(try(plotmo:::check.integer.scalar(NA)), "argument is NA") expect.err(try(plotmo:::check.integer.scalar(NA, null.ok=TRUE)), "argument is NA") expect.err(try(plotmo:::check.integer.scalar(NULL)), "argument is NULL") expect.err(try(plotmo:::check.integer.scalar(xtest, na.ok=TRUE)), "'xtest' is NULL") expect.err(try(plotmo:::check.integer.scalar("xyz", na.ok=TRUE)), "\"xyz\" is a string but it should be an integer, or NA, or TRUE or FALSE") expect.err(try(plotmo:::check.integer.scalar("TRUE", na.ok=TRUE)), "\"TRUE\" is a string but it should be an integer, or NA, or TRUE or FALSE") stopifnot(identical(plotmo:::check.integer.scalar(TRUE), TRUE)) stopifnot(identical(plotmo:::check.integer.scalar(NA, na.ok=TRUE), NA)) x.integer.scalar <- 1234L expect.err(try(plotmo:::check.integer.scalar(x.integer.scalar, min=0, max=3)), "x.integer.scalar=1234 but it should be between 0 and 3") stopifnot(identical(plotmo:::check.integer.scalar(x.integer.scalar, min=2, max=1235), 1234L)) stopifnot(identical(plotmo:::check.integer.scalar(1234, min=2, max=1235), 1234)) stopifnot(identical(plotmo:::check.integer.scalar(x.integer.scalar, min=2, max=1235), 1234L)) stopifnot(identical(plotmo:::check.integer.scalar(1234, min=2, max=1235), 1234)) xtest <- 1.234 expect.err(try(plotmo:::check.integer.scalar(xtest, min=0, max=3)), "xtest=1.234 but it should be an integer, or TRUE or FALSE") # check check.vec xtest <- "x" expect.err(try(plotmo:::check.vec(xtest, "xtest", na.ok=TRUE)), "'xtest' is not numeric") xtest <- as.double(NA) print(plotmo:::check.vec(xtest, "xtest", na.ok=TRUE)) xtest <- as.double(1:3) print(plotmo:::check.vec(xtest, "xtest", na.ok=TRUE)) xtest <- c(1,2,3,1/0,5,6,7) expect.err(try(plotmo:::check.vec(xtest, "xtest", na.ok=TRUE)), "non-finite value in xtest") xtest <- c(1,2,3,NA,5,6,7) expect.err(try(plotmo:::check.vec(xtest, "xtest")), "NA in xtest") xtest <- c(1,2,3) expect.err(try(plotmo:::check.vec(xtest, "xtest", expected.len=2)), "'xtest' has the wrong length 3, expected 2") print(plotmo:::check.vec(c(TRUE, FALSE), "c(TRUE, FALSE)")) plotmo1 <- function(object, ..., trace=0, SHOWCALL=TRUE, caption=NULL) { if(is.null(caption)) caption <- paste(deparse(substitute(object)), collapse=" ") call <- match.call(expand.dots=TRUE) call <- strip.space(paste(deparse(substitute(call)), collapse=" ")) printf("%s\n", call) plotmo(object, trace=trace, SHOWCALL=SHOWCALL, caption=caption, ...) } plotres1 <- function(object, ..., trace=0, SHOWCALL=TRUE, caption=NULL) { if(is.null(caption)) caption <- paste(deparse(substitute(object)), collapse=" ") call <- match.call(expand.dots=TRUE) call <- strip.space(paste(deparse(substitute(call)), collapse=" ")) printf("%s\n", call) plotres(object, trace=trace, SHOWCALL=SHOWCALL, caption=caption, ...) } # basic tests of plotmo on abbreviated titanic data get.tita <- function() { tita <- etitanic pclass <- as.character(tita$pclass) # change the order of the factors so not alphabetical pclass[pclass == "1st"] <- "first" pclass[pclass == "2nd"] <- "class2" pclass[pclass == "3rd"] <- "classthird" tita$pclass <- factor(pclass, levels=c("class2", "classthird", "first")) # log age is so we have a continuous predictor even when model is age~. set.seed(2015) tita$logage <- log(tita$age) + rnorm(nrow(tita)) tita$parch <- NULL # by=12 gives us a small fast model with an additive and a interaction term tita[seq(1, nrow(etitanic), by=12), ] } tita <- get.tita() mod.lm.age <- lm(age~., data=tita) plotmo1(mod.lm.age) plotmo1(mod.lm.age, level=.95) plotmo1(mod.lm.age, level=.95, col.resp=3) sexn <- as.numeric(tita$sex) mod.lm.sexn <- lm(sexn~.-sex, data=tita) plotmo1(mod.lm.sexn) plotmo1(mod.lm.sexn, level=.95) set.seed(2020) mod.earth.age <- earth(age~., data=tita, degree=2, nfold=3, ncross=3, varmod.method="lm") plotmo1(mod.earth.age) plotmo1(mod.earth.age, level=.9, degree2=0) # tita[,4] is age set.seed(2020) mod.earth.tita.age <- earth(tita[,-4], tita[,4], degree=2, nfold=3, ncross=3, trace=.5, varmod.method="lm") cat("\nsummary(mod.earth.tita.age)\n") print(summary(mod.earth.tita.age)) plotmo1(mod.earth.tita.age) plotmo1(mod.earth.tita.age, level=.9, degree2=0) set.seed(2020) a.earth.sex <- earth(sex~., data=tita, degree=2, nfold=3, ncross=3, varmod.method="lm") plotmo1(a.earth.sex) plotmo1(a.earth.sex, level=.9) plotmo1(a.earth.sex, type="class") expect.err(try(plotmo1(a.earth.sex, level=.9, degree2=0, type="class")), "predicted values are strings") # tita[,3] is sex set.seed(2020) mod.earth.tita <- earth(tita[,-3], tita[,3], degree=2, nfold=3, ncross=3, varmod.method="lm") plotmo1(mod.earth.tita) plotmo1(mod.earth.tita, level=.9, degree2=0) plotmo1(mod.earth.tita, type="class") expect.err(try(plotmo1(mod.earth.tita, level=.9, degree2=0, type="class")), "predicted values are strings") set.seed(2020) mod.earth.sex <- earth(sex~., data=tita, degree=2, nfold=3, ncross=3, varmod.method="earth", glm=list(family=binomial)) plotmo1(mod.earth.sex) plotmo1(mod.earth.sex, type="link") plotmo1(mod.earth.sex, type="class") plotmo1(mod.earth.sex, level=.9, type="earth") # tita[,3] is sex set.seed(2020) mod.earth.tita <- earth(tita[,-3], tita[,3], degree=2, nfold=3, ncross=3, varmod.method="earth", glm=list(family=binomial)) plotmo1(mod.earth.tita) plotmo1(mod.earth.tita, type="link") plotmo1(mod.earth.tita, type="class") plotmo1(mod.earth.tita, level=.9, type="earth") # check factor handling when factors are not ordered alphabetically tita.orgpclass <- etitanic[seq(1, nrow(etitanic), by=12), ] tita <- get.tita() tita$logage <- NULL tita.orgpclass$parch <- NULL stopifnot(names(tita.orgpclass) == names(tita)) a.tita.orgpclass <- earth(pclass~., degree=2, data=tita.orgpclass) a.tita <- earth(pclass~., degree=2, data=tita) options(warn=2) # treat warnings as errors expect.err(try(plotmo(a.tita)), "Defaulting to nresponse=1, see above messages") options(warn=1) # following two graphs should be identical plotmo1(a.tita.orgpclass, nresponse="1st", all1=T, col.resp=3, type2="im") plotmo1(a.tita, nresponse="first", all1=T, col.resp=3, type2="im") # following two graphs should be identical plotmo1(a.tita.orgpclass, nresponse="2nd", all1=T) plotmo1(a.tita, nresponse="class2", all1=T) tita <- get.tita() mod.earth.pclass <- earth(pclass~., data=tita, degree=2) options(warn=2) # treat warnings as errors expect.err(try(plotmo1(mod.earth.pclass)), "Defaulting to nresponse=1, see above messages") options(warn=1) plotmo1(mod.earth.pclass, nresponse="fi") plotmo1(mod.earth.pclass, nresponse="first") plotmo1(mod.earth.pclass, nresponse=3) plotmo1(mod.earth.pclass, type="class") plotmo1(mod.earth.pclass, nresponse=1, type="class", grid.levels=list(sex="fem"), smooth.col="indianred", smooth.lwd=2, pt.col=as.numeric(tita$pclass)+1, pt.pch=1) # tita[,1] is pclass mod.earth.tita <- earth(tita[,-1], tita[,1], degree=2) options(warn=2) # treat warnings as errors expect.err(try(plotmo1(mod.earth.tita)), "Defaulting to nresponse=1, see above messages") options(warn=1) plotmo1(mod.earth.tita, nresponse="first") plotmo1(mod.earth.tita, type="class") mod.earth.pclass2 <- earth(pclass~., data=tita, degree=2, glm=list(family=binomial)) # expect.err(try(plotmo1(mod.earth.pclass2)), "nresponse is not specified") plotmo1(mod.earth.pclass2, nresponse=3) plotmo1(mod.earth.pclass2, type="link", nresponse=3) plotmo1(mod.earth.pclass2, type="class") # tita[,1] is pclass mod.earth.tita <- earth(tita[,-1], tita[,1], degree=2, glm=list(family=binomial)) plotmo1(mod.earth.tita, nresponse=3) plotmo1(mod.earth.tita, type="link", nresponse=3) plotmo1(mod.earth.tita, type="class") # plotmo vignette examples # use a small set of variables for illustration printf("library(earth)\n") library(earth) # for ozone1 data data(ozone1) oz <- ozone1[, c("O3", "humidity", "temp", "ibt")] lm.model.vignette <- lm(O3 ~ humidity + temp*ibt, data=oz) # linear model plotmo1(lm.model.vignette, pt.col="gray", nrug=-1) plotmo1(lm.model.vignette, level=.9) printf("library(mda)\n") library(mda) mars.model.vignette1 <- mars(oz[,-1], oz[,1], degree=2) plotmo1(mars.model.vignette1) plotres1(mars.model.vignette1) mars.model.vignette2 <- mars(oz[,-1,drop=FALSE], oz[,1,drop=FALSE], degree=2) plotmo1(mars.model.vignette2) # TODO causes Error in lm.fit(object$x, y, singular.ok = FALSE) : (list) object cannot be coerced to type 'double' # although still works # the error is mars.to.earth try(hatvalues.lm.fit(lm.fit(object$x, y, singular.ok=FALSE))) plotres1(mars.model.vignette2, trace=1) printf("library(rpart)\n") library(rpart) # rpart rpart.model.vignette <- rpart(O3 ~ ., data=oz) plotmo1(rpart.model.vignette, all2=TRUE) expect.err(try(plotmo1(rpart.model.vignette, level=.9)), "the level argument is not supported for \"rpart\" objects") # commented out because is slow and already tested in test.non.earth.R # printf("library(randomForest)\n") # library(randomForest) # randomForest # rf.model.vignette <- randomForest(O3~., data=oz) # plotmo1(rf.model.vignette) # partialPlot(rf.model.vignette, oz, temp) # compare to partial-dependence plot printf("library(gbm)\n") library(gbm) # gbm set.seed(2016) gbm.model.vignette <- gbm(O3~., data=oz, dist="gaussian", inter=2, n.trees=100) # commented out following because they always take the whole page # plot(gbm.model.vignette, i.var=2) # compare to partial-dependence plots # plot(gbm.model.vignette, i.var=c(2,3)) set.seed(2016) plotmo1(gbm.model.vignette, caption="gbm.model.vignette") # commented out because is slow and already tested elsewhere # printf("library(mgcv)\n") # library(mgcv) # gam # gam.model.vignette <- gam(O3 ~ s(humidity)+s(temp)+s(ibt)+s(temp,ibt), data=oz) # plotmo1(gam.model.vignette, level=.95, all2=TRUE) printf("library(nnet)\n") library(nnet) # nnet set.seed(4) nnet.model.vignette <- nnet(O3~., data=scale(oz), size=2, decay=0.01, trace=FALSE) plotmo1(nnet.model.vignette, type="raw", all2=T) printf("library(MASS)\n") library(MASS) # qda lcush <- data.frame(Type=as.numeric(Cushings$Type),log(Cushings[,1:2])) lcush <- lcush[1:21,] qda.model.vignette <- qda(Type~., data=lcush) plotmo1(qda.model.vignette, type="class", all2=TRUE, type2="contour", ngrid2=100, contour.nlevels=2, contour.drawlabels=FALSE, pt.col=as.numeric(lcush$Type)+1, pt.pch=as.character(lcush$Type)) # miscellaneous other examples tita <- get.tita() mod.glm.sex <- glm(sex~., data=tita, family=binomial) plotmo1(mod.glm.sex, pt.col=as.numeric(tita$pclass)+1) # tita[,4] is age, tita[,1] is pclass printf("library(lars)\n") library(lars) set.seed(2015) xmat <- as.matrix(tita[,c(2,5,6)]) mod.lars.xmat <- lars(xmat, tita[,4]) par(mfrow=c(2,2)) plot(mod.lars.xmat) plotmo1(mod.lars.xmat, nresponse=4, do.par=F) plotres(mod.lars.xmat, trace=0, nresponse=4) if(0) { # TODO fails with R-3.4.2: object '.QP_qpgen2' not found printf("library(cosso)\n") library(cosso) set.seed(2016) cosso <- cosso(xmat,tita[,4],family="Gaussian") # TODO tell maintainer of cosso that you have to do this class(cosso) <- "cosso" set.seed(2016) plotmo1(cosso) set.seed(2016) plotres(cosso) } # examples from James, Witten, et al. ISLR book # I tested all models in their scripts manually. # All worked except for exceptions below. printf("library(pls)\n") library(pls) printf("library(ISLR)\n") library(ISLR) Hitters=na.omit(Hitters) set.seed(1) x <- model.matrix(Salary~.,Hitters)[,-1] y <- Hitters$Salary train=sample(1:nrow(x), nrow(x)/2) pcr.fit1=pcr(Salary~., data=Hitters,subset=train,scale=TRUE, validation="CV") plotmo1(pcr.fit1, nresponse=10) # set.seed(1) # x <- model.matrix(Salary~.,Hitters)[,-1] # y <- Hitters$Salary # train=sample(1:nrow(x), nrow(x)/2) # pcr.fit2=pcr(y~x,scale=TRUE,ncomp=7) # # TODO following gives Error: predictions returned the wrong length (got 263 but expected 50) # plotmo1(pcr.fit2, nresponse=5) library(splines) fit.lm2=lm(wage~bs(age,knots=c(25,40,60)),data=Wage) par(mfrow=c(1,2),mar=c(4.5,4.5,1,1),oma=c(0,0,4,0)) agelims=range(Wage$age) age.grid=seq(from=agelims[1],to=agelims[2]) pred=predict(fit.lm2,newdata=list(age=age.grid),se=T) plot(Wage$age,Wage$wage,col="gray", ylim=c(0,320)) lines(age.grid,pred$fit,lwd=2) lines(age.grid,pred$fit+2*pred$se,lty="dashed") lines(age.grid,pred$fit-2*pred$se,lty="dashed") fit.lm2=lm(wage~bs(age,knots=c(25,40,60)),data=Wage,model=F) # TODO delete plotmo1(fit.lm2, col.resp=2, do.par=F, level=.95, ylim=c(0,320), nrug=TRUE, caption="fit.lm2", ylab="wage") fit.glm2 <- glm(I(wage>250)~poly(age,4),data=Wage,family=binomial) par(mfrow=c(1,2),mar=c(4.5,4.5,1,1),oma=c(0,0,4,0)) agelims=range(Wage$age) age.grid=seq(from=agelims[1],to=agelims[2]) # their plot preds=predict(fit.glm2,newdata=list(age=age.grid),se=T) pfit=exp(preds$fit)/(1+exp(preds$fit)) se.bands.logit = cbind(preds$fit+2*preds$se.fit, preds$fit-2*preds$se.fit) se.bands = exp(se.bands.logit)/(1+exp(se.bands.logit)) preds=predict(fit.glm2,newdata=list(age=age.grid),type="response",se=T) plot(Wage$age,I(Wage$wage>250),xlim=agelims,type="n",ylim=c(0,.2)) points(jitter(Wage$age), I((Wage$wage>250)/5),cex=.5,pch="|",col="darkgrey") lines(age.grid,pfit,lwd=2, col="blue") matlines(age.grid,se.bands,lwd=1,col="blue",lty=3) # plotmo plot, side by side # TODO Warning: the level argument may not be properly supported on glm objects built with weights plotmo1(fit.glm2, level=.95, degree1.col="blue", ylim=c(0,.2), do.par=FALSE, nrug=-1, caption="fit.glm2", ylab="I(wage > 250)") # Test deparsing of the formula in plotmo.pairs.default # TODO Height is included in the plots even though formula says -Height Height2 <- trees$Height^2 a <- lm(Volume~(Girth*Height2)-Height, data=trees, x=TRUE, model=FALSE) plotmo(a) # test "the variable on the right side of the formula is a matrix or data.frame" # TODO would like to solve this problem options(warn=2) data(gasoline, package="pls") earth.octane <- earth(octane ~ NIR, data=gasoline) print(summary(earth.octane)) # ok plotres(earth.octane) # ok expect.err(try(plotmo(earth.octane)), "the variable on the right side of the formula is a matrix or data.frame") options(warn=1) # TODO May 2020 'ElemStatLearn' is not available (for R version 4.0.0) # library(ElemStatLearn) # x <- mixture.example$x # g <- mixture.example$y # lm.mixture.example <- lm(g ~ x) # options(warn=2) # expect.err(try(plotmo(lm.mixture.example)), "the variable on the right side of the formula is a matrix or data.frame") # options(warn=1) # test variable names with $ are not supported a <- earth(O3~ozone1$doy, data=ozone1) expect.err(try(plotmo(a)), "cannot get the original model predictors") a <- earth(O3~ozone1$doy + temp, data=ozone1) expect.err(try(plotmo(a)), "cannot get the original model predictors") a <- lm(O3~ozone1$doy, data=ozone1) expect.err(try(plotmo(a)), "cannot get the original model predictors") a <- lm(O3~ozone1$doy + temp, data=ozone1) expect.err(try(plotmo(a)), "cannot get the original model predictors") #--- test interaction of w1. and non w1 args ------------------------------------- par(mfrow=c(4,3), mar=c(3, 3, 4, 1), mgp=c(2, 0.6, 0)) mod78 <- earth(Volume ~ ., data = trees) par(mfrow=c(3,4), mar=c(3, 3, 3, 1), mgp=c(2, 0.6, 0)) # multiple which, earth model plotres(mod78, cex.main=1, ylim=c(-.5, .8), xlim=c(-2, 7), col=2:3, do.par=FALSE, w1.main=c("ylim=c(-.5, .8)\nxlim=c(-2, 7) col=2:3")) # multiple which, earth model plotres(mod78, cex.main=.7, w1.ylim=c(-.5, .8), w1.xlim=c(-2, 7), col=2:3, do.par=FALSE, ylim=c(-10,10), xlim=c(-30, 100), w1.main=c("w1.ylim=c(-.5, .8) w1.xlim=c(-2, 7)\nylim=c(-10,10), xlim=c(-30, 100)")) par(org.par) par(mfrow=c(3,4), mar=c(3, 3, 3, 1), mgp=c(2, 0.6, 0)) # which=1, earth model plotres(mod78, which=1, cex.main=.8, col=2:3, main="which=1, no other ylim args", w1.main="which=1, no other ylim args") plotres(mod78, which=1, cex.main=.8, col=2:3, w1.ylim=c(.3,.98), w1.xlim=c(-2, 7), main="w1.ylim=c(.3,.98)\nw1.xlim=c(-2, 7)") plotres(mod78, which=1, cex.main=.8, col=2:3, ylim=c(.3,.98), xlim=c(-2, 7), main="ylim=c(.3,.98)\nxlim=c(-2, 7)") # ylim gets passed to modsel plotres(mod78, which=1, cex.main=.75, col=2:3, w1.ylim=c(.3,.98), ylim=c(-.5,.5), w1.xlim=c(-2, 7), xlim=c(-90, 90), main="w1.ylim=c(.3,.98), ylim=c(-.5,.5)\nw1.xlim=c(-2, 7), xlim=c(-90, 90)") # ignore ylim # which=3, earth model plotres(mod78, which=3, cex.main=1, col=2:3, main="which=3, no other ylim args") plotres(mod78, which=3, cex.main=1, col=2:3, w1.ylim=c(.3,.98), w1.xlim=c(-2, 7), main="w1.ylim=c(.3,.98)\nw1.xlim=c(-2, 7)") # not usual, ignore w1.ylim plotres(mod78, which=3, cex.main=1, col=2:3, ylim=c(-10,10), xlim=c(-90,90), main="which=3, ylim=c(-10,10)\nxlim=c(-90,90)") plotres(mod78, which=3, cex.main=1, col=2:3, w1.ylim=c(.3,.98), ylim=c(-10,10), w1.xlim=c(-2, 7), xlim=c(-90,90), main="w1.ylim=c(.3,.98) ylim=c(-10,10)\nw1.xlim=c(-2, 7), xlim=c(-90,90)") par(org.par) nullarg <- NULL expect.err(try(plotmo(nullarg)), "argument 'nullarg' is NULL") expect.err(try(plotmo(NULL)), "argument 'NULL' is NULL") expect.err(try(plotmo(0)), "'0' is not an S3 model") expect.err(try(plotmo(list(1,2))), "'list(1, 2)' is a plain list, not an S3 model") expect.err(try(plotmo(list(1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0))), "object is a plain list, not an S3 model") source("test.epilog.R") plotmo/inst/slowtests/test.fac.R0000644000176200001440000002721013727235376016463 0ustar liggesusers# test.fac.R: test factor plotting in plotmo. This also tests swapxy, xflip, and yflip # Stephen Milborrow, Berea Mar 2011 source("test.prolog.R") library(plotmo) library(earth) library(rpart) data(ozone1) data(etitanic) cat("==test plotmo with factors==\n") test.fac.with.rpart <- function(ngrid2=20) { et <- etitanic col.response <- as.numeric(et$sex)+2 et$pclass.fac <- et$pclass et$parch.int <- et$parch parch.fac <- et$parch parch.fac[parch.fac >= 3] <- 3 # use non alphabetically sorted factor levels et$parch.fac <- factor(parch.fac, labels=c( "levz", "lev1", "lev2", "levf")) et$pclass.num <- as.numeric(et$pclass) et$pclass <- et$sex <- et$age <- et$sibsp <- et$parch <- NULL cat("names(et):", names(et), "\n") # survived pclass.fac parch.int parch.fac pclass.num old.par <- par(no.readonly=TRUE) on.exit(par(old.par)) par(mfrow=c(4,5)) par(mar = c(2, 2, 3, 0.5), cex=.6) # numeric x numeric a2 <- rpart(survived ~ pclass.num+parch.int, data=et) set.seed(145) plotmo(a2, do.par=F, type2="im", degree1=2, col.response=col.response, pt.cex=.3) set.seed(145) plotmo(a2, do.par=F, type2="con", degree1=NA, col.response=col.response, pt.cex=.3) set.seed(145) plotmo(a2, do.par=F, type2="persp", degree1=NA, ngrid2=40, persp.theta=NA, persp.ticktype="d", cex.lab=.8, persp.ntick=2) # factor x numeric a3 <- rpart(survived ~ pclass.fac+parch.int, data=et) set.seed(145) plotmo(a3, do.par=F, type2="im", col.response=col.response, pt.cex=.3) set.seed(145) plotmo(a3, do.par=F, type2="con", degree1=NA, col.response=col.response, pt.cex=.3) set.seed(145) plotmo(a3, do.par=F, type2="persp", degree1=NA, ngrid2=40, persp.theta=NA, persp.ticktype="d", persp.border=NA, cex.lab=.8, persp.ntick=2) # numeric x factor a4 <- rpart(survived ~ pclass.num+parch.fac, data=et) set.seed(145) plotmo(a4, do.par=F, type2="im", tra=1, col.response=col.response, pt.cex=.3) set.seed(145) plotmo(a4, do.par=F, type2="con", degree1=NA, col.response=col.response, pt.cex=.3) set.seed(145) plotmo(a4, do.par=F, type2="persp", degree1=NA, ngrid2=40, persp.theta=NA, persp.ticktype="d", persp.border=NA, cex.lab=.8, persp.ntick=2) # factor x factor a5 <- rpart(survived ~ pclass.fac+parch.fac, data=et) set.seed(145) plotmo(a5, do.par=F, type2="im", nrug=TRUE, col.response=col.response, pt.cex=.3) set.seed(145) plotmo(a5, do.par=F, type2="con", degree1=NA, col.response=col.response, pt.cex=.3) set.seed(145) plotmo(a5, do.par=F, type2="persp", degree1=NA, ngrid2=40, persp.theta=NA, persp.ticktype="d", persp.border=NA, cex.lab=.8, persp.ntick=2) # test ndiscrete par(mfrow=c(3,5)) par(mar = c(2, 2, 3, 0.5), cex=.6) plotmo(a2, do.par=F, type2="persp", degree1=2, ndiscrete=0, main="ndiscrete=0", persp.theta=NA, persp.ticktype="d", persp.ntick=2, col.response=col.response, pt.cex=.3) plotmo(a2, do.par=F, type2="im", degree1=NA, ndiscrete=0) plotmo(a2, do.par=F, type2="con", degree1=NA, ndiscrete=0) plotmo(a2, do.par=F, type2="persp", degree1=2, degree2=NA, ndiscrete=0, main="center", center=TRUE, col.response=col.response, pt.cex=.3) plotmo(a2, do.par=F, type2="persp", degree1=2, ndiscrete=3, main="ndiscrete=3", persp.theta=NA, persp.ticktype="d", persp.ntick=2, col.response=col.response, pt.cex=.3) plotmo(a2, do.par=F, type2="im", degree1=NA, ndiscrete=3) plotmo(a2, do.par=F, type2="con", degree1=NA, ndiscrete=3) plotmo(a2, do.par=F, type2="persp", degree1=2, degree2=NA, ndiscrete=3, main="center", center=TRUE, col.response=col.response, pt.cex=.3) plotmo(a2, do.par=F, type2="persp", degree1=2, ndiscrete=10, main="ndiscrete=10", persp.theta=NA, persp.ticktype="d", persp.ntick=2, col.response=col.response, pt.cex=.3) plotmo(a2, do.par=F, type2="im", degree1=NA, ndiscrete=10) plotmo(a2, do.par=F, type2="con", degree1=NA, ndiscrete=10) plotmo(a2, do.par=F, type2="persp", degree1=2, degree2=NA, ndiscrete=10, main="center", center=TRUE, col.response=col.response, pt.cex=.3) } test.fac.with.rpart() cat("==test plotmo swapxy with factors==\n") test.swapxy.with.rpart <- function(ngrid2=20) { et <- etitanic[c(1:50,300:350,600:650),] col.response <- as.numeric(et$sex)+2 et$pclass.fac <- et$pclass et$parch.int <- et$parch parch.fac <- et$parch parch.fac[parch.fac > 2] <- 2 # use non alphabetically sorted factor levels et$parch.fac <- factor(parch.fac, labels=c("lev.zero", "lev.one", "lev.two.or.more")) print(et$parch.fac) et$pclass.num <- as.numeric(et$pclass) et$pclass <- et$sex <- et$age <- et$sibsp <- et$parch <- NULL cat("names(et):", names(et), "\n") # survived pclass.fac parch.int parch.fac pclass.num old.par <- par(no.readonly=TRUE) on.exit(par(old.par)) par(mfrow=c(4,4)) par(mar = c(2, 3, 5, 0.5), cex=.6) # factor x factor a5 <- rpart(survived ~ pclass.fac+parch.fac, data=et) for(swapxy in c(F,T)) { for(xflip in c(F,T)) for(yflip in c(F,T)) { set.seed(145) plotmo(a5, do.par=F, type2="im", degree1=NA, swapxy=swapxy, xflip=xflip, yflip=yflip, main=paste("swapxy=", swapxy, "\nxflip=", xflip, "\nyflip=", yflip), col.response=col.response, pt.cex=3, pt.pch=".") set.seed(145) plotmo(a5, do.par=F, type2="con", degree1=NA, swapxy=swapxy, xflip=xflip, yflip=yflip, main=paste("swapxy=", swapxy, "\nxflip=", xflip, "\nyflip=", yflip), col.response=col.response, pt.cex=.3) } } par(mfrow=c(2,2)) set.seed(146) plotmo(a5, do.par=F, type2="persp", degree1=NA, swapxy=FALSE, main=paste("swapxy=", FALSE), ngrid2=40, persp.theta=145, persp.ticktype="d", cex.lab=.8, persp.ntick=5) set.seed(146) plotmo(a5, do.par=F, type2="persp", degree1=NA, swapxy=TRUE, main=paste("swapxy=", TRUE), ngrid2=40, persp.theta=145, persp.ticktype="d", cex.lab=.8, persp.ntick=5) set.seed(146) plotmo(a5, do.par=F, type2="im", degree1=2, swapxy=FALSE, main=paste("swapxy=", FALSE)) } test.swapxy.with.rpart() aflip <- earth(O3~vh + wind + humidity + temp, data=ozone1, degree=2) col.response<- ifelse(ozone1$O3 == 38, "red", "pink") # test xflip arg, degree1 plots par(mfrow=c(2,2)) set.seed(102) plotmo(aflip, degree1=1:2, degree2=0, do.par=F, col.response=col.response, nrug=-1, ylab="O3", smooth.col="gray") plotmo(aflip, degree1=1:2, degree2=F, do.par=F, col.response=col.response, nrug=-1, ylab="O3", xflip=T, main="xflip=TRUE, degree1 plots", , smooth.col="gray") col.response<- ifelse(ozone1$O3 == 1, "green", "pink") # test flip args, type2=persp par(mfrow=c(2,2)) plotmo(aflip, degree1=0, degree2=2, do.par=F, persp.ticktype="d") plotmo(aflip, degree1=0, degree2=2, do.par=F, persp.tickt="d", swapxy=T, main="swapxy=TRUE") plot(0, 0, type="n", axes=FALSE, xlab="", ylab="") plot(0, 0, type="n", axes=FALSE, xlab="", ylab="") # test swapxy args, type2=image par(mfrow=c(3,3)) plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="im", col.response=col.response, main="test swapxy on image plots\nreference plot") plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="im", col.response=col.response, swapxy=T, main="swapxy=T") plot(0, 0, type="n", axes=FALSE, xlab="", ylab="") plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="im", col.response=col.response, xflip=T, main="xflip=T") plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="im", col.response=col.response, yflip=T, main="yflip=T") plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="im", col.response=col.response, xflip=T, yflip=T, main="xflip=T, yflip=T") plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="im", col.response=col.response, swapxy=T, xflip=T, main="swapxy=T, xflip=T") plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="im", col.response=col.response, swapxy=T, yflip=T, main="swapxy=T, yflip=T") plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="im", col.response=col.response, swapxy=T, xflip=T, yflip=T, main="swapxy=T, xflip=T, yflip=T") # test flip args, type2=contour plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="con", col.response=col.response, main="test flip on contour plots\nreference plot") plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="con", col.response=col.response, swapxy=T) plot(0, 0, type="n", axes=FALSE, xlab="", ylab="") plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="con", col.response=col.response, xflip=T) plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="con", col.response=col.response, yflip=T) plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="con", col.response=col.response, xflip=T, yflip=T) plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="con", col.response=col.response, swapxy=T, xflip=T) plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="con", col.response=col.response, swapxy=T, yflip=T) plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="con", col.response=col.response, swapxy=T, xflip=T, yflip=T) # ordered factor cat("==test plotmo with ordered factor==\n") par(mfcol=c(2,2)) par(mar=c(3, 3, 3, 1)) par(mgp=c(1.5, .5, 0)) a <- lm(height~., data=Loblolly) termplot(a, partial.resid=T, rug=T, terms=2, main="Seed is an ordered factor") # compare to termplot plotmo(a, do.par=F, col.resp="gray", nrug=T, all2=T) #--------------------------------------------------------------------------- # test ndiscrete with integer and non integer predictors, with missing values par(mfcol=c(2,4)) par(mar=c(3, 3, 3, 1)) par(mgp=c(1.5, .5, 0)) et <- etitanic et$var <- et$parch et$var[et$var==1] <- 0 # want a "hole" in var's value, for testing et$var[1:3] <- 6 cat("table(et$var):") print(table(et$var)) cat("\n") a <- earth(survived~var+age, data=et, degree=2, pm="none") plotmo(a, trace=FALSE, ndiscrete=0, main="integral var\n(var levels are 0 2 3 4 5 6)\nndiscrete=0", cex.lab=.8, do.par=F, smooth.col="indianred", persp.ticktype="d", clip=F, degree1=0, persp.theta=40) plotmo(a, ndiscrete=0, do.par=F, smooth.col="indianred", ylim=c(-.5,1), degree2=0, degree1=1) #------------ plotmo(a, ndiscrete=10, main="integral var\nndiscrete=10", cex.lab=.8, do.par=F, smooth.col="indianred", persp.ticktype="d", clip=F, degree1=0, persp.theta=40) plotmo(a, trace=0, ndiscrete=10, do.par=F, smooth.col="indianred", ylim=c(-.5,1), degree2=0, degree1=1) #------------ et$var <- et$var / 2 cat("table(et$var):") print(table(et$var)) cat("\n") a <- earth(survived~var+age, data=et, degree=2, pm="none") plotmo(a, ndiscrete=0, main="integral var\n(var levels are 0 1 1.5 2 2.5 3)\nndiscrete=0", cex.lab=.8, do.par=F, smooth.col="indianred", persp.ticktype="d", clip=F, degree1=0, persp.theta=40) plotmo(a, ndiscrete=0, do.par=F, smooth.col="indianred", ylim=c(-.5,1), degree2=0, degree1=1) #------------ plotmo(a, ndiscrete=10, main="non integral var\nndiscrete=10", cex.lab=.8, do.par=F, smooth.col="indianred", persp.ticktype="d", clip=F, degree1=0, persp.theta=40) plotmo(a, ndiscrete=10, do.par=F, smooth.col="indianred", ylim=c(-.5,1), degree2=0, degree1=1) source("test.epilog.R") plotmo/inst/slowtests/test.c50.Rout.save0000644000176200001440000000601214563614021017766 0ustar liggesusers> # test.c50.R: c50 tests for plotmo and plotres > > source("test.prolog.R") > library(C50) > library(rpart.plot) # for ptitanic, want data with NAs for testing Loading required package: rpart > library(plotmo) Loading required package: Formula Loading required package: plotrix > library(earth) # for etitanic > data(etitanic) > get.tit <- function() # abbreviated titanic data + { + tit <- etitanic + pclass <- as.character(tit$pclass) + # change the order of the factors so not alphabetical + pclass[pclass == "1st"] <- "first" + pclass[pclass == "2nd"] <- "class2" + pclass[pclass == "3rd"] <- "classthird" + tit$pclass <- factor(pclass, levels=c("class2", "classthird", "first")) + # log age is so we have a continuous predictor even when model is age~. + set.seed(2015) + tit$logage <- log(tit$age) + rnorm(nrow(tit)) + tit$parch <- NULL + # by=12 gives us a small fast model with an additive and a interaction term + tit <- tit[seq(1, nrow(etitanic), by=12), ] + } > tit <- get.tit() > > c50.tree.xy <- C5.0(x=tit[,-1], y=tit[,1]) # predict pclass > plotmo(c50.tree.xy, type="prob", nresponse="first", pmethod="apartdep") calculating apartdep for survived calculating apartdep for age calculating apartdep for logage calculating apartdep for survived:age 0123456790 calculating apartdep for survived:logage 0123456790 calculating apartdep for age:logage 01234567890 > plotmo(c50.tree.xy, type="class") plotmo grid: survived sex age sibsp logage 0 male 30 0 3.06991 > # TODO following gives error: type should be either 'class', 'confidence' or 'prob' > # try(plotmo(c50.tree.xy, type="confidence")) > plotres(c50.tree.xy, type="prob", nresponse="first") > > c50.tree.form <- C5.0(pclass~., data=tit) # predict pclass > plotmo(c50.tree.form, type="prob", nresponse="first") plotmo grid: survived sex age sibsp logage 0 male 30 0 3.06991 > plotmo(c50.tree.form, type="class") plotmo grid: survived sex age sibsp logage 0 male 30 0 3.06991 > # TODO following gives error: type should be either 'class', 'confidence' or 'prob' > # try(plotmo(c50.tree.form, type="confidence")) > plotres(c50.tree.form, type="prob", nresponse="first") > > tit$survived <- factor(ifelse(tit$survived == 1, "yes", "no"), + levels = c("yes", "no")) > c50.tree.survived <- C5.0(survived~., data=tit, trials=5) # predict survived > plotmo(c50.tree.survived, type="prob", nresponse="yes") plotmo grid: pclass sex age sibsp logage classthird male 30 0 3.06991 > plotmo(c50.tree.survived, type="class") plotmo grid: pclass sex age sibsp logage classthird male 30 0 3.06991 > # TODO following gives error: type should be either 'class', 'confidence' or 'prob' > # try(plotmo(c50.tree.survived, type="confidence")) > plotres(c50.tree.survived, type="prob", nresponse="yes") > > source("test.epilog.R") plotmo/inst/slowtests/test.center.R0000644000176200001440000001122613725307662017206 0ustar liggesusers# test.center.R: test plotmo's center and ndiscrete args # Stephen Milborrow, Berea Apr 2011 source("test.prolog.R") library(rpart.plot) library(plotmo) library(earth) data(etitanic) et <- etitanic[, c("survived", "pclass", "sex", "age")] et$pclassn <- as.numeric(et$pclass) et <- et[c(30:80,330:380,630:680), ] par(mfrow=c(3,3)) par(mar=c(3, 3.5, 3, 0.5)) par(mgp=c(1.5, .5, 0)) ndiscrete <- 0 #--- row 1 set.seed(844) a1 <- lm(survived~pclassn+sex, data=et) plotmo(a1, all2=T, do.par=F, degree1=NA, degree2=1, center=TRUE, clip=F, main="a1: survived~pclassn+sex\n(default ndiscrete)", pt.col=ifelse(et$survived, "black", "red"), pt.pch=".", pt.cex=2.5, lab=c(1,1,1)) set.seed(844) plotmo(a1, degree1=1, all2=T, degree2=0, do.par=F, xflip=T, center=TRUE, clip=F, grid.levels=list(sex="f"), ndiscrete=ndiscrete, main="pclassn with sex=\"female\"", smooth.col="lightblue", smooth.lwd=2, pt.col=ifelse(et$survived, "black", "red"), pt.pch=".", pt.cex=2.5) set.seed(844) plotmo(a1, degree1=1, all2=T, degree2=0, do.par=F, xflip=T, center=TRUE, clip=F, grid.levels=list(sex="m"), ndiscrete=ndiscrete, main="pclassn with sex=\"male\"", smooth.col="lightblue", smooth.lwd=2, pt.col=ifelse(et$survived, "black", "red"), pt.pch=".", pt.cex=2.5) #--- row 2 a2 <- lm(survived~pclassn*sex, data=et) set.seed(844) plotmo(a2, all2=T, do.par=F, degree2=1, degree1=0, center=TRUE, clip=F, main="a2: survived~pclassn*sex\n(default ndiscrete)") set.seed(844) plotmo(a2, degree1=1, all2=T, degree2=0, do.par=F, xflip=T, center=TRUE, clip=F, grid.levels=list(sex="f"), ndiscrete=ndiscrete, main="pclassn with sex=\"female\"", smooth.col="lightblue", smooth.lwd=2, pt.col=ifelse(et$survived, "black", "red"), pt.pch=".", pt.cex=2.5) set.seed(844) plotmo(a2, degree1=1, all2=T, degree2=0, do.par=F, xflip=T, center=TRUE, clip=F, grid.levels=list(sex="m"), ndiscrete=ndiscrete, main="pclassn with sex=\"male\"", smooth.col="lightblue", smooth.lwd=2, pt.col=ifelse(et$survived, "black", "red"), pt.pch=".", pt.cex=2.5) #--- row 3 par(mfg=c(3,2)) a3 <- lm(survived~pclassn, data=et) set.seed(844) plotmo(a3, do.par=F, xflip=T, center=TRUE, clip=F, ndiscrete=ndiscrete, main="a3: survived~pclassn", degree1.col=1, smooth.col="lightblue", smooth.lwd=2, pt.col=ifelse(et$survived, "black", "red"), pt.pch=".", pt.cex=2.5) plot(0, 0, type="n", axes=FALSE, xlab="", ylab="") #--- row 1 # note that this is an example of a model that gets generated differently # with Scale.y=TRUE vs Scale.y=FALSE (although not shown here) a4 <- earth(survived~pclassn+age, data=et, degree=2) set.seed(844) plotmo(a4, do.par=F, center=TRUE, clip=F, ylim=c(-.6,.7), main="earth: survived~pclassn+age\n(default ndiscrete)", degree1=0, all2=T) set.seed(844) plotmo(a4, do.par=F, xflip=F, all1=T, center=TRUE, clip=F, ylim=c(-.6,.7), main="a4, age with pclassn=1st", ndiscrete=ndiscrete, degree2=0, degree1=2, # grid.levels=list(pclassn="1st"), grid.levels=list(pclassn=1), smooth.col="lightblue", smooth.lwd=2, pt.col=ifelse(et$survived, "black", "red"), pt.pch=".", pt.cex=2.5) set.seed(844) plotmo(a4, do.par=F, xflip=F, all1=T, center=TRUE, clip=F, ylim=c(-.6,.7), main="age with pclassn=3rd", ndiscrete=ndiscrete, degree2=0, degree1=2, grid.levels=list(pclassn=3), smooth.col="lightblue", smooth.lwd=2, pt.col=ifelse(et$survived, "black", "red"), pt.pch=".", pt.cex=2.5) #--- row 2 set.seed(844) plotmo(a4, do.par=F, center=TRUE, clip=F, type2="im", main="a4 earth: survived~pclassn+age\n(default ndiscrete)", degree1=0, all2=T, yflip=T, pt.col=ifelse(et$survived, 1, "red"), image.col=gray(seq(6, 10, length=10) / 10), xflip=T, pt.pch=".", pt.cex=2) set.seed(844) plotmo(a4, do.par=F, xflip=F, all1=T, center=TRUE, clip=F, main="pclassn with age=10", ndiscrete=ndiscrete, degree2=0, degree1=1, grid.levels=list(age=10), smooth.col="lightblue", smooth.lwd=2, pt.col=ifelse(et$survived, "black", "red"), pt.pch=".", pt.cex=2.5) set.seed(844) plotmo(a4, do.par=F, xflip=F, all1=T, center=TRUE, clip=F, main="pclassn with age=40", ndiscrete=ndiscrete, degree2=0, degree1=1, grid.levels=list(age=40), smooth.col="lightblue", smooth.lwd=2, pt.col=ifelse(et$survived, "black", "red"), pt.pch=".", pt.cex=2.5) source("test.epilog.R") plotmo/inst/slowtests/test.gbm.bat0000755000176200001440000000142314664203360017032 0ustar liggesusers@rem test.gbm.bat: gbm tests for plotmo and plotres @echo test.gbm.bat @"C:\PROGRA~1\R\R-4.4.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.glmnet.R0000644000176200001440000004463113727235376017226 0ustar liggesusers# test.glmnet.R: glmnet tests for plotmo and plotres source("test.prolog.R") library(earth) library(glmnet) data(ozone1) data(etitanic) get.tit <- function() # abbreviated titanic data { tit <- etitanic pclass <- as.character(tit$pclass) # change the order of the factors so not alphabetical pclass[pclass == "1st"] <- "first" pclass[pclass == "2nd"] <- "class2" pclass[pclass == "3rd"] <- "classthird" tit$pclass <- factor(pclass, levels=c("class2", "classthird", "first")) # log age is so we have a continuous predictor even when model is age~. set.seed(2015) tit$logage <- log(tit$age) + rnorm(nrow(tit)) tit$parch <- NULL # by=12 gives us a small fast model with an additive and a interaction term tit <- tit[seq(1, nrow(etitanic), by=12), ] } plotmo1 <- function(object, ..., trace=0, SHOWCALL=TRUE, caption=NULL) { if(is.null(caption)) caption <- paste(deparse(substitute(object)), collapse=" ") call <- match.call(expand.dots=TRUE) call <- strip.space(paste(deparse(substitute(call)), collapse=" ")) printf("%s\n", call) plotmo(object, trace=trace, SHOWCALL=SHOWCALL, caption=caption, ...) } plotres1 <- function(object, ..., trace=0, SHOWCALL=TRUE, caption=NULL) { if(is.null(caption)) caption <- paste(deparse(substitute(object)), collapse=" ") call <- match.call(expand.dots=TRUE) call <- strip.space(paste(deparse(substitute(call)), collapse=" ")) printf("%s\n", call) plotres(object, trace=trace, SHOWCALL=SHOWCALL, caption=caption, ...) } tit <- get.tit() set.seed(2015) xmat <- as.matrix(tit[,c(2,5,6)]) set.seed(2015) mod.glmnet.xmat <- glmnet(xmat, tit[,4]) # plotmo on glmnet mods is boring but we test it anyway plotmo1(mod.glmnet.xmat) plotres1(mod.glmnet.xmat) # compare to plot.glmnet par(mfrow=c(4,2), mar=c(3,6,3.5,6)) # extra side margins for more square plots plot_glmnet(mod.glmnet.xmat, main="mod.glmnet.xmat\ncompare to plot.glmnet") plot(0,0) plot_glmnet(mod.glmnet.xmat, xvar="norm", col=c(3,2,1)) plot(mod.glmnet.xmat, xvar="norm") plot_glmnet(mod.glmnet.xmat, xvar="lambda") plot(mod.glmnet.xmat, xvar="lambda") plot_glmnet(mod.glmnet.xmat, xvar="dev") plot(mod.glmnet.xmat, xvar="dev") par(org.par) set.seed(2015) mod.cv.glmnet.xmat <- cv.glmnet(xmat, tit[,4], nfolds=3) # following was needed before plotmo 3.1.3 (before adding plotmo.prolog.cv.glmnet) # mod.cv.glmnet.xmat$x <- as.data.frame(xmat) # mod.cv.glmnet.xmat$y <- tit[,4] cat("==Test plotmo trace=1 and lambda.min\n") plotmo1(mod.cv.glmnet.xmat, predict.s="lambda.min", trace=1) cat("==Test plotmo trace=2 and lambda.min\n") plotmo1(mod.cv.glmnet.xmat, predict.s="lambda.min", trace=2) cat("==Test plotres trace=1 and lambda.1se\n") plotres1(mod.cv.glmnet.xmat, predict.s="lambda.1se", trace=1) cat("==Test plotres trace=2 and lambda.1se\n") plotres1(mod.cv.glmnet.xmat, predict.s="lambda.1se", trace=2) set.seed(2015) x <- matrix(rnorm(100*20),100,20) # 20 variables y <- rnorm(100) mod <- glmnet(x,y) plotmo1(mod) # test w1.label par(mfrow=c(2,3)) par(cex=1) par(mar=c(3,3,3,1)) plotres(mod, which=1, w1.main="default w1.label") plotres(mod, which=1, w1.label=5, w1.main="w1.label=5") plotres(mod, which=1, w1.label=0, w1.main="w1.label=0") plotres(mod, which=1, w1.label=TRUE, w1.main="w1.label=TRUE") plotres(mod, which=1, w1.label=100, w1.main="w1.label=100") par(org.par) # test w1 and non w1 args passed par(mfrow=c(2,2), mar=c(4,4,4,4), cex=1) plot_glmnet(mod, w1.col=3:4, w1.xvar="norm", main="plot_glmnet\nw1.col=3:4 w1.xvar=\"norm\"") plot_glmnet(mod, col=3:4, xvar="norm", main="plot_glmnet\ncol=3:4 xvar=\"norm\"") plot_glmnet(mod, col=3:4, w1.col=1:2, w1.xvar="norm", xvar="lambda", main="plot_glmnet\ncol=3:4 w1.col=1:2\nw1.xvar=\"norm\", xvar=\"lambda\"") par(org.par) par(mfrow=c(3,2), mar=c(3,4,4,4), cex=1) plotres(mod, which=c(1,3), do.par=FALSE, w1.col=3:4, w1.xvar="norm", w1.main="plotres\nw1.col=3:4 w1.xvar=\"norm\"") plotres(mod, which=c(1,3), do.par=FALSE, col=3:4, xvar="norm", w1.main="plotres\nplotres\ncol=3:4 xvar=\"norm\"") plotres(mod, which=c(1,3), do.par=FALSE, col=3:4, w1.col=1:2, w1.main="plotres\ncol=3:4 w1.col=1:2") par(org.par) # glmnet with sparse matrices set.seed(2015) n <- 100 p <- 20 nzc <- trunc(p/10) x <- matrix(rnorm(n*p),n,p) iz <- sample(1:(n*p),size=n*p*.85,replace=FALSE) x[iz] <- 0 sx <- Matrix(x,sparse=TRUE) # colnames(sx) <- paste("x", 1:ncol(sx), sep="") # need column names for plotmo inherits(sx,"sparseMatrix") # confirm that it is sparse beta <- rnorm(nzc) fx <- x[,seq(nzc)]%*%beta eps <- rnorm(n) y <- fx+eps px <- exp(fx) px <- px/(1+px) ly <- rbinom(n=length(px),prob=px,size=1) mod.glmnet.sx <- glmnet(sx,y) plotmo1(mod.glmnet.sx, all2=TRUE) # will give warning: too many predictors to plot all pairs plotmo1(mod.glmnet.sx, all2=2, caption="all2=2") # test all2=2 plotmo1(mod.glmnet.sx, all2=2, degree2=1:3, caption="all2=2 degree2=1:3") plotres(mod.glmnet.sx) par(org.par) par(mfrow=c(2,4), mar=c(3,3,3,1), mgp=c(1.5,0.5,0), oma=c(0,0,2.5,0)) y <- trees$Volume x <- as.matrix(data.frame(Girth=trees$Girth, Height=trees$Height)) glmnet <- glmnet(x, y) plotres(glmnet, do.par=FALSE, caption="glmnet and lm: top and bottom should be the same") lm <- lm(Volume~., data=trees) plotres(lm, do.par=FALSE, SHOWCALL=TRUE) par(mfrow=c(3,2), mar=c(3,3,3,1), mgp=c(1.5,0.5,0), oma=c(0,0,2.5,0)) plotres(glmnet, do.par=FALSE, which=c(1,3), w1.xvar="norm", caption="glmnet with various options", SHOWCALL=TRUE) plotres(glmnet, trace=1, do.par=FALSE, which=c(1,3), SHOWCALL=TRUE) plotres(glmnet, trace=1, do.par=FALSE, which=c(1,3), predict.s=5, SHOWCALL=TRUE) par(org.par) printf("======== glmnet additional tests\n") set.seed(2015) p <- 10 n <- 30 x <- cbind(matrix(rnorm(n*p),n,p)) y <- rowSums(x[,1:3]^3) glmnet <- glmnet(x,y) plotres(glmnet, SHOWCALL=TRUE, caption="glmnet: y <- rowSums(x[,1:3]^3)") plotres(glmnet, SHOWCALL=TRUE, w1.xvar="norm") par(mfrow=c(1,1)) omar <- par("mar") ocex.axis <- par("cex.axis") ocex.lab <- par("cex.lab") plotres(glmnet, SHOWCALL=TRUE, which=1) stopifnot(par("mar") == omar) stopifnot(par("cex.axis") == ocex.axis) stopifnot(par("cex.lab") == ocex.lab) par(org.par) # test some args for plot_glmnet plotres(glmnet, predict.s=.05, SHOWCALL=TRUE, trace=0, col.main=2, w1.xlab="my xlab", w1.ylab="my ylab", w1.main="test some args for plot_glmnet1", w1.col=4:1) plot_glmnet(glmnet, trace=0, col.main=2, main="test some args for plot_glmnet2", xlab="my xlab", ylab="my ylab", col=4:1, ylim=c(-2,4)) # TODO xlim=c(-5,3)) plotres(glmnet, predict.s=.05, SHOWCALL=TRUE, which=c(1,3), grid.col="gray", do.par=2) plotres(glmnet, predict.s=.05, SHOWCALL=TRUE, which=c(1,3), w1.s.col=0, do.par=0) par(org.par) # TODO the following issues a stream of warnings: restarting interrupted promise evaluation expect.err(try(plotres(glmnet, w1.col=nonesuch)), "cannot evaluate 'col'") printf("======== glmnet multinomial (multnet)\n") par(mfrow=c(4,4), mar=c(3,3,3,1)) set.seed(2016) n <- 200 p <- 4 x <- matrix(rnorm(n*p), n, p) colnames(x) <- paste("x", 1:ncol(x), sep="") # "1" is correlated with x[,1], "4" is correlated with x[,2], "2" and "3" not correlated y <- ifelse(x[,1] > 0.5, 1, ifelse(x[,2] > 0.0, 4, sample(c(2,3), size=nrow(x), replace=TRUE))) print(cov(x, y)) y <- factor(y) # TODO Following causes the following warning: # Warning: from glmnet Fortran code (error code -90); Convergence for 90th lambda value not reached after maxit=100000 iterations; solutions for larger lambdas returned multinomial.mod <- glmnet(x, y, family="multinomial") plotres(multinomial.mod, nresponse=1, w1.main="nresponse=1", main="family=\"multinomial\"", smooth.col=0, info=TRUE, trace=0, which=c(1,3), do.par=FALSE, xlim=c(-.2,1.2), ylim=c(-1.2, 1.2)) plotres(multinomial.mod, nresponse=2, w1.main="nresponse=2", smooth.col=0, info=TRUE, trace=0, which=c(1,3), do.par=FALSE, xlim=c(-.2,1.2), ylim=c(-1.2, 1.2)) plotres(multinomial.mod, nresponse=3, w1.main="nresponse=3", smooth.col=0, info=TRUE, trace=0, which=c(1,3), do.par=FALSE, xlim=c(-.2,1.2), ylim=c(-1.2, 1.2)) plotres(multinomial.mod, nresponse=4, w1.main="nresponse=4", smooth.col=0, info=TRUE, trace=0, which=c(1,3), do.par=FALSE, xlim=c(-.2,1.2), ylim=c(-1.2, 1.2)) plotmo(multinomial.mod, nresponse=1, trace=0, do.par=FALSE, degree1=1:2) plotmo(multinomial.mod, nresponse=2, trace=0, do.par=FALSE, degree1=1:2) par(mgp=c(1.5, .4, 0)) plot(multinomial.mod, xvar="norm") # compare to plot.glmnet par(org.par) # compare to earth par(mfrow=c(4,3), mar=c(3,3,1,1)) yfac <- factor(c("a","b","c","d")[y]) earth.mod <- earth(x, yfac, trace=0) plotres(earth.mod, nresponse=1, main=sprint("multiresponse\nnresponse=1 rsq %.2g", earth.mod$rsq.per.response[1]), which=3, xlim=c(-.2, 1.2), ylim=c(-1.2, 1.2), smooth.col=0, info=TRUE, do.par=FALSE, trace=0, jitter=7, cex.response=.7) plotmo(earth.mod, nresponse=1, do.par=FALSE) plotres(earth.mod, nresponse=2, main=sprint("nresponse=2 rsq %.2g", earth.mod$rsq.per.response[2]), which=3, xlim=c(-.2, 1.2), ylim=c(-1.2, 1.2), smooth.col=0, info=TRUE, do.par=FALSE, trace=0, jitter=7, cex.response=.7) plotmo(earth.mod, nresponse=2, do.par=FALSE) plotres(earth.mod, nresponse=3, main=sprint("nresponse=3 rsq %.2g", earth.mod$rsq.per.response[3]), which=3, xlim=c(-.2, 1.2), ylim=c(-1.2, 1.2), smooth.col=0, info=TRUE, do.par=FALSE, trace=0, jitter=7, cex.response=.7) plotmo(earth.mod, nresponse=3, do.par=FALSE) plotres(earth.mod, nresponse=4, main=sprint("nresponse=4 rsq %.2g", earth.mod$rsq.per.response[4]), which=3, xlim=c(-.2, 1.2), ylim=c(-1.2, 1.2), smooth.col=0, info=TRUE, do.par=FALSE, trace=0, jitter=7, cex.response=.7) plotmo(earth.mod, nresponse=4, do.par=FALSE) print(summary(earth.mod)) par(org.par) printf("======== binomial model\n") set.seed(2019) n <- 50 p <- 4 x <- matrix(rnorm(n*p), n, p) colnames(x) <- paste("x", 1:ncol(x), sep="") y <- ifelse(x[,1] + x[,2] + .1 * rnorm(n) > .5, TRUE, FALSE) print(cov(x, y)) y <- factor(y) glmnet.binomial <- glmnet(x, y, family="binomial") par(mfrow=c(2,3), mar=c(3,3,1,1)) plotres(glmnet.binomial, info=T, predict.s=.02, which=c(1,3), do.par=FALSE, w1.main="glmnet.binomial") plot(glmnet.binomial) earth.mod <- earth(x, y) set.seed(2019) plotres(earth.mod, info=T, which=c(1,3), do.par=FALSE) par(org.par) par(mfrow=c(2,4), mar=c(3,3,1,1)) set.seed(2019) plotmo(glmnet.binomial, do.par=FALSE) plotmo(earth.mod, do.par=FALSE, main="binomial earth.mod") par(org.par) printf("======== glmnet family=\"mgaussian\"\n") set.seed(2015) p <- 10 n <- 30 x <- cbind((1:n)/n, matrix(rnorm(n*(p-1)),n,p-1)) colnames(x) <- paste0("x", 1:p) # ymultresp <- cbind(rowSums(x[,1:5]^3), rowSums(x[,5:p]^3), 1:n) set.seed(1) ymultresp <- cbind(x[,1]+.001*rnorm(n), rowSums(x[,2:5]^3), rnorm(n)) glmnet.mgaussian <- glmnet(x, ymultresp, family="mgaussian") plotres(glmnet.mgaussian, nresponse=1, SHOWCALL=TRUE, which=c(1:3), do.par=2, info=1) # manually calculate the residuals plot(x=predict(glmnet.mgaussian, newx=x, s=0)[,1,1], y=ymultresp[,1] - predict(glmnet.mgaussian, newx=x, s=0)[,1,1], pch=20, xlab="Fitted", ylab="Residuals", main="Manually calculated residuals, nresponse=1, s=0") abline(h=0, col="gray") par(org.par) plotres(glmnet.mgaussian, nresponse=2, SHOWCALL=TRUE, which=c(1:3), do.par=2, info=1) # manually calculate the residuals plot(x=predict(glmnet.mgaussian, newx=x, s=0)[,2,1], y=ymultresp[,2] - predict(glmnet.mgaussian, newx=x, s=0)[,2,1], pch=20, xlab="Fitted", ylab="Residuals", main="Manually calculated residuals, nresponse=2, s=0") abline(h=0, col="gray") par(org.par) plotmo(glmnet.mgaussian, nresponse=1, SHOWCALL=TRUE) plotmo(glmnet.mgaussian, nresponse=2, SHOWCALL=TRUE) graphics::par(mfrow=c(2,2), mgp=c(1.5,0.4,0), tcl=-0.3, cex.main=1, font.main=1, mar=c(4,3,1.2,0.8), oma=c(0,0,4,0), cex=0.83) plotres(glmnet.mgaussian, nresponse=2, SHOWCALL=TRUE, which=3, do.par=FALSE, caption="glmnet.mgaussian compare to manually calculated residuals") plot(x=predict(glmnet.mgaussian, newx=x, s=0)[,2,1], y=ymultresp[,2] - predict(glmnet.mgaussian, newx=x, s=0)[,2,1], pch=20, xlab="Fitted", ylab="Residuals", main="Manual residuals, nresponse=2, s=0") abline(h=0, col="gray") plotres(glmnet.mgaussian, nresponse=2, predict.s=.5, SHOWCALL=TRUE, which=3, do.par=FALSE) plot(x=predict(glmnet.mgaussian, newx=x, s=.5)[,2,1], y=ymultresp[,2] - predict(glmnet.mgaussian, newx=x, s=.5)[,2,1], pch=20, xlab="Fitted", ylab="Residuals", main="Manual residuals, nresponse=2, s=.5") abline(h=0, col="gray") plotres(glmnet.mgaussian, predict.s=.05, nresponse=3, info=TRUE, SHOWCALL=TRUE) # essentially random par(org.par) par(mfrow=c(2,3), mar=c(3,3,3,.5), oma=c(0,0,3,0), mgp=c(1.5,0.4,0), tcl=-0.3) data(trees) set.seed(2015) # variable with a long name x50 <- cbind(trees[,1:2], Girth12345678901234567890=rnorm(nrow(trees))) mod.with.long.name <- glmnet(data.matrix(x50),data.matrix(trees$Volume)) plotres(mod.with.long.name, which=1, caption="test plot_glmnet with x50 and x60") # one inactive variable (all coefs are zero for variable "rand") set.seed(2015) x60 <- cbind(trees[,1], rand=rnorm(nrow(trees)), trees[,2]) # complicate the issue: use an unnamed column (column 3) colnames(x60) <- c("Girth", "rand", "") mod.with.inactive.var <- glmnet(data.matrix(x60),data.matrix(trees$Volume)) mod.with.inactive.var$beta["rand",] = 0 # TODO hack force inactive variable plotres(mod.with.inactive.var, which=1) plotres(mod.with.inactive.var, which=1, w1.xvar="norm") # compare to plot.glmnet (but note that labels aren't always plotted unless par=c(1,1)?) plot(mod.with.inactive.var, xvar="norm", label=TRUE) # plotmo calls the unnamed column "x3", fair enough plotmo(mod.with.inactive.var, do.par=FALSE, pt.col=2) # single active variable x70 <- cbind(trees[,1,drop=F], 0) a <- glmnet(data.matrix(x70), data.matrix(trees$Volume)) par(org.par) par(mfrow=c(2,2), mar=c(3,3,2,4)) plotres(a, which=1, predict.s=1, caption="single active variable") plotres(a, which=1, w1.xvar="norm") plotres(a, which=1, w1.xvar="lambda") plotres(a, which=1, w1.xvar="dev") #--- test interaction of w1. and non w1 args ------------------------------------- #--- glmnet model, which=1 --- par(org.par) par(mfrow=c(4,3), mar=c(3, 3, 4, 1), mgp=c(2, 0.6, 0)) plotres(mod.glmnet.xmat, which=1, w1.xlim=c(6,-6), w1.ylim=c(-5,5), w1.col=1:2, w1.main="TEST INTERACTION OF W1 ARGS PAGE 1 (which=1)\n\nwhich=1 w1.xlim=c(6,-6)\nw1.ylim=c(-5,5)) w1.col=1:2,") plotres(mod.glmnet.xmat, which=1, cex.main=1.2, xlim=c(9,-9), ylim=c(-60,60), col=3:4, w1.main="which=1 xlim=c(9,-9)\nylim=c(-60,60)) col=3:4,") plotres(mod.glmnet.xmat, which=1, cex.main=1, xlim=c(9,-9), w1.xlim=c(6,-6), ylim=c(-60,60), w1.ylim=c(-5,5), w1.col=1:2, col=3:4, w1.main="which=1 xlim=c(9,-9), w1.xlim=c(6,-6)\nylim=c(-60,60), w1.ylim=c(-5,5)) w1.col=1:2, col=3:4") #--- glmnet model, which=c(1,3,4) --- plotres(mod.glmnet.xmat, which=c(1,3,4), cex.main=1, ylim=c(-70,70), xlim=c(-20, 60), col=2:3, do.par=FALSE, w1.main="TEST INTERACTION OF W1 ARGS PAGE 1 (which=c(1,3,4))\nlim=c(-70,70), xlim=c(-20, 60)") plotres(mod.glmnet.xmat, which=c(1,3,4), cex.main=1.2, ylim=c(-70,70), xlim=c(-20, 60), qq.xlim=c(-7,5), col=2:3, do.par=FALSE, w1.main="ylim=c(-70,70), xlim=c(-20, 60)\nqq.xlim=c(-7,5)") plotres(mod.glmnet.xmat, which=c(1,3,4), cex.main=1.2, w1.ylim=c(-7,7), w1.xlim=c(4,-4), col=2:3, do.par=FALSE, w1.main="w1.ylim=c(-7,7), w1.xlim=c(4,-4)") # plotres(mod.glmnet.xmat, which=c(1,3,4), cex.main=.9, # w1.ylim=c(-7,7), ylim=c(-20,20), # qq.xlim=c(-7,5), col=2:3, do.par=FALSE, # qq.ylim=c(-100,100), # main="w1.ylim=c(-7,7) ylim=c(-20,20)\nqq.xlim=c(-7,5) qq.ylim=c(-100,100)") par(org.par) par(mfrow=c(3,3), mar=c(3, 3, 4, 1), mgp=c(2, 0.6, 0)) plotres(mod.glmnet.xmat, which=c(1,3,4), do.par=FALSE, # w1.main="which=c(1,3,4)", w1.xlim=c(6,-6), w1.ylim=c(-5,5), w1.col=2:3, w1.main="TEST INTERACTION OF W1 ARGS PAGE 2\n\nwhich=c(1,3,4) w1.xlim=c(6,-6)\nw1.ylim=c(-5,5)) w1.col=2:3") plotres(mod.glmnet.xmat, which=c(1,3,4), w1.cex.main=1, do.par=FALSE, # w1.main="which=c(1,3,4)", xlim=c(-20,70), ylim=c(-60,60), w1.col=2:3, col=3:4, w1.main="which=c(1,3,4) ylim=c(-60,60))\nw1.col=2:3, col=3:4") plotres(mod.glmnet.xmat, which=c(1,3,4), w1.cex.main=1, do.par=FALSE, # w1.main="which=c(1,3,4)", xlim=c(-20,70), w1.xlim=c(6,-6), ylim=c(-60,60), w1.ylim=c(-5,5), col=3:4, w1.main="which=c(1,3,4) xlim=c(9,-9), w1.xlim=c(6,-6)\nylim=c(-60,60), w1.ylim=c(-5,5)) w1.col=1:2, col=3:4") par(org.par) #-- make sure that we can work with all families set.seed(2016) par(mfrow=c(3,3), mar=c(3,3,3,1)) n <- 100 p <- 4 x <- matrix(rnorm(n*p), n, p) g2 <- sample(1:2, n, replace=TRUE) for(family in c("gaussian","binomial","poisson")) { mod <- glmnet(x,g2,family=family) plot(mod, xvar="lambda") plotres(mod, w1.xvar="lambda", main=paste("family", family), which=c(1,3), do.par=FALSE) } # cox library(plotmo) n <- 100 p <- 20 nzc <- trunc(p/10) set.seed(2016) beta <- rnorm(nzc) x7 <- matrix(rnorm(n*p), n, p) beta <- rnorm(nzc) fx <- x7[,seq(nzc)] %*% beta/3 hx <- exp(fx) ty <- rexp(n, hx) tcens <- rbinom(n=n, prob=.3, size=1)# censoring indicator y <- cbind(time=ty, status=1-tcens) # y=Surv(ty,1-tcens) with library(survival) glmnet.cox <- glmnet(x=x7, y=y, family="cox") plot(glmnet.cox) title("glmnet.cox", line=2) plot_glmnet(glmnet.cox, xvar="norm") plotres(glmnet.cox, which=3, do.par=FALSE) par(org.par) # test col argument par(mfrow=c(2,3), mar=c(3,3,5,1), cex=1) mod <- glmnet(as.matrix(mtcars[-1]), mtcars[,1]) plot_glmnet(mod, main="plot_glmnet default") plot_glmnet(mod, col=c(1,2,3,0,0,NA,0,0,0,0), main="col=c(1,2,3,0,0,NA,0,0,0,0)") g <- "gray" plot_glmnet(mod, col=c("black","red","green",g,g,g,g,g,"steelblue","darkorange"), main="col=c('black','red','green',g,g,g,g,g,'steelblue','darkorange')") plot_glmnet(mod, col=c("black","red","green",0,0,0,0,0,"steelblue","darkorange"), main="col=c('black','red','green',0,0,0,0,0,'steelblue','darkorange')") plot_glmnet(mod, col=c("black","red", 0), main="col=c('black','red', 0)") # test recycling, including 0 par(org.par) source("test.epilog.R") plotmo/inst/slowtests/test.glmnetUtils.bat0000755000176200001440000000157314655214117020604 0ustar liggesusers@rem test.glmnetUtils.bat: glmnetUtils tests for plotmo and plotres @echo test.glmnetUtils.bat @"C:\PROGRA~1\R\R-4.4.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.partdep.R0000644000176200001440000002003714663412556017366 0ustar liggesusers# partdep.test.R: partdep tests for plotmo and plotres source("test.prolog.R") library(plotmo) library(earth) data(etitanic) mod <- earth(survived~., data=etitanic, degree=2) plotmo(mod, caption="plotmo classical") plotmo(mod, pmethod="partdep", caption="plotmo partdep age") set.seed(2016) plotmo(mod, pmethod="apartdep", caption="plotmo apartdep age", do.par=2) set.seed(2016) plotmo(mod, pmethod="apartdep", ylim=c(0,1), do.par=0, type2="image", pt.col=ifelse(etitanic$survived, "green", "red"), degree1=0, degree2=1:3) par(org.par) # compare to gbm with an artifical function of variables with a very strong interaction library(gbm) n <- 250 set.seed(2016) x1 <- runif(n) x2 <- runif(n) x3 <- runif(n) y <- ifelse(x2 > .6, x1-.2, ifelse(x2 > .4, 1 - 1.5 * x1, .3)) + .1 * sin(4 * x3) data <- data.frame(x1=x1, x2=x2, x3=x3, y=y) n.trees <- 20 set.seed(2016) mod <- gbm(y~., data=data, n.trees=n.trees, shrinkage=.1, distribution="gaussian", interact=5) plotmo(mod, degree1=0, persp.ticktype="detailed", caption="variables with a strong interaction") par(mfrow=c(4,4), mar=c(2,3,2,1), mgp=c(1.5, 0.5, 0), oma=c(0,0,6,0)) library(viridis); image.col <- viridis(100) ngrid1 <- 50 ngrid2 <- 30 plotmo(mod, pmethod="plot", do.par=0, degree2=2, type2="im", ylim=NULL, clip=FALSE, image.col=image.col, ngrid1=ngrid1, ngrid=ngrid2) title("row1: plotmo classic\nrow2: plotmo apartdep\nrow3: plotmo partdep\nrow4: plot.gbm\n\n\n\n\n\n\n", xpd=NA) ylim <- c(.21, .40) set.seed(2016) # for consistent selection of rows for partdep.x plotmo(mod, pmethod="apartdep", do.par=0, degree2=2, type2="im", ylim=ylim, clip=FALSE, image.col=image.col, ngrid1=ngrid1, ngrid=ngrid2) plotmo(mod, pmethod="partdep", do.par=0, degree2=2, type2="im", ylim=ylim, clip=FALSE, image.col=image.col, ngrid1=ngrid1, ngrid=ngrid2, trace=-1) # check that the pacifier messages are suppressed plot(mod, i.var=1, n.trees=n.trees, ylim=ylim, continuous.resolution=ngrid1) plot(mod, i.var=2, n.trees=n.trees, ylim=ylim, continuous.resolution=ngrid1) plot(mod, i.var=3, n.trees=n.trees, ylim=ylim, continuous.resolution=ngrid1) # following ignores par(mfrow=c(2,2)) plot(mod, i.var=c(1,3), n.trees=n.trees, continuous.resolution=ngrid2, col.regions=image.col, colorkey=FALSE, main="gbm plot x1:x3\ncompare to plotmo partdep on previous page") par(org.par) #--- compare to gbm and randomForest with a simple regression function data(scor, package="bootstrap") # some correlated data n <- 50 x1 <- scale(scor$mec[1:n]) x2 <- scale(scor$vec[1:n]) data <- data.frame(x1=x1, x2=x2) ngrid1 <- 100 # randomForest, simple regression function library(randomForest) data$y <- x1 > -.1 # y depends only on x1 (-.1 hand-tuned to create interesting model surface) set.seed(2016) # Expect Warning: The response has five or fewer unique values. Are you sure you want to do regression? mod <- randomForest(y~., data=data, ntree=3) par(mfrow=c(4,2), mar=c(2.5,3,2,1), mgp=c(1.3,0.4,0), oma=c(0,0,7,0)) set.seed(2016) # for consistent jitter of response sites plotmo(mod, degree1=0, ngrid2=100, do.par=0, clip=FALSE, type2="image", main="regression surface", pt.col=ifelse(data$y, "green", "red")) title("RANDOM FOREST SIMPLE REGRESSION MODEL row1: regression surface row2: plotmo classic type=response row3: plotmo partdep type=response row4: randomForest plot\n\n\n\n\n\n\n", xpd=NA, adj=0) plotmo(mod, degree1=0, ngrid2=100, do.par=0, clip=FALSE, persp.border=NA, main="regression surface") plotmo(mod, pmethod="plotmo", do.par=0, degree2=0, ngrid1=ngrid1, type="response") plotmo(mod, pmethod="partdep", do.par=0, degree2=0, ngrid1=ngrid1, type="response") partialPlot(mod, pred.data=data, x.var="x1", n.pt=ngrid1, which.class="True") partialPlot(mod, pred.data=data, x.var="x2", n.pt=ngrid1, which.class="True") par(org.par) # gbm, simple regression function library(gbm) n.trees <- 20 data$y <- x1 > -.6 # y depends only on x1 (-.1 hand-tuned to create interesting model surface) set.seed(2016) mod <- gbm(y~., data=data, n.trees=n.trees, shrinkage=.1, interaction.depth=4, distribution="gaussian") par(mfrow=c(4,2), mar=c(2.5,3,2,1), mgp=c(1.3,0.4,0), oma=c(0,0,7,0)) set.seed(2016) # for consistent jitter of response sites plotmo(mod, degree1=0, ngrid2=100, do.par=0, clip=FALSE, type2="image", main="regression surface", pt.col=ifelse(data$y, "green", "red")) title("GBM SIMPLE REGRESSION MODEL row1: regression surface row2: plotmo classic type=response row3: plotmo partdep type=response row4: gbm plot\n\n\n\n\n\n\n", xpd=NA, adj=0) plotmo(mod, degree1=0, ngrid2=100, do.par=0, clip=FALSE, persp.border=NA, main="regression surface") plotmo(mod, pmethod="plotmo", do.par=0, all1=TRUE, degree2=0, ngrid1=ngrid1, type="response") plotmo(mod, pmethod="partdep", do.par=0, all1=TRUE, degree2=0, ngrid1=ngrid1, type="response") plot(mod, i.var=1, n.trees=n.trees, continuous.resolution=ngrid1) plot(mod, i.var=2, n.trees=n.trees, continuous.resolution=ngrid1) par(org.par) #--- compare to gbm and randomForest with simple binomial (two class) data data(scor, package="bootstrap") # some correlated data n <- 50 x1 <- scale(scor$mec[1:n]) x2 <- scale(scor$vec[1:n]) data <- data.frame(x1=x1, x2=x2) ngrid1 <- 100 # randomForest, simple binomial (two-class) data library(randomForest) # y depends only on x1 # random forest requires a factor for classification (not a logical) data$y <- factor(as.character(x1 > .4), levels=c("FALSE", "TRUE"), labels=c("False", "True")) set.seed(2016) mod <- randomForest(y~., data=data, ntree=3) par(mfrow=c(4,2), mar=c(2.5,3,2,1), mgp=c(1.3,0.4,0), oma=c(0,0,7,0)) set.seed(2016) # for consistent jitter of response sites plotmo(mod, degree1=0, ngrid2=100, do.par=0, clip=FALSE, type2="image", main="regression surface", pt.col=ifelse(data$y=="True", "green", "red")) title("RANDOM FOREST SIMPLE TWO-CLASS MODEL row1: regression surface row2: plotmo partdep type=response (FALSE or TRUE) row3: plotmo partdep type=prob row4: randomForest partialPlot (clipped log odds)\n\n\n\n\n\n\n", xpd=NA, adj=0) plotmo(mod, degree1=0, ngrid2=100, do.par=0, clip=FALSE, persp.border=NA, main="regression surface") plotmo(mod, pmethod="partdep", do.par=0, degree2=0, ngrid1=ngrid1, type="response") plotmo(mod, pmethod="partdep", do.par=0, degree2=0, ngrid1=ngrid1, type="prob", nresponse="True", ylim=c(0,1)) partialPlot(mod, pred.data=data, x.var="x1", n.pt=ngrid1, which.class="True", ylim=c(-16,16)) partialPlot(mod, pred.data=data, x.var="x2", n.pt=ngrid1, which.class="True", ylim=c(-16,16)) par(org.par) # gbm, simple binomial (two-class) data library(gbm) n.trees <- 10 data$y <- as.numeric(x1 > .6) # y depends only on x1 set.seed(2016) mod <- gbm(y~., data=data, n.trees=n.trees, shrinkage=.1, interact=4, distribution="bernoulli") par(mfrow=c(4,2), mar=c(2.5,3,2,1), mgp=c(1.3,0.4,0), oma=c(0,0,7,0)) set.seed(2016) # for consistent jitter of response sites plotmo(mod, degree1=0, ngrid2=100, do.par=0, clip=FALSE, type2="image", main="regression surface", pt.col=ifelse(data$y, "green", "red")) title("GBM SIMPLE TWO-CLASS MODEL row1: regression surface row2: plotmo partdep type=response (probability) row4: plotmo partdep type=link (log odds) row3: gbm plot (log odds)\n\n\n\n\n\n\n", xpd=NA, adj=0) plotmo(mod, degree1=0, ngrid2=100, do.par=0, clip=FALSE, persp.border=NA, main="regression surface") plotmo(mod, pmethod="partdep", do.par=0, all1=TRUE, degree2=0, ngrid1=ngrid1, type="response") plotmo(mod, pmethod="partdep", do.par=0, all1=TRUE, degree2=0, ngrid1=ngrid1, type="link") plot(mod, i.var=1, n.trees=n.trees, continuous.resolution=ngrid1) plot(mod, i.var=2, n.trees=n.trees, continuous.resolution=ngrid1) par(org.par) source("test.epilog.R") plotmo/inst/slowtests/test.plotmo3.Rout.save0000644000176200001440000012560114663412304021003 0ustar liggesusers> # test.plotmo3.R: extra tests for plotmo version 3 and higher > > source("test.prolog.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix > data(ozone1) > data(etitanic) > options(warn=1) # print warnings as they occur > > # check check.numeric.scalar > > xtest <- NA > expect.err(try(plotmo:::check.numeric.scalar(xtest)), "'xtest' is NA") Error : 'xtest' is NA Got expected error from try(plotmo:::check.numeric.scalar(xtest)) > xtest <- NULL > expect.err(try(plotmo:::check.numeric.scalar(xtest)), "'xtest' is NULL") Error : 'xtest' is NULL Got expected error from try(plotmo:::check.numeric.scalar(xtest)) > expect.err(try(plotmo:::check.numeric.scalar(NA)), "argument is NA") Error : argument is NA Got expected error from try(plotmo:::check.numeric.scalar(NA)) > expect.err(try(plotmo:::check.numeric.scalar(NULL)), "argument is NULL") Error : argument is NULL Got expected error from try(plotmo:::check.numeric.scalar(NULL)) > expect.err(try(plotmo:::check.numeric.scalar(try)), "'try' must be numeric (whereas its current class is \"function\")") Error : 'try' must be numeric (whereas its current class is "function") Got expected error from try(plotmo:::check.numeric.scalar(try)) > expect.err(try(plotmo:::check.numeric.scalar('try')), "\"try\" must be numeric (whereas its current class is \"character\")") Error : "try" must be numeric (whereas its current class is "character") Got expected error from try(plotmo:::check.numeric.scalar("try")) > expect.err(try(plotmo:::check.numeric.scalar(NULL)), "argument is NULL") Error : argument is NULL Got expected error from try(plotmo:::check.numeric.scalar(NULL)) > expect.err(try(plotmo:::check.numeric.scalar(1234, min=2, max=3)), "argument=1234 but it should be between 2 and 3") Error : argument=1234 but it should be between 2 and 3 Got expected error from try(plotmo:::check.numeric.scalar(1234, min = 2, max = 3)) > expect.err(try(plotmo:::check.numeric.scalar(0.1234, min=2, max=3)), "argument=0.1234 but it should be between 2 and 3") Error : argument=0.1234 but it should be between 2 and 3 Got expected error from try(plotmo:::check.numeric.scalar(0.1234, min = 2, max = 3)) > > expect.err(try(plotmo:::check.numeric.scalar(.1234, min=2, max=3)), "argument=0.1234 but it should be between 2 and 3") Error : argument=0.1234 but it should be between 2 and 3 Got expected error from try(plotmo:::check.numeric.scalar(0.1234, min = 2, max = 3)) > expect.err(try(plotmo:::check.numeric.scalar(+1234, min=2, max=3)), "argument=1234 but it should be between 2 and 3") Error : argument=1234 but it should be between 2 and 3 Got expected error from try(plotmo:::check.numeric.scalar(+1234, min = 2, max = 3)) > expect.err(try(plotmo:::check.numeric.scalar(-1234, min=2, max=3)), "argument=-1234 but it should be between 2 and 3") Error : argument=-1234 but it should be between 2 and 3 Got expected error from try(plotmo:::check.numeric.scalar(-1234, min = 2, max = 3)) > expect.err(try(plotmo:::check.numeric.scalar(+.1234, min=2, max=3)), "argument=0.1234 but it should be between 2 and 3") Error : argument=0.1234 but it should be between 2 and 3 Got expected error from try(plotmo:::check.numeric.scalar(+0.1234, min = 2, max = 3)) > expect.err(try(plotmo:::check.numeric.scalar(-.1234, min=2, max=3)), "argument=-0.1234 but it should be between 2 and 3") Error : argument=-0.1234 but it should be between 2 and 3 Got expected error from try(plotmo:::check.numeric.scalar(-0.1234, min = 2, max = 3)) > expect.err(try(plotmo:::check.numeric.scalar("", min=0, max=3)), "\"\" must be numeric (whereas its current class is \"character\"") Error : "" must be numeric (whereas its current class is "character") Got expected error from try(plotmo:::check.numeric.scalar("", min = 0, max = 3)) > > x.numeric.scalar <- 1234 > expect.err(try(plotmo:::check.numeric.scalar(x.numeric.scalar, min=0, max=3)), "x.numeric.scalar=1234 but it should be between 0 and 3") Error : x.numeric.scalar=1234 but it should be between 0 and 3 Got expected error from try(plotmo:::check.numeric.scalar(x.numeric.scalar, min = 0, max = 3)) > stopifnot(identical(plotmo:::check.numeric.scalar(x.numeric.scalar, min=2, max=1235), 1234)) > stopifnot(identical(plotmo:::check.numeric.scalar(1234, min=2, max=1235), 1234)) > > # check check.integer.scalar > > xtest <- NA > expect.err(try(plotmo:::check.integer.scalar(xtest)), "'xtest' is NA") Error : 'xtest' is NA Got expected error from try(plotmo:::check.integer.scalar(xtest)) > xtest <- NULL > expect.err(try(plotmo:::check.integer.scalar(xtest)), "'xtest' is NULL") Error : 'xtest' is NULL Got expected error from try(plotmo:::check.integer.scalar(xtest)) > expect.err(try(plotmo:::check.integer.scalar(NA)), "argument is NA") Error : argument is NA Got expected error from try(plotmo:::check.integer.scalar(NA)) > expect.err(try(plotmo:::check.integer.scalar(NA, null.ok=TRUE)), "argument is NA") Error : argument is NA Got expected error from try(plotmo:::check.integer.scalar(NA, null.ok = TRUE)) > expect.err(try(plotmo:::check.integer.scalar(NULL)), "argument is NULL") Error : argument is NULL Got expected error from try(plotmo:::check.integer.scalar(NULL)) > expect.err(try(plotmo:::check.integer.scalar(xtest, na.ok=TRUE)), "'xtest' is NULL") Error : 'xtest' is NULL Got expected error from try(plotmo:::check.integer.scalar(xtest, na.ok = TRUE)) > expect.err(try(plotmo:::check.integer.scalar("xyz", na.ok=TRUE)), "\"xyz\" is a string but it should be an integer, or NA, or TRUE or FALSE") Error : "xyz" is a string but it should be an integer, or NA, or TRUE or FALSE Got expected error from try(plotmo:::check.integer.scalar("xyz", na.ok = TRUE)) > expect.err(try(plotmo:::check.integer.scalar("TRUE", na.ok=TRUE)), "\"TRUE\" is a string but it should be an integer, or NA, or TRUE or FALSE") Error : "TRUE" is a string but it should be an integer, or NA, or TRUE or FALSE Got expected error from try(plotmo:::check.integer.scalar("TRUE", na.ok = TRUE)) > stopifnot(identical(plotmo:::check.integer.scalar(TRUE), TRUE)) > stopifnot(identical(plotmo:::check.integer.scalar(NA, na.ok=TRUE), NA)) > x.integer.scalar <- 1234L > expect.err(try(plotmo:::check.integer.scalar(x.integer.scalar, min=0, max=3)), "x.integer.scalar=1234 but it should be between 0 and 3") Error : x.integer.scalar=1234 but it should be between 0 and 3 Got expected error from try(plotmo:::check.integer.scalar(x.integer.scalar, min = 0, max = 3)) > stopifnot(identical(plotmo:::check.integer.scalar(x.integer.scalar, min=2, max=1235), 1234L)) > stopifnot(identical(plotmo:::check.integer.scalar(1234, min=2, max=1235), 1234)) > stopifnot(identical(plotmo:::check.integer.scalar(x.integer.scalar, min=2, max=1235), 1234L)) > stopifnot(identical(plotmo:::check.integer.scalar(1234, min=2, max=1235), 1234)) > xtest <- 1.234 > expect.err(try(plotmo:::check.integer.scalar(xtest, min=0, max=3)), "xtest=1.234 but it should be an integer, or TRUE or FALSE") Error : xtest=1.234 but it should be an integer, or TRUE or FALSE Got expected error from try(plotmo:::check.integer.scalar(xtest, min = 0, max = 3)) > > # check check.vec > xtest <- "x" > expect.err(try(plotmo:::check.vec(xtest, "xtest", na.ok=TRUE)), "'xtest' is not numeric") Error : 'xtest' is not numeric Got expected error from try(plotmo:::check.vec(xtest, "xtest", na.ok = TRUE)) > xtest <- as.double(NA) > print(plotmo:::check.vec(xtest, "xtest", na.ok=TRUE)) NULL > xtest <- as.double(1:3) > print(plotmo:::check.vec(xtest, "xtest", na.ok=TRUE)) NULL > xtest <- c(1,2,3,1/0,5,6,7) > expect.err(try(plotmo:::check.vec(xtest, "xtest", na.ok=TRUE)), "non-finite value in xtest") Error : non-finite value in xtest xtest[4] is Inf Got expected error from try(plotmo:::check.vec(xtest, "xtest", na.ok = TRUE)) > xtest <- c(1,2,3,NA,5,6,7) > expect.err(try(plotmo:::check.vec(xtest, "xtest")), "NA in xtest") Error : NA in xtest xtest[4] is NA Got expected error from try(plotmo:::check.vec(xtest, "xtest")) > xtest <- c(1,2,3) > expect.err(try(plotmo:::check.vec(xtest, "xtest", expected.len=2)), "'xtest' has the wrong length 3, expected 2") Error : 'xtest' has the wrong length 3, expected 2 Got expected error from try(plotmo:::check.vec(xtest, "xtest", expected.len = 2)) > print(plotmo:::check.vec(c(TRUE, FALSE), "c(TRUE, FALSE)")) NULL > > plotmo1 <- function(object, ..., trace=0, SHOWCALL=TRUE, caption=NULL) { + if(is.null(caption)) + caption <- paste(deparse(substitute(object)), collapse=" ") + call <- match.call(expand.dots=TRUE) + call <- strip.space(paste(deparse(substitute(call)), collapse=" ")) + printf("%s\n", call) + plotmo(object, trace=trace, SHOWCALL=SHOWCALL, caption=caption, ...) + } > plotres1 <- function(object, ..., trace=0, SHOWCALL=TRUE, caption=NULL) { + if(is.null(caption)) + caption <- paste(deparse(substitute(object)), collapse=" ") + call <- match.call(expand.dots=TRUE) + call <- strip.space(paste(deparse(substitute(call)), collapse=" ")) + printf("%s\n", call) + plotres(object, trace=trace, SHOWCALL=SHOWCALL, caption=caption, ...) + } > # basic tests of plotmo on abbreviated titanic data > > get.tita <- function() + { + tita <- etitanic + pclass <- as.character(tita$pclass) + # change the order of the factors so not alphabetical + pclass[pclass == "1st"] <- "first" + pclass[pclass == "2nd"] <- "class2" + pclass[pclass == "3rd"] <- "classthird" + tita$pclass <- factor(pclass, levels=c("class2", "classthird", "first")) + # log age is so we have a continuous predictor even when model is age~. + set.seed(2015) + tita$logage <- log(tita$age) + rnorm(nrow(tita)) + tita$parch <- NULL + # by=12 gives us a small fast model with an additive and a interaction term + tita[seq(1, nrow(etitanic), by=12), ] + } > tita <- get.tita() > > mod.lm.age <- lm(age~., data=tita) > plotmo1(mod.lm.age) plotmo1(object=mod.lm.age) plotmo grid: pclass survived sex sibsp logage classthird 0 male 0 3.06991 > plotmo1(mod.lm.age, level=.95) plotmo1(object=mod.lm.age,level=0.95) plotmo grid: pclass survived sex sibsp logage classthird 0 male 0 3.06991 > plotmo1(mod.lm.age, level=.95, col.resp=3) plotmo1(object=mod.lm.age,level=0.95,col.resp=3) plotmo grid: pclass survived sex sibsp logage classthird 0 male 0 3.06991 > > sexn <- as.numeric(tita$sex) > mod.lm.sexn <- lm(sexn~.-sex, data=tita) > plotmo1(mod.lm.sexn) plotmo1(object=mod.lm.sexn) plotmo grid: pclass survived sex age sibsp logage classthird 0 male 30 0 3.06991 > plotmo1(mod.lm.sexn, level=.95) plotmo1(object=mod.lm.sexn,level=0.95) plotmo grid: pclass survived sex age sibsp logage classthird 0 male 30 0 3.06991 > > set.seed(2020) > mod.earth.age <- earth(age~., data=tita, degree=2, nfold=3, ncross=3, varmod.method="lm") > plotmo1(mod.earth.age) plotmo1(object=mod.earth.age) plotmo grid: pclass survived sex sibsp logage classthird 0 male 0 3.06991 > plotmo1(mod.earth.age, level=.9, degree2=0) plotmo1(object=mod.earth.age,level=0.9,degree2=0) plotmo grid: pclass survived sex sibsp logage classthird 0 male 0 3.06991 > > # tita[,4] is age > set.seed(2020) > mod.earth.tita.age <- earth(tita[,-4], tita[,4], degree=2, nfold=3, ncross=3, trace=.5, varmod.method="lm") Model with pmethod="backward": GRSq 0.335 RSq 0.512 nterms 6 CV fold 1.1 CVRSq -0.047 n.oof 58 34% n.infold.nz 58 100% n.oof.nz 30 100% CV fold 1.2 CVRSq -0.022 n.oof 59 33% n.infold.nz 59 100% n.oof.nz 29 100% CV fold 1.3 CVRSq -0.045 n.oof 59 33% n.infold.nz 59 100% n.oof.nz 29 100% CV fold 2.1 CVRSq 0.133 n.oof 58 34% n.infold.nz 58 100% n.oof.nz 30 100% CV fold 2.2 CVRSq 0.338 n.oof 59 33% n.infold.nz 59 100% n.oof.nz 29 100% CV fold 2.3 CVRSq 0.149 n.oof 59 33% n.infold.nz 59 100% n.oof.nz 29 100% CV fold 3.1 CVRSq 0.419 n.oof 58 34% n.infold.nz 58 100% n.oof.nz 30 100% CV fold 3.2 CVRSq 0.107 n.oof 59 33% n.infold.nz 59 100% n.oof.nz 29 100% CV fold 3.3 CVRSq 0.307 n.oof 59 33% n.infold.nz 59 100% n.oof.nz 29 100% CV all CVRSq 0.149 n.infold.nz 88 100% varmod method="lm" rmethod="hc12" lambda=1 exponent=1 conv=1 clamp=0.1 minspan=-3: iter weight.ratio coefchange% (Intercept) tita[, 4] 1 1.4 0.0 13 -0.032 2 1.2 7.1 12 -0.018 3 1.3 3.0 13 -0.024 4 1.3 1.2 13 -0.022 5 1.3 0.5 13 -0.023 > cat("\nsummary(mod.earth.tita.age)\n") summary(mod.earth.tita.age) > print(summary(mod.earth.tita.age)) Call: earth(x=tita[,-4], y=tita[,4], trace=0.5, degree=2, nfold=3, ncross=3, varmod.method="lm") coefficients (Intercept) 25.664968 pclassfirst 9.028974 h(sibsp-1) -12.096706 h(1.68119-logage) -7.502937 sexmale * h(logage-2.48137) 5.062358 sibsp * h(logage-1.68119) 3.280947 Selected 6 of 14 terms, and 4 of 6 predictors Termination condition: Reached nk 21 Importance: logage, sexmale, pclassclassthird-unused, sibsp, pclassfirst, ... Number of terms at each degree of interaction: 1 3 2 GCV 174.7603 RSS 11022.31 GRSq 0.335155 RSq 0.5124778 CVRSq 0.1487371 Note: the cross-validation sd's below are standard deviations across folds Cross validation: nterms 3.89 sd 1.05 nvars 3.22 sd 0.97 CVRSq sd MaxErr sd 0.149 0.174 -39.1 32.3 varmod: method "lm" min.sd 1.49 iter.rsq 0.001 stddev of predictions: coefficients iter.stderr iter.stderr% (Intercept) 15.7287403 2.77398 18 tita[, 4] -0.0283536 0.0837154 295 mean smallest largest ratio 95% prediction interval 58.24711 55.23254 62.56685 1.13279 68% 80% 90% 95% response values in prediction interval 84 90 97 99 > plotmo1(mod.earth.tita.age) plotmo1(object=mod.earth.tita.age) plotmo grid: pclass survived sex sibsp logage classthird 0 male 0 3.06991 > plotmo1(mod.earth.tita.age, level=.9, degree2=0) plotmo1(object=mod.earth.tita.age,level=0.9,degree2=0) plotmo grid: pclass survived sex sibsp logage classthird 0 male 0 3.06991 > > set.seed(2020) > a.earth.sex <- earth(sex~., data=tita, degree=2, nfold=3, ncross=3, varmod.method="lm") > plotmo1(a.earth.sex) plotmo1(object=a.earth.sex) plotmo grid: pclass survived age sibsp logage classthird 0 30 0 3.06991 > plotmo1(a.earth.sex, level=.9) plotmo1(object=a.earth.sex,level=0.9) plotmo grid: pclass survived age sibsp logage classthird 0 30 0 3.06991 > plotmo1(a.earth.sex, type="class") plotmo1(object=a.earth.sex,type="class") plotmo grid: pclass survived age sibsp logage classthird 0 30 0 3.06991 > expect.err(try(plotmo1(a.earth.sex, level=.9, degree2=0, type="class")), "predicted values are strings") plotmo1(object=a.earth.sex,level=0.9,degree2=0,type="class") Error : the level argument is not allowed when the predicted values are strings Got expected error from try(plotmo1(a.earth.sex, level = 0.9, degree2 = 0, type = "class")) > > # tita[,3] is sex > set.seed(2020) > mod.earth.tita <- earth(tita[,-3], tita[,3], degree=2, nfold=3, ncross=3, varmod.method="lm") > plotmo1(mod.earth.tita) plotmo1(object=mod.earth.tita) plotmo grid: pclass survived age sibsp logage classthird 0 30 0 3.06991 > plotmo1(mod.earth.tita, level=.9, degree2=0) plotmo1(object=mod.earth.tita,level=0.9,degree2=0) plotmo grid: pclass survived age sibsp logage classthird 0 30 0 3.06991 > plotmo1(mod.earth.tita, type="class") plotmo1(object=mod.earth.tita,type="class") plotmo grid: pclass survived age sibsp logage classthird 0 30 0 3.06991 > expect.err(try(plotmo1(mod.earth.tita, level=.9, degree2=0, type="class")), "predicted values are strings") plotmo1(object=mod.earth.tita,level=0.9,degree2=0,type="class") Error : the level argument is not allowed when the predicted values are strings Got expected error from try(plotmo1(mod.earth.tita, level = 0.9, degree2 = 0, type = "class")) > > set.seed(2020) > mod.earth.sex <- earth(sex~., data=tita, degree=2, nfold=3, ncross=3, varmod.method="earth", glm=list(family=binomial)) Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred > plotmo1(mod.earth.sex) plotmo1(object=mod.earth.sex) plotmo grid: pclass survived age sibsp logage classthird 0 30 0 3.06991 > plotmo1(mod.earth.sex, type="link") plotmo1(object=mod.earth.sex,type="link") plotmo grid: pclass survived age sibsp logage classthird 0 30 0 3.06991 > plotmo1(mod.earth.sex, type="class") plotmo1(object=mod.earth.sex,type="class") plotmo grid: pclass survived age sibsp logage classthird 0 30 0 3.06991 > plotmo1(mod.earth.sex, level=.9, type="earth") plotmo1(object=mod.earth.sex,level=0.9,type="earth") plotmo grid: pclass survived age sibsp logage classthird 0 30 0 3.06991 > > # tita[,3] is sex > set.seed(2020) > mod.earth.tita <- earth(tita[,-3], tita[,3], degree=2, nfold=3, ncross=3, varmod.method="earth", glm=list(family=binomial)) Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred > plotmo1(mod.earth.tita) plotmo1(object=mod.earth.tita) plotmo grid: pclass survived age sibsp logage classthird 0 30 0 3.06991 > plotmo1(mod.earth.tita, type="link") plotmo1(object=mod.earth.tita,type="link") plotmo grid: pclass survived age sibsp logage classthird 0 30 0 3.06991 > plotmo1(mod.earth.tita, type="class") plotmo1(object=mod.earth.tita,type="class") plotmo grid: pclass survived age sibsp logage classthird 0 30 0 3.06991 > plotmo1(mod.earth.tita, level=.9, type="earth") plotmo1(object=mod.earth.tita,level=0.9,type="earth") plotmo grid: pclass survived age sibsp logage classthird 0 30 0 3.06991 > > # check factor handling when factors are not ordered alphabetically > tita.orgpclass <- etitanic[seq(1, nrow(etitanic), by=12), ] > tita <- get.tita() > tita$logage <- NULL > tita.orgpclass$parch <- NULL > stopifnot(names(tita.orgpclass) == names(tita)) > a.tita.orgpclass <- earth(pclass~., degree=2, data=tita.orgpclass) > a.tita <- earth(pclass~., degree=2, data=tita) > options(warn=2) # treat warnings as errors > expect.err(try(plotmo(a.tita)), "Defaulting to nresponse=1, see above messages") predict.earth[88,3]: class2 classthird first 1 0.3179514 0.3141272 0.36792134 2 0.3179514 0.3141272 0.36792134 3 0.2400614 0.6754849 0.08445368 ... 0.2180022 0.5645160 0.21748179 88 0.2400614 0.6754849 0.08445368 predict.earth returned multiple columns (see above) but nresponse is not specified Use the nresponse argument to specify a column. Example: nresponse=2 Example: nresponse="classthird" Error : (converted from warning) Defaulting to nresponse=1, see above messages Got expected error from try(plotmo(a.tita)) > options(warn=1) > # following two graphs should be identical > plotmo1(a.tita.orgpclass, nresponse="1st", all1=T, col.resp=3, type2="im") plotmo1(object=a.tita.orgpclass,nresponse="1st",all1=T,col.resp=3,type2="im") plotmo grid: survived sex age sibsp 0 male 30 0 > plotmo1(a.tita, nresponse="first", all1=T, col.resp=3, type2="im") plotmo1(object=a.tita,nresponse="first",all1=T,col.resp=3,type2="im") plotmo grid: survived sex age sibsp 0 male 30 0 > # following two graphs should be identical > plotmo1(a.tita.orgpclass, nresponse="2nd", all1=T) plotmo1(object=a.tita.orgpclass,nresponse="2nd",all1=T) plotmo grid: survived sex age sibsp 0 male 30 0 > plotmo1(a.tita, nresponse="class2", all1=T) plotmo1(object=a.tita,nresponse="class2",all1=T) plotmo grid: survived sex age sibsp 0 male 30 0 > > tita <- get.tita() > mod.earth.pclass <- earth(pclass~., data=tita, degree=2) > options(warn=2) # treat warnings as errors > expect.err(try(plotmo1(mod.earth.pclass)), "Defaulting to nresponse=1, see above messages") plotmo1(object=mod.earth.pclass) predict.earth[88,3]: class2 classthird first 1 0.3197580 0.2991394 0.3811026 2 0.3197580 0.2991394 0.3811026 3 0.2490258 0.6472095 0.1037648 ... 0.1984114 0.5220475 0.2795411 88 0.2490258 0.6472095 0.1037648 predict.earth returned multiple columns (see above) but nresponse is not specified Use the nresponse argument to specify a column. Example: nresponse=2 Example: nresponse="classthird" Error : (converted from warning) Defaulting to nresponse=1, see above messages Got expected error from try(plotmo1(mod.earth.pclass)) > options(warn=1) > plotmo1(mod.earth.pclass, nresponse="fi") plotmo1(object=mod.earth.pclass,nresponse="fi") plotmo grid: survived sex age sibsp logage 0 male 30 0 3.06991 > plotmo1(mod.earth.pclass, nresponse="first") plotmo1(object=mod.earth.pclass,nresponse="first") plotmo grid: survived sex age sibsp logage 0 male 30 0 3.06991 > plotmo1(mod.earth.pclass, nresponse=3) plotmo1(object=mod.earth.pclass,nresponse=3) plotmo grid: survived sex age sibsp logage 0 male 30 0 3.06991 > plotmo1(mod.earth.pclass, type="class") plotmo1(object=mod.earth.pclass,type="class") plotmo grid: survived sex age sibsp logage 0 male 30 0 3.06991 > plotmo1(mod.earth.pclass, nresponse=1, + type="class", grid.levels=list(sex="fem"), + smooth.col="indianred", smooth.lwd=2, + pt.col=as.numeric(tita$pclass)+1, + pt.pch=1) plotmo1(object=mod.earth.pclass,nresponse=1,type="class",grid.levels=list(sex="fem"),smooth.col="indianred",smooth.lwd=2,pt.col=as.numeric(tita$pclass)+1,pt.pch=1) plotmo grid: survived sex age sibsp logage 0 female 30 0 3.06991 > > # tita[,1] is pclass > mod.earth.tita <- earth(tita[,-1], tita[,1], degree=2) > options(warn=2) # treat warnings as errors > expect.err(try(plotmo1(mod.earth.tita)), "Defaulting to nresponse=1, see above messages") plotmo1(object=mod.earth.tita) predict.earth[88,3]: class2 classthird first 1 0.3197580 0.2991394 0.3811026 2 0.3197580 0.2991394 0.3811026 3 0.2490258 0.6472095 0.1037648 ... 0.1984114 0.5220475 0.2795411 88 0.2490258 0.6472095 0.1037648 predict.earth returned multiple columns (see above) but nresponse is not specified Use the nresponse argument to specify a column. Example: nresponse=2 Example: nresponse="classthird" Error : (converted from warning) Defaulting to nresponse=1, see above messages Got expected error from try(plotmo1(mod.earth.tita)) > options(warn=1) > plotmo1(mod.earth.tita, nresponse="first") plotmo1(object=mod.earth.tita,nresponse="first") plotmo grid: survived sex age sibsp logage 0 male 30 0 3.06991 > plotmo1(mod.earth.tita, type="class") plotmo1(object=mod.earth.tita,type="class") plotmo grid: survived sex age sibsp logage 0 male 30 0 3.06991 > > mod.earth.pclass2 <- earth(pclass~., data=tita, degree=2, glm=list(family=binomial)) > # expect.err(try(plotmo1(mod.earth.pclass2)), "nresponse is not specified") > plotmo1(mod.earth.pclass2, nresponse=3) plotmo1(object=mod.earth.pclass2,nresponse=3) plotmo grid: survived sex age sibsp logage 0 male 30 0 3.06991 > plotmo1(mod.earth.pclass2, type="link", nresponse=3) plotmo1(object=mod.earth.pclass2,type="link",nresponse=3) plotmo grid: survived sex age sibsp logage 0 male 30 0 3.06991 > plotmo1(mod.earth.pclass2, type="class") plotmo1(object=mod.earth.pclass2,type="class") plotmo grid: survived sex age sibsp logage 0 male 30 0 3.06991 > > # tita[,1] is pclass > mod.earth.tita <- earth(tita[,-1], tita[,1], degree=2, glm=list(family=binomial)) > plotmo1(mod.earth.tita, nresponse=3) plotmo1(object=mod.earth.tita,nresponse=3) plotmo grid: survived sex age sibsp logage 0 male 30 0 3.06991 > plotmo1(mod.earth.tita, type="link", nresponse=3) plotmo1(object=mod.earth.tita,type="link",nresponse=3) plotmo grid: survived sex age sibsp logage 0 male 30 0 3.06991 > plotmo1(mod.earth.tita, type="class") plotmo1(object=mod.earth.tita,type="class") plotmo grid: survived sex age sibsp logage 0 male 30 0 3.06991 > > # plotmo vignette examples > > # use a small set of variables for illustration > printf("library(earth)\n") library(earth) > library(earth) # for ozone1 data > data(ozone1) > oz <- ozone1[, c("O3", "humidity", "temp", "ibt")] > > lm.model.vignette <- lm(O3 ~ humidity + temp*ibt, data=oz) # linear model > plotmo1(lm.model.vignette, pt.col="gray", nrug=-1) plotmo1(object=lm.model.vignette,pt.col="gray",nrug=-1) plotmo grid: humidity temp ibt 64 62 167.5 > plotmo1(lm.model.vignette, level=.9) plotmo1(object=lm.model.vignette,level=0.9) plotmo grid: humidity temp ibt 64 62 167.5 > > printf("library(mda)\n") library(mda) > library(mda) Loading required package: class Loaded mda 0.5-4 > mars.model.vignette1 <- mars(oz[,-1], oz[,1], degree=2) > plotmo1(mars.model.vignette1) plotmo1(object=mars.model.vignette1) plotmo grid: humidity temp ibt 64 62 167.5 > plotres1(mars.model.vignette1) plotres1(object=mars.model.vignette1) > mars.model.vignette2 <- mars(oz[,-1,drop=FALSE], oz[,1,drop=FALSE], degree=2) > plotmo1(mars.model.vignette2) plotmo1(object=mars.model.vignette2) plotmo grid: humidity temp ibt 64 62 167.5 > # TODO causes Error in lm.fit(object$x, y, singular.ok = FALSE) : (list) object cannot be coerced to type 'double' > # although still works > # the error is mars.to.earth try(hatvalues.lm.fit(lm.fit(object$x, y, singular.ok=FALSE))) > plotres1(mars.model.vignette2, trace=1) plotres1(object=mars.model.vignette2,trace=1) stats::residuals(object=mars.object, type="response") stats::fitted(object=mars.object) got model response from getCall(object)$y calling mars.to.earth (needed for the model selection plot) training rsq 0.76 > > printf("library(rpart)\n") library(rpart) > library(rpart) # rpart > rpart.model.vignette <- rpart(O3 ~ ., data=oz) > plotmo1(rpart.model.vignette, all2=TRUE) plotmo1(object=rpart.model.vignette,all2=TRUE) plotmo grid: humidity temp ibt 64 62 167.5 > expect.err(try(plotmo1(rpart.model.vignette, level=.9)), "the level argument is not supported for \"rpart\" objects") plotmo1(object=rpart.model.vignette,level=0.9) Error : the level argument is not supported for "rpart" objects Got expected error from try(plotmo1(rpart.model.vignette, level = 0.9)) > > # commented out because is slow and already tested in test.non.earth.R > # printf("library(randomForest)\n") > # library(randomForest) # randomForest > # rf.model.vignette <- randomForest(O3~., data=oz) > # plotmo1(rf.model.vignette) > # partialPlot(rf.model.vignette, oz, temp) # compare to partial-dependence plot > > printf("library(gbm)\n") library(gbm) > library(gbm) # gbm Loaded gbm 2.2.2 This version of gbm is no longer under development. Consider transitioning to gbm3, https://github.com/gbm-developers/gbm3 > set.seed(2016) > gbm.model.vignette <- gbm(O3~., data=oz, dist="gaussian", inter=2, n.trees=100) > # commented out following because they always take the whole page > # plot(gbm.model.vignette, i.var=2) # compare to partial-dependence plots > # plot(gbm.model.vignette, i.var=c(2,3)) > set.seed(2016) > plotmo1(gbm.model.vignette, caption="gbm.model.vignette") plotmo1(object=gbm.model.vignette,caption="gbm.model.vignette") plotmo grid: humidity temp ibt 64 62 167.5 > > # commented out because is slow and already tested elsewhere > # printf("library(mgcv)\n") > # library(mgcv) # gam > # gam.model.vignette <- gam(O3 ~ s(humidity)+s(temp)+s(ibt)+s(temp,ibt), data=oz) > # plotmo1(gam.model.vignette, level=.95, all2=TRUE) > > printf("library(nnet)\n") library(nnet) > library(nnet) # nnet > set.seed(4) > nnet.model.vignette <- nnet(O3~., data=scale(oz), size=2, decay=0.01, trace=FALSE) > plotmo1(nnet.model.vignette, type="raw", all2=T) plotmo1(object=nnet.model.vignette,type="raw",all2=T) plotmo grid: humidity temp ibt 0.2954793 0.01697621 0.08267399 > > printf("library(MASS)\n") library(MASS) > library(MASS) # qda > lcush <- data.frame(Type=as.numeric(Cushings$Type),log(Cushings[,1:2])) > lcush <- lcush[1:21,] > qda.model.vignette <- qda(Type~., data=lcush) > plotmo1(qda.model.vignette, type="class", all2=TRUE, + type2="contour", ngrid2=100, contour.nlevels=2, contour.drawlabels=FALSE, + pt.col=as.numeric(lcush$Type)+1, + pt.pch=as.character(lcush$Type)) plotmo1(object=qda.model.vignette,type="class",all2=TRUE,type2="contour",ngrid2=100,contour.nlevels=2,contour.drawlabels=FALSE,pt.col=as.numeric(lcush$Type)+1,pt.pch=as.character(lcush$Type)) plotmo grid: Tetrahydrocortisone Pregnanetriol 2.04122 0.1823216 > > # miscellaneous other examples > > tita <- get.tita() > > mod.glm.sex <- glm(sex~., data=tita, family=binomial) > plotmo1(mod.glm.sex, pt.col=as.numeric(tita$pclass)+1) plotmo1(object=mod.glm.sex,pt.col=as.numeric(tita$pclass)+1) plotmo grid: pclass survived age sibsp logage classthird 0 30 0 3.06991 > > # tita[,4] is age, tita[,1] is pclass > printf("library(lars)\n") library(lars) > library(lars) Loaded lars 1.3 > set.seed(2015) > xmat <- as.matrix(tita[,c(2,5,6)]) > mod.lars.xmat <- lars(xmat, tita[,4]) > par(mfrow=c(2,2)) > plot(mod.lars.xmat) > plotmo1(mod.lars.xmat, nresponse=4, do.par=F) plotmo1(object=mod.lars.xmat,nresponse=4,do.par=F) plotmo grid: survived sibsp logage 0 0 3.06991 > plotres(mod.lars.xmat, trace=0, nresponse=4) > > if(0) { # TODO fails with R-3.4.2: object '.QP_qpgen2' not found + printf("library(cosso)\n") + library(cosso) + set.seed(2016) + cosso <- cosso(xmat,tita[,4],family="Gaussian") + # TODO tell maintainer of cosso that you have to do this + class(cosso) <- "cosso" + set.seed(2016) + plotmo1(cosso) + set.seed(2016) + plotres(cosso) + } > # examples from James, Witten, et al. ISLR book > # I tested all models in their scripts manually. > # All worked except for exceptions below. > > printf("library(pls)\n") library(pls) > library(pls) Attaching package: 'pls' The following object is masked from 'package:stats': loadings > printf("library(ISLR)\n") library(ISLR) > library(ISLR) > Hitters=na.omit(Hitters) > > set.seed(1) > x <- model.matrix(Salary~.,Hitters)[,-1] > y <- Hitters$Salary > train=sample(1:nrow(x), nrow(x)/2) > pcr.fit1=pcr(Salary~., data=Hitters,subset=train,scale=TRUE, validation="CV") > plotmo1(pcr.fit1, nresponse=10) plotmo1(object=pcr.fit1,nresponse=10) plotmo grid: AtBat Hits HmRun Runs RBI Walks Years CAtBat CHits CHmRun 394 102 8 50 44 36 6 1931 510 36 CRuns CRBI CWalks League Division PutOuts Assists Errors NewLeague 246 219 172 A W 211 56 7 A > > # set.seed(1) > # x <- model.matrix(Salary~.,Hitters)[,-1] > # y <- Hitters$Salary > # train=sample(1:nrow(x), nrow(x)/2) > # pcr.fit2=pcr(y~x,scale=TRUE,ncomp=7) > # # TODO following gives Error: predictions returned the wrong length (got 263 but expected 50) > # plotmo1(pcr.fit2, nresponse=5) > > library(splines) > fit.lm2=lm(wage~bs(age,knots=c(25,40,60)),data=Wage) > par(mfrow=c(1,2),mar=c(4.5,4.5,1,1),oma=c(0,0,4,0)) > agelims=range(Wage$age) > age.grid=seq(from=agelims[1],to=agelims[2]) > pred=predict(fit.lm2,newdata=list(age=age.grid),se=T) > plot(Wage$age,Wage$wage,col="gray", ylim=c(0,320)) > lines(age.grid,pred$fit,lwd=2) > lines(age.grid,pred$fit+2*pred$se,lty="dashed") > lines(age.grid,pred$fit-2*pred$se,lty="dashed") > fit.lm2=lm(wage~bs(age,knots=c(25,40,60)),data=Wage,model=F) # TODO delete > plotmo1(fit.lm2, col.resp=2, do.par=F, level=.95, ylim=c(0,320), + nrug=TRUE, caption="fit.lm2", ylab="wage") plotmo1(object=fit.lm2,col.resp=2,do.par=F,level=0.95,ylim=c(0,320),nrug=TRUE,ylab="wage",caption="fit.lm2") > > fit.glm2 <- glm(I(wage>250)~poly(age,4),data=Wage,family=binomial) > par(mfrow=c(1,2),mar=c(4.5,4.5,1,1),oma=c(0,0,4,0)) > agelims=range(Wage$age) > age.grid=seq(from=agelims[1],to=agelims[2]) > # their plot > preds=predict(fit.glm2,newdata=list(age=age.grid),se=T) > pfit=exp(preds$fit)/(1+exp(preds$fit)) > se.bands.logit = cbind(preds$fit+2*preds$se.fit, preds$fit-2*preds$se.fit) > se.bands = exp(se.bands.logit)/(1+exp(se.bands.logit)) > preds=predict(fit.glm2,newdata=list(age=age.grid),type="response",se=T) > plot(Wage$age,I(Wage$wage>250),xlim=agelims,type="n",ylim=c(0,.2)) > points(jitter(Wage$age), I((Wage$wage>250)/5),cex=.5,pch="|",col="darkgrey") > lines(age.grid,pfit,lwd=2, col="blue") > matlines(age.grid,se.bands,lwd=1,col="blue",lty=3) > # plotmo plot, side by side > # TODO Warning: the level argument may not be properly supported on glm objects built with weights > plotmo1(fit.glm2, level=.95, degree1.col="blue", ylim=c(0,.2), do.par=FALSE, nrug=-1, caption="fit.glm2", ylab="I(wage > 250)") plotmo1(object=fit.glm2,level=0.95,degree1.col="blue",ylim=c(0,0.2),do.par=FALSE,nrug=-1,ylab="I(wage>250)",caption="fit.glm2") Warning: the level argument may not work correctly on glm objects built with weights > > # Test deparsing of the formula in plotmo.pairs.default > # TODO Height is included in the plots even though formula says -Height > Height2 <- trees$Height^2 > a <- lm(Volume~(Girth*Height2)-Height, data=trees, x=TRUE, model=FALSE) > plotmo(a) plotmo grid: Girth Height2 Height 12.9 5776 76 > > # test "the variable on the right side of the formula is a matrix or data.frame" > # TODO would like to solve this problem > > options(warn=2) > data(gasoline, package="pls") > earth.octane <- earth(octane ~ NIR, data=gasoline) > print(summary(earth.octane)) # ok Call: earth(formula=octane~NIR, data=gasoline) coefficients (Intercept) 87.818970 h(NIR1016 nm- -0.050322) -307.631441 h(NIR1036 nm- -0.060936) 83.025904 h(NIR1054 nm- -0.059068) 254.542458 h(NIR1134 nm-0.028475) 34.069219 h(0.484052-NIR1194 nm) -45.522897 h(NIR1194 nm-0.484052) 50.623858 h(0.25499-NIR1208 nm) 81.506833 h(NIR1208 nm-0.25499) -92.719551 h(NIR1686 nm-1.25012) -7.936903 h(1.27324-NIR1690 nm) 3.531658 Selected 11 of 12 terms, and 8 of 401 predictors Termination condition: RSq changed by less than 0.001 at 12 terms Importance: NIR1208 nm, NIR1194 nm, NIR1134 nm, NIR1690 nm, NIR1016 nm, ... Number of terms at each degree of interaction: 1 10 (additive model) GCV 0.05120795 RSS 1.298122 GRSq 0.9784914 RSq 0.990602 > plotres(earth.octane) # ok > expect.err(try(plotmo(earth.octane)), "the variable on the right side of the formula is a matrix or data.frame") Error : (converted from warning) the variable on the right side of the formula is a matrix or data.frame plotmo often cannot process such variables Got expected error from try(plotmo(earth.octane)) > options(warn=1) > > # TODO May 2020 'ElemStatLearn' is not available (for R version 4.0.0) > # library(ElemStatLearn) > # x <- mixture.example$x > # g <- mixture.example$y > # lm.mixture.example <- lm(g ~ x) > # options(warn=2) > # expect.err(try(plotmo(lm.mixture.example)), "the variable on the right side of the formula is a matrix or data.frame") > # options(warn=1) > > # test variable names with $ are not supported > > a <- earth(O3~ozone1$doy, data=ozone1) > expect.err(try(plotmo(a)), "cannot get the original model predictors") Warning: "$" in the formula is not supported by plotmo, will try to get the data elsewhere formula: ozone1$doy Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: formula(object): "$" in formula is not allowed (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(plotmo(a)) > > a <- earth(O3~ozone1$doy + temp, data=ozone1) > expect.err(try(plotmo(a)), "cannot get the original model predictors") Warning: "$" in the formula is not supported by plotmo, will try to get the data elsewhere formula: ozone1$doy + temp Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: formula(object): "$" in formula is not allowed (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(plotmo(a)) > > a <- lm(O3~ozone1$doy, data=ozone1) > expect.err(try(plotmo(a)), "cannot get the original model predictors") Warning: "$" in the formula is not supported by plotmo, will try to get the data elsewhere formula: ozone1$doy Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: formula(object): "$" in formula is not allowed (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(plotmo(a)) > > a <- lm(O3~ozone1$doy + temp, data=ozone1) > expect.err(try(plotmo(a)), "cannot get the original model predictors") Warning: "$" in the formula is not supported by plotmo, will try to get the data elsewhere formula: ozone1$doy + temp Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: formula(object): "$" in formula is not allowed (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(plotmo(a)) > > #--- test interaction of w1. and non w1 args ------------------------------------- > > par(mfrow=c(4,3), mar=c(3, 3, 4, 1), mgp=c(2, 0.6, 0)) > > mod78 <- earth(Volume ~ ., data = trees) > par(mfrow=c(3,4), mar=c(3, 3, 3, 1), mgp=c(2, 0.6, 0)) > > # multiple which, earth model > plotres(mod78, cex.main=1, + ylim=c(-.5, .8), xlim=c(-2, 7), col=2:3, do.par=FALSE, + w1.main=c("ylim=c(-.5, .8)\nxlim=c(-2, 7) col=2:3")) > > # multiple which, earth model > plotres(mod78, cex.main=.7, + w1.ylim=c(-.5, .8), w1.xlim=c(-2, 7), col=2:3, do.par=FALSE, + ylim=c(-10,10), xlim=c(-30, 100), + w1.main=c("w1.ylim=c(-.5, .8) w1.xlim=c(-2, 7)\nylim=c(-10,10), xlim=c(-30, 100)")) > par(org.par) > > par(mfrow=c(3,4), mar=c(3, 3, 3, 1), mgp=c(2, 0.6, 0)) > > # which=1, earth model > > plotres(mod78, which=1, cex.main=.8, + col=2:3, + main="which=1, no other ylim args", + w1.main="which=1, no other ylim args") > > plotres(mod78, which=1, cex.main=.8, + col=2:3, w1.ylim=c(.3,.98), w1.xlim=c(-2, 7), + main="w1.ylim=c(.3,.98)\nw1.xlim=c(-2, 7)") > > plotres(mod78, which=1, cex.main=.8, + col=2:3, ylim=c(.3,.98), xlim=c(-2, 7), + main="ylim=c(.3,.98)\nxlim=c(-2, 7)") # ylim gets passed to modsel > > plotres(mod78, which=1, cex.main=.75, + col=2:3, w1.ylim=c(.3,.98), ylim=c(-.5,.5), + w1.xlim=c(-2, 7), xlim=c(-90, 90), + main="w1.ylim=c(.3,.98), ylim=c(-.5,.5)\nw1.xlim=c(-2, 7), xlim=c(-90, 90)") # ignore ylim > > # which=3, earth model > plotres(mod78, which=3, cex.main=1, + col=2:3, + main="which=3, no other ylim args") > > plotres(mod78, which=3, cex.main=1, + col=2:3, w1.ylim=c(.3,.98), w1.xlim=c(-2, 7), + main="w1.ylim=c(.3,.98)\nw1.xlim=c(-2, 7)") # not usual, ignore w1.ylim > > plotres(mod78, which=3, cex.main=1, + col=2:3, ylim=c(-10,10), xlim=c(-90,90), + main="which=3, ylim=c(-10,10)\nxlim=c(-90,90)") > > plotres(mod78, which=3, cex.main=1, + col=2:3, w1.ylim=c(.3,.98), ylim=c(-10,10), w1.xlim=c(-2, 7), xlim=c(-90,90), + main="w1.ylim=c(.3,.98) ylim=c(-10,10)\nw1.xlim=c(-2, 7), xlim=c(-90,90)") > > par(org.par) > > nullarg <- NULL > expect.err(try(plotmo(nullarg)), "argument 'nullarg' is NULL") Error : argument 'nullarg' is NULL Got expected error from try(plotmo(nullarg)) > expect.err(try(plotmo(NULL)), "argument 'NULL' is NULL") Error : argument 'NULL' is NULL Got expected error from try(plotmo(NULL)) > expect.err(try(plotmo(0)), "'0' is not an S3 model") Error : '0' is not an S3 model Got expected error from try(plotmo(0)) > expect.err(try(plotmo(list(1,2))), "'list(1, 2)' is a plain list, not an S3 model") Error : 'list(1, 2)' is a plain list, not an S3 model Got expected error from try(plotmo(list(1, 2))) > expect.err(try(plotmo(list(1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0))), + "object is a plain list, not an S3 model") Error : object is a plain list, not an S3 model Got expected error from try(plotmo(list(1, 2, 3, 4, 5, 6, 7, 8, 0, 1, 2, 3, 4, 5, 6, 7, 8, 0, 1, 2, 3, 4, 5, 6, 7, 8, 0, 1, 2, 3, 4, 5, 6, 7, 8, 0, 1, 2, 3, 4, 5, 6, 7, 8, 0, 1, 2, 3, 4, 5, 6, 7, 8, 0, 1, 2, 3, 4, 5, 6, 7, 8, 0, 1, 2, 3, 4, 5, 6, 7, 8, 0, 1, 2, 3, 4, 5, 6, 7, 8, 0, 1, 2, 3, 4, 5, 6, 7, 8, 0, 1, 2, 3, 4, 5, 6, 7, 8, 0, 1, 2, 3, 4, 5, 6, 7, 8, 0, 1, 2, 3, 4, 5, 6, 7, 8, 0, 1, 2, 3, 4, 5, 6, 7, 8, 0, 1, 2, 3, 4, 5, 6, 7, 8, 0, 1, 2, 3, 4, 5, 6, 7, 8, 0, 1, 2, 3, 4, 5, 6, 7, 8, 0))) > > source("test.epilog.R") plotmo/inst/slowtests/test.center.Rout.save0000644000176200001440000001277714563614021020676 0ustar liggesusers> # test.center.R: test plotmo's center and ndiscrete args > # Stephen Milborrow, Berea Apr 2011 > > source("test.prolog.R") > library(rpart.plot) Loading required package: rpart > library(plotmo) Loading required package: Formula Loading required package: plotrix > library(earth) > data(etitanic) > > et <- etitanic[, c("survived", "pclass", "sex", "age")] > et$pclassn <- as.numeric(et$pclass) > et <- et[c(30:80,330:380,630:680), ] > > par(mfrow=c(3,3)) > par(mar=c(3, 3.5, 3, 0.5)) > par(mgp=c(1.5, .5, 0)) > > ndiscrete <- 0 > > #--- row 1 > > set.seed(844) > a1 <- lm(survived~pclassn+sex, data=et) > plotmo(a1, all2=T, do.par=F, degree1=NA, degree2=1, center=TRUE, clip=F, + main="a1: survived~pclassn+sex\n(default ndiscrete)", + pt.col=ifelse(et$survived, "black", "red"), + pt.pch=".", pt.cex=2.5, lab=c(1,1,1)) > > set.seed(844) > plotmo(a1, degree1=1, all2=T, degree2=0, do.par=F, xflip=T, center=TRUE, clip=F, + grid.levels=list(sex="f"), ndiscrete=ndiscrete, + main="pclassn with sex=\"female\"", + smooth.col="lightblue", smooth.lwd=2, + pt.col=ifelse(et$survived, "black", "red"), + pt.pch=".", pt.cex=2.5) plotmo grid: pclassn sex 2 female > > set.seed(844) > plotmo(a1, degree1=1, all2=T, degree2=0, do.par=F, xflip=T, center=TRUE, clip=F, + grid.levels=list(sex="m"), ndiscrete=ndiscrete, + main="pclassn with sex=\"male\"", + smooth.col="lightblue", smooth.lwd=2, + pt.col=ifelse(et$survived, "black", "red"), + pt.pch=".", pt.cex=2.5) plotmo grid: pclassn sex 2 male > > #--- row 2 > > a2 <- lm(survived~pclassn*sex, data=et) > set.seed(844) > plotmo(a2, all2=T, do.par=F, degree2=1, degree1=0, center=TRUE, clip=F, + main="a2: survived~pclassn*sex\n(default ndiscrete)") > > set.seed(844) > plotmo(a2, degree1=1, all2=T, degree2=0, do.par=F, xflip=T, center=TRUE, clip=F, + grid.levels=list(sex="f"), ndiscrete=ndiscrete, + main="pclassn with sex=\"female\"", + smooth.col="lightblue", smooth.lwd=2, + pt.col=ifelse(et$survived, "black", "red"), + pt.pch=".", pt.cex=2.5) plotmo grid: pclassn sex 2 female > > set.seed(844) > plotmo(a2, degree1=1, all2=T, degree2=0, do.par=F, xflip=T, center=TRUE, clip=F, + grid.levels=list(sex="m"), ndiscrete=ndiscrete, + main="pclassn with sex=\"male\"", + smooth.col="lightblue", smooth.lwd=2, + pt.col=ifelse(et$survived, "black", "red"), + pt.pch=".", pt.cex=2.5) plotmo grid: pclassn sex 2 male > > #--- row 3 > > par(mfg=c(3,2)) > a3 <- lm(survived~pclassn, data=et) > set.seed(844) > plotmo(a3, do.par=F, xflip=T, center=TRUE, clip=F, ndiscrete=ndiscrete, + main="a3: survived~pclassn", degree1.col=1, + smooth.col="lightblue", smooth.lwd=2, + pt.col=ifelse(et$survived, "black", "red"), + pt.pch=".", pt.cex=2.5) > > plot(0, 0, type="n", axes=FALSE, xlab="", ylab="") > > #--- row 1 > > # note that this is an example of a model that gets generated differently > # with Scale.y=TRUE vs Scale.y=FALSE (although not shown here) > a4 <- earth(survived~pclassn+age, data=et, degree=2) > > set.seed(844) > plotmo(a4, do.par=F, center=TRUE, clip=F, ylim=c(-.6,.7), + main="earth: survived~pclassn+age\n(default ndiscrete)", degree1=0, all2=T) > > set.seed(844) > plotmo(a4, do.par=F, xflip=F, all1=T, center=TRUE, clip=F, ylim=c(-.6,.7), + main="a4, age with pclassn=1st", ndiscrete=ndiscrete, + degree2=0, degree1=2, + # grid.levels=list(pclassn="1st"), + grid.levels=list(pclassn=1), + smooth.col="lightblue", smooth.lwd=2, + pt.col=ifelse(et$survived, "black", "red"), + pt.pch=".", pt.cex=2.5) plotmo grid: pclassn age 1 29 > > set.seed(844) > plotmo(a4, do.par=F, xflip=F, all1=T, center=TRUE, clip=F, ylim=c(-.6,.7), + main="age with pclassn=3rd", ndiscrete=ndiscrete, + degree2=0, degree1=2, + grid.levels=list(pclassn=3), + smooth.col="lightblue", smooth.lwd=2, + pt.col=ifelse(et$survived, "black", "red"), + pt.pch=".", pt.cex=2.5) plotmo grid: pclassn age 3 29 > > #--- row 2 > > set.seed(844) > plotmo(a4, do.par=F, center=TRUE, clip=F, type2="im", + main="a4 earth: survived~pclassn+age\n(default ndiscrete)", degree1=0, all2=T, yflip=T, + pt.col=ifelse(et$survived, 1, "red"), + image.col=gray(seq(6, 10, length=10) / 10), xflip=T, + pt.pch=".", pt.cex=2) > > set.seed(844) > plotmo(a4, do.par=F, xflip=F, all1=T, center=TRUE, clip=F, + main="pclassn with age=10", ndiscrete=ndiscrete, + degree2=0, degree1=1, + grid.levels=list(age=10), + smooth.col="lightblue", smooth.lwd=2, + pt.col=ifelse(et$survived, "black", "red"), + pt.pch=".", pt.cex=2.5) plotmo grid: pclassn age 2 10 > > set.seed(844) > plotmo(a4, do.par=F, xflip=F, all1=T, center=TRUE, clip=F, + main="pclassn with age=40", ndiscrete=ndiscrete, + degree2=0, degree1=1, + grid.levels=list(age=40), + smooth.col="lightblue", smooth.lwd=2, + pt.col=ifelse(et$survived, "black", "red"), + pt.pch=".", pt.cex=2.5) plotmo grid: pclassn age 2 40 > > source("test.epilog.R") plotmo/inst/slowtests/test.plotmo.dots.bat0000755000176200001440000000156114655214117020554 0ustar liggesusers@rem test.plotmo.dots.R: test handling of dots arguments @echo test.plotmo.dots.bat @"C:\PROGRA~1\R\R-4.4.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.R0000644000176200001440000007355014055527241016701 0ustar liggesusers# test.dots.R source("test.prolog.R") cat0("=== test dotindex\n") test.dotindex <- function(expected, ARGNAME, ..., EX=FALSE) { dotindex <- plotmo:::dotindex(ARGNAME=ARGNAME, EX=EX, ...) stopifnot(all.equal(dotindex, expected)) } test.dotindex(NA, "x") # empty dots test.dotindex(NA, "x", a=10, b=20) test.dotindex(1, "a", a=10, b=20) test.dotindex(2, "b", a=10, b=20) test.dotindex(1, "a1", a=10, b=20) test.dotindex(NA, "a", a1=10, a2=20) expect.err(try(test.dotindex(1, nonesuch, a=10, a=20)), "object 'nonesuch' not found") expect.err(try(test.dotindex(1, "a1", a=10, a=20)), "argument 'a' for test.dotindex() is duplicated") expect.err(try(test.dotindex(1, "aa1", a=10, aa=20)), "arguments 'a' and 'aa' both match 'aa1' in test.dotindex") stopifnot(is.na(plotmo:::dotindex("a", EX=1, a1=10, a2=20))) stopifnot(plotmo:::dotindex("a2", EX=1, a1=10, a2=20) == 2) # multiple argnames test.dotindex(NA, c("a", "b")) # empty dots test.dotindex(1, c("a", "b"), a=2, c=3) test.dotindex(1, c("a", "b"), a=5, b=6) test.dotindex(2, c("a", "b"), x=1, a=5, b=6) test.dotindex(3, c("b,a"), x=1, a=5, b=6) test.dotindex(1, c("a b"), b=3, c=4) test.dotindex(2, c(" a b "), c=3, b=4) test.dotindex(NA, c("a", "b"), c=3) stopifnot(plotmo:::dotindex(c("x", "a1"), EX=1, a1=10, a2=20) == 1) test.dota <- function(expected, ARGNAME, ..., DEF=NA, EX=FALSE) { if(is.na(DEF)) dot <- plotmo:::dota(ARGNAME, EX=EX, ...) else dot <- plotmo:::dota(ARGNAME, EX=EX, DEF=DEF, ...) stopifnot(all.equal(dot, expected)) } cat0("=== test dot\n") test.dota(NA, "x") # empty dots test.dota(NA, "x", a=10, b=20) test.dota(10, "a", a=10, b=20) test.dota(20, "b", a=10, b=20) test.dota(99, DEF=99, "nonesuch", a=10, b=20) test.dota(NA, "a", a1=10, a2=20) expect.err(try(test.dota(1, "a1", a=10, a=20)), "argument 'a' for test.dota() is duplicated") expect.err(try(test.dota(1, 99, a=10, a=20)), "is.character(argname) is not TRUE") expect.err(try(test.dota(1, test.dota, a=10, a=20)), "is.character(argname) is not TRUE") expect.err(try(test.dota(1, "", a=10, a=20)), "empty string in ARGNAME") expect.err(try(test.dota(1, "x^x", a=10, a=20)), "illegal character \"^\" in ARGNAME") test.dota(10, "abc", EX=T, abc=10) test.dota(NA, "a", EX=T, a1=10, a2=20) expect.err(try(test.dota(1, "a1", a1=10, a1=20)), "argument 'a1' for test.dota() is duplicated") stopifnot(is.na(plotmo:::dota("a", EX=1, a1=1, a2=2))) stopifnot(plotmo:::dota("a2", EX=1, a1=10, a2=20, a3=30) == 20) foo <- function(func, x) func(x) foo(mean, 33) foo(function(...) plotmo:::dota("x", ...), 33) foo(function(...) plotmo:::dota("x99", ...), 33) foo(function(...) { plotmo:::dota("nonesuch", ...) }, 33) test.dota(1, "a", EX=T, a=1) test.dota(2, "b", EX=T, a=1, b=2, c=3) test.dota(NA, "x", EX=T, a=1, b=2, c=3) test.dota(2, "a", EX=T, ab=1, a=2) test.dota(2, "a", EX=T, aa=1, a=2) test.dota(NA, "a", EX=T, aa=1, ab=2) expect.err(try(test.dota(2, "a", EX=T, aa=1, a=2, a=3)), "argument 'a' for test.dota() is duplicated") expect.err(try(test.dota(2, "a", EX=T, a=none.such)), "cannot evaluate 'a'") # multiple argnames test.dota(2, c("a", "b"), a=2, c=3) test.dota(5, c("a", "b"), a=5, b=6) test.dota(5, c("a", "b"), x=1, a=5, b=6) test.dota(3, c("a", "b"), b=3, c=4) test.dota(4, c("a", "b"), c=3, b=4) test.dota(NA, c("a", "b"), c=3) expect.err(try(test.dota(1, c("b", "aa1"), a=10, aa=20)), "arguments 'a' and 'aa' both match 'aa1' in test.dota") expect.err(try(test.dota(1, c("x", ""), a=10, b=20)), "empty string in ARGNAME") stopifnot(plotmo:::dota(c("x", "a2", "y"), EX=1, a1=10, a2=20, a3=30) == 20) test.dota(NA, c("a", "b"), aa=2, cc=3, EX=T) test.dota(2, c("aa", "b"), aa=2, cc=3, EX=T) test.dota(3, c("bb", "b"), bb=3, cc=4, EX=T) test.dota(NA, c("a", "b"), c=3, EX=T) foo.x <- function(...) { plotmo:::dota("x", ..., DEF="default", EX=FALSE) } stopifnot(foo.x(x=3) == 3) stopifnot(foo.x(y=3) == "default") foo2 <- function(funcarg, ...) funcarg(...) stopifnot(is.na(foo2(function(...) plotmo:::dota("x", ...), 3))) # 3 is unnamed stopifnot(foo2(function(...) plotmo:::dota("x", EX=0, ...), x=3) == 3) stopifnot(foo2(function(...) plotmo:::dota("x99", EX=0, ...), x=3) == 3) stopifnot(foo2(function(...) { plotmo:::dota("x", DEF="default", EX=FALSE, ...) }, x=3) == 3) stopifnot(foo2(function(...) { plotmo:::dota("y", DEF="default", EX=FALSE, ...) }, x=3) == "default") # expect.err(try(foo2(function(...) { plotmo:::dota("y", DEF="default", EX=FALSE, ...) }, 3)), "unnamed arguments in ... are not allowed for funcarg()") stopifnot(foo2(foo.x, x=3) == 3) stopifnot(foo2(foo.x, y=3) == "default") test.is.dot <- function(expected, ARGNAME, ...) { present <- plotmo:::is.dot(ARGNAME, ...) stopifnot(all.equal(present, expected)) } cat0("=== test is.dot\n") test.is.dot(FALSE, "x") # empty dots test.is.dot(FALSE, "x", EX=0, a=10, b=20) test.is.dot(TRUE, "a", EX=0, a=10, b=20) test.is.dot(TRUE, "b", EX=0, a=10, b=20) test.is.dot(TRUE, "a1", EX=0, a=10, b=20) test.is.dot(FALSE, "a", EX=0, a1=10, a2=20) expect.err(try(test.is.dot(TRUE, "a1", EX=0, a=10, a=20)), "argument 'a' for test.is.dot() is duplicated") expect.err(try(test.is.dot(TRUE, "a", EX=0, a=10, a=20)), "argument 'a' for test.is.dot() is duplicated") stopifnot(plotmo:::is.dot("a", EX=1, a1=10, a2=20, a3=30) == FALSE) stopifnot(plotmo:::is.dot("x", EX=1, a1=10, a2=20, a3=30) == FALSE) stopifnot(plotmo:::is.dot("a3", EX=1, a1=10, a2=20, a3=30) == TRUE) # multiple argnames test.is.dot(TRUE, EX=0, c("a1", "b1"), a=2, c=3) test.is.dot(TRUE, EX=0, c("a1", "b1"), b=3, c=4) test.is.dot(TRUE, EX=0, c("a1", "b1"), c=3, b=4) test.is.dot(FALSE, EX=0, c("a1", "b1"), c=3) expect.err(try(test.is.dot(FALSE, c("aa1", "b"), EX=0, a=10, aa=20)), "arguments 'a' and 'aa' both match 'aa1' in test.is.dot") stopifnot(plotmo:::is.dot(c("x", "a", "y"), EX=1, a1=10, a2=20, a3=30) == FALSE) stopifnot(plotmo:::is.dot(c("x", "a2", "y"), EX=1, a1=10, a2=20, a3=30) == TRUE) cat0("=== test expand.drop\n") # nchar is used an example func, it has formals "x", "type", "allowNA" stopifnot(is.null(plotmo:::expand.drop(NULL, prefix="prefix.", func=nchar))) stopifnot(plotmo:::expand.drop("a", prefix="prefix.", func=nchar) == ">PREFIX|>EXPLICIT|^a") stopifnot(plotmo:::expand.drop("a", prefix="prefix.", func=nchar, include.standard.prefixes=TRUE) == ">STANDARDPREFIXES|^force\\.|^def\\.|^drop\\.|>PREFIX|^prefix\\.|>EXPLICIT|^a") stopifnot(plotmo:::expand.drop("FORMALS", prefix="prefix.", func=base::nchar) == ">FORMALS|^x|^type|^allowNA|^keepNA|>PREFIX|>EXPLICIT") stopifnot(plotmo:::expand.drop("FORMALS", prefix="prefix.", func=base::nchar, include.standard.prefixes=TRUE) == ">FORMALS|^x|^type|^allowNA|^keepNA|>STANDARDPREFIXES|^force\\.|^def\\.|^drop\\.|>PREFIX|^prefix\\.|>EXPLICIT") expect.err(try(plotmo:::expand.drop("FORMALS", prefix="prefix.", func=NULL)), "\"FORMALS\" specified in DROP, but FUNC is NULL") expect.err(try(plotmo:::expand.drop("FORMALS", prefix="prefix.", func=base::c)), "\"FORMALS\" specified but formals(FUNC) returned no formal arguments") foo99 <- function(...) NULL expect.err(try(plotmo:::expand.drop("FORMALS", prefix="prefix.", func=foo99)), "\"FORMALS\" specified but formals(FUNC) returned only \"...\"") stopifnot(plotmo:::expand.drop("a,FORMALS", prefix="prefix.", func=base::nchar) == ">FORMALS|^x|^type|^allowNA|^keepNA|>PREFIX|>EXPLICIT|^a") stopifnot(plotmo:::expand.drop("a,FORMALS", prefix="prefix.", func=base::nchar, include.standard.prefixes=TRUE) == ">FORMALS|^x|^type|^allowNA|^keepNA|>STANDARDPREFIXES|^force\\.|^def\\.|^drop\\.|>PREFIX|^prefix\\.|>EXPLICIT|^a") expect.err(try(plotmo:::expand.drop("", prefix="prefix.", func=base::nchar)), "DROP is an empty string") stopifnot(plotmo:::expand.drop("a", prefix="lines.", func=base::nchar) == ">PREFIX|>EXPLICIT|^a") stopifnot(plotmo:::expand.drop("a", "lines.a", prefix="lines.", func=base::nchar, include.standard.prefixes=TRUE) == ">STANDARDPREFIXES|^force\\.|^def\\.|^drop\\.|>PREFIX|^lines\\.|>EXPLICIT|^a") stopifnot(plotmo:::expand.drop("a*", prefix="lines.", func=base::nchar) == ">PREFIX|>EXPLICIT|^a.*") stopifnot(plotmo:::expand.drop("a.*", prefix="lines.", func=base::nchar) == ">PREFIX|>EXPLICIT|^a\\..*") stopifnot(plotmo:::expand.drop("a$", prefix="lines.", func=base::nchar) == ">PREFIX|>EXPLICIT|^a$") stopifnot(plotmo:::expand.drop("a$,b*,c*$", prefix="lines.", func=base::nchar) == ">PREFIX|>EXPLICIT|^a$|^b.*|^c.*$") stopifnot(plotmo:::expand.drop(c("a", "b,c", " d e$ f ", "g h$, i"), prefix="lines.", func=base::nchar) == ">PREFIX|>EXPLICIT|^a|^b|^c|^d|^e$|^f|^g|^h$|^i") stopifnot(plotmo:::expand.drop("PLOT.ARGS", prefix="lines.", func=base::nchar) == ">PREFIX|>EXPLICIT|>PLOT_ARGS|^add$|^adj$|^bty$|^cex$|^cex\\.axis$|^cex\\.lab$|^cex\\.main$|^cex\\.sub$|^col$|^col\\.axis$|^col\\.lab$|^col\\.main$|^col\\.sub$|^crt$|^family$|^font$|^font$|^font\\.axis$|^font\\.lab$|^font\\.main$|^font\\.sub$|^lend$|^ljoin$|^lmitre$|^lty$|^lwd$|^main$|^pch$|^srt$|^xaxp$|^xaxs$|^xaxt$|^xlab$|^xlim$|^xlog$|^xpd$|^yaxp$|^yaxs$|^yaxt$|^ylab$|^ylim$|^ylog$") stopifnot(plotmo:::expand.drop("abc,PLOT.ARGS", prefix="lines.", func=base::nchar) == ">PREFIX|>EXPLICIT|^abc|>PLOT_ARGS|^add$|^adj$|^bty$|^cex$|^cex\\.axis$|^cex\\.lab$|^cex\\.main$|^cex\\.sub$|^col$|^col\\.axis$|^col\\.lab$|^col\\.main$|^col\\.sub$|^crt$|^family$|^font$|^font$|^font\\.axis$|^font\\.lab$|^font\\.main$|^font\\.sub$|^lend$|^ljoin$|^lmitre$|^lty$|^lwd$|^main$|^pch$|^srt$|^xaxp$|^xaxs$|^xaxt$|^xlab$|^xlim$|^xlog$|^xpd$|^yaxp$|^yaxs$|^yaxt$|^ylab$|^ylim$|^ylog$") stopifnot(plotmo:::expand.drop("abc,FORMALS,PLOT.ARGS", prefix="lines.", func=base::nchar) == ">FORMALS|^x|^type|^allowNA|^keepNA|>PREFIX|>EXPLICIT|^abc|>PLOT_ARGS|^add$|^adj$|^bty$|^cex$|^cex\\.axis$|^cex\\.lab$|^cex\\.main$|^cex\\.sub$|^col$|^col\\.axis$|^col\\.lab$|^col\\.main$|^col\\.sub$|^crt$|^family$|^font$|^font$|^font\\.axis$|^font\\.lab$|^font\\.main$|^font\\.sub$|^lend$|^ljoin$|^lmitre$|^lty$|^lwd$|^main$|^pch$|^srt$|^xaxp$|^xaxs$|^xaxt$|^xlab$|^xlim$|^xlog$|^xpd$|^yaxp$|^yaxs$|^yaxt$|^ylab$|^ylim$|^ylog$") stopifnot(plotmo:::expand.drop("abc,FORMALS,PAR.ARGS", prefix="lines.", func=base::nchar) == ">FORMALS|^x|^type|^allowNA|^keepNA|>PREFIX|>EXPLICIT|^abc|>PAR_ARGS|^adj$|^ann$|^ask$|^bg$|^bty$|^cex$|^cex\\.axis$|^cex\\.lab$|^cex\\.main$|^cex\\.sub$|^col\\.axis$|^col\\.lab$|^col\\.main$|^col\\.sub$|^crt$|^err$|^family$|^fg$|^fig$|^fin$|^font$|^font\\.axis$|^font\\.lab$|^font\\.main$|^font\\.sub$|^lab$|^las$|^lend$|^lheight$|^ljoin$|^lmitre$|^lty$|^mai$|^mar$|^mex$|^mfcol$|^mfg$|^mfrow$|^mgp$|^mkh$|^new$|^oma$|^omd$|^omi$|^pch$|^pin$|^plt$|^ps$|^pty$|^srt$|^tck$|^tcl$|^usr$|^xaxp$|^xaxs$|^xaxt$|^xlog$|^xpd$|^yaxp$|^yaxs$|^yaxt$|^ylbias$|^ylog$") stopifnot(plotmo:::expand.drop("abc,FORMALS,PLOTMO.ARGS", prefix="lines.", func=base::nchar) == ">FORMALS|^x|^type|^allowNA|^keepNA|>PREFIX|>EXPLICIT|^abc|>PLOTMO_ARGS|^caption\\.|^cex\\.|^col\\.|^contour\\.|^cum\\.|^degree1\\.|^degree2\\.|^density\\.|^filled\\.contour\\.|^font\\.|^func\\.|^grid\\.|^heatmap\\.|^image\\.|^jitter\\.|^legend\\.|^label\\.|^level\\.|^line\\.|^lines\\.|^lty\\.|^lty\\.|^lwd\\.|^main\\.|^mtext\\.|^nresiduals|^par\\.|^pch\\.|^persp\\.|^plot\\.|^plotmath\\.|^prednames\\.|^qq\\.|^qqline\\.|^pt\\.|^response\\.|^rug\\.|^smooth\\.|^text\\.|^title\\.|^vfont\\.") test.deprefix <- function(expected, ..., FNAME="test.deprefix", KEEP=NULL) { args <- plotmo:::deprefix(..., FNAME=FNAME, KEEP=KEEP, CALLARGS="") # can't use all.equal because it complains about names # cat("args:\n") # print(args) # cat("expected:\n") # print(expected) stopifnot(length(args) == length(expected)) for(i in seq_len(length(expected))) { stopifnot(names(args)[i] == names(expected)[i]) stopifnot(args[[i]] == expected[[i]]) } } cat0("=== test deprefix\n") test.deprefix( expected=list(a=1, b=2), DROP="*", PREFIX="predict.", def.a=1, predict.b=2, c=3) test.deprefix(TRACE=2, expected=list(b="predict.b", d="def.d", c="predict.c", e="predict.e"), PREFIX="predict.", DROP="*", a="a", b="b", c="c", w1.xlab="xlab", def.b="def.b", def.d="def.d", predict.b="predict.b", predict.c="predict.c", predict.e="predict.e") test.deprefix(TRACE=2, expected=list(b="predict.b", d="def.d", a="a", c="predict.c", e="predict.e"), KEEP=NULL, PREFIX="predict.", DROP="w1.", a="a", b="b", c="c", w1.xlab="xlab", def.b="def.b", def.d="def.d", predict.b="predict.b", predict.c="predict.c", predict.e="predict.e") test.deprefix( expected=list(a="predict.a"), KEEP=NULL, PREFIX="predict.", DROP="w1.", a="plain.a", predict.a="predict.a") test.deprefix(expected=list(a="aa1"), KEEP=NULL, PREFIX="predict.", a="aa1") test.deprefix(expected=list(a="aa2"), KEEP=NULL, PREFIX="predict.", def.a="aa2") test.deprefix(expected=list(a="aa3", b="bb3"), KEEP=NULL, PREFIX="predict.", def.a="aa3", b="bb3") test.deprefix(expected=list(10, 20), TRACE=2, KEEP=NULL, DROP="w1.,persp.,xlab.", PREFIX="predict.", force.anon2=20, force.anon1=10) test.deprefix(expected=list(10, 20, a=3), TRACE=2, KEEP=NULL, DROP="w1.,persp.,xlab.", PREFIX="predict.", force.anon2=20, force.anon1=10, a=3) expect.err(try(test.deprefix(expected=list(10, 20, a=4), KEEP=NULL, DROP="w1.,persp.,xlab.", PREFIX="predict.", force.anon=10, force.anon=20, a=3, predict.a=4)), "argument 'force.anon' for test.deprefix() is duplicated") expect.err(try(test.deprefix(expected=list(10, 20, a=4), KEEP=NULL, DROP="w1.,persp.,xlab.", PREFIX="predict.", FNAME="foobar", force.anon=10, force.anon=20, a=3, predict.a=4)), "argument 'force.anon' for foobar() is duplicated") test.deprefix(expected=list(10, 20, a=4), KEEP=NULL, DROP="w1.,persp.,xlab.", PREFIX="predict.", force.anon1=10, force.anon2=20, a=3, predict.a=4) test.deprefix(expected=list(10, 20, b=3, a=4), KEEP=NULL, DROP="w1.,persp.,xlab.", PREFIX="predict.", force.anon1=10, force.anon2=20, def.b=3, a=3, predict.a=4) test.deprefix(expected=list(10, 20, b=5, a=3), KEEP=NULL, DROP="w1.,persp.,xlab.", PREFIX="predict.", force.anon1=10, force.anon2=20, def.b=3, a=3, predict.b=5) test.deprefix(expected=list(10, 20, b=6, a=3), KEEP=NULL, DROP="w1.,persp.,xlab.", PREFIX="predict.", force.anon1=10, force.anon2=20, def.b=3, a=3, b=6) expect.err(try(test.deprefix(expected=NULL, KEEP=NULL, PREFIX="predict.", DROP="w1\\.")), "illegal character \"\\\" in DROP = \"w1\\.\"") test.deprefix(expected=list(b="predict.b", d="def.d", a="a", c="predict.c", w1.xl="xlab2", e="predict.e"), PREFIX="predict.", DROP="w1.xlab$", a="a", b="b", c="c", w1.xlab="xlab1", # will be dropped (exact match) w1.xl="xlab2", # will be kept (not an exact match) def.b="def.b", def.d="def.d", predict.b="predict.b", predict.c="predict.c", predict.e="predict.e") # expect.err(try(plotmo:::deprefix(FNAME="test.deprefix", PREFIX="predict.", UPPER.CASE123=99, # def.a=1, predict.b=2, c=3)), # "uppercase argument names like \"UPPER.CASE123\" are not allowed for test.deprefix()") test.expand.dotnames <- function(expected, PREFIX, FUNC=NULL, FNAME="test.expand.dotnames", FORMALS=NULL, ...) { dots <- as.list(match.call(expand.dots=FALSE)$...) args <- plotmo:::expand.dotnames(dots, PREFIX, FUNC, FNAME, FORMALS) # can't use all.equal because it complains about named list versus unnamed list stopifnot(length(args) == length(expected)) for(i in seq_len(length(expected))) { stopifnot(names(args)[i] == names(expected)[i]) stopifnot(eval(args[[i]]) == expected[[i]]) } } cat0("=== test expand.dotnames\n") test.expand.dotnames(expected=list(x=9, persp.shade=3), "persp.", graphics:::persp.default, "persp.default", x=9, persp.sh=3) test.expand.dotnames(expected=list(x=9, persp.shade=3, persp.nonesuch=4), "persp.", graphics:::persp.default, "persp.default", x=9, persp.sh=3, persp.nonesuch=4) test.expand.dotnames(expected=list(x=9, persp.col=3), "persp.", graphics:::persp.default, "persp.default", x=9, persp.c=3) # TODO not sure why this works as it does test.expand.dotnames(expected=list(x=9, persp.x=3), "persp.", graphics:::persp.default, "persp.default", x=9, persp.x=3) expect.err(try(test.expand.dotnames(expected=NULL, "persp.", graphics:::persp.default, "persp.default", x=9, persp.l=3)), "'l' matches both the 'ltheta' and 'lphi' arguments of persp.default()") test.expand.dotnames(expected=list(x=9, plot.foo=3, plot.xlim=c(1,2)), "plot.", graphics:::plot.default, "plot.default", x=9, plot.foo=3, plot.xlim=c(1,2)) test.expand.dotnames(expected=list(x=9, plot.foo=3, plot.xlim=c(1,2)), "plot.", graphics:::plot.default, "plot.default", x=9, plot.foo=3, plot.xli=c(1,2)) expect.err(try(test.expand.dotnames(expected=NULL, "plot.", graphics:::plot.default, "plot.default", x=9, plot.foo=3, plot.xl=c(1,2))), "'xl' matches both the 'xlim' and 'xlab' arguments of plot.default()") foo3 <- function(aaa=1, aa=2, bb=3, bba=4, cca=5, ccb=6, def=7) cat0("foo3: aaa=", aaa, " aa=", aa, ", bb=", bb, " bba=", bba, " cca=", cca, " ccb=", ccb, " def=", def, "\n") # --- above tests again but using formals --- # formal args for graphics:::persp.default (R version 3.2.0) formals <- c( "x", "y", "z", "xlim", "zlim", "xlab", "ylab", "zlab", "main", "sub", "theta", "phi", "r", "d", "scale", "expand", "col", "border", "ltheta", "lphi", "shade", "box", "axes", "nticks", "ticktype") test.expand.dotnames(expected=list(x=9, persp.shade=3), "persp.", graphics:::persp, "persp", FORMALS=formals, x=9, persp.sh=3) test.expand.dotnames(expected=list(x=9, persp.shade=3, persp.nonesuch=4), "persp.", graphics:::persp, "persp", FORMALS=formals, x=9, persp.sh=3, persp.nonesuch=4) test.expand.dotnames(expected=list(x=9, persp.col=3), "persp.", graphics:::persp, "persp", FORMALS=formals, x=9, persp.c=3) # TODO not sure why this works as it does test.expand.dotnames(expected=list(x=9, persp.x=3), "persp.", graphics:::persp, "persp", FORMALS=formals, x=9, persp.x=3) expect.err(try(test.expand.dotnames(expected=NULL, "persp.", graphics:::persp, "persp", FORMALS=formals, x=9, persp.l=3)), "'l' matches both the 'ltheta' and 'lphi' arguments of persp()") # done formals tests test.expand.dotnames(expected=list(x=9, plot.foo=3, plot.xlim=c(1,2)), "plot.", graphics:::plot.default, "plot.default", x=9, plot.foo=3, plot.xlim=c(1,2)) test.expand.dotnames(expected=list(x=9, plot.foo=3, plot.xlim=c(1,2)), "plot.", graphics:::plot.default, "plot.default", x=9, plot.foo=3, plot.xli=c(1,2)) expect.err(try(test.expand.dotnames(expected=NULL, "plot.", graphics:::plot.default, "plot.default", x=9, plot.foo=3, plot.xl=c(1,2))), "'xl' matches both the 'xlim' and 'xlab' arguments of plot.default()") test.expand.dotnames(expected=list(foo3.aa=99), "foo3.", foo3, "foo3", foo3.aa=99) expect.err(try(plotmo:::call.plot(foo3, "foo3.", foo3.aa=99)), "Unnamed arguments are not allowed here\n The argument's value is \"foo3.\"") expect.err(try(plotmo:::call.plot(foo3, foo, foo3.aa=99)), "Unnamed arguments are not allowed here\n The argument's value is function.object") expect.err(try(plotmo:::call.plot(foo3, NULL, foo3.aa=99)), "Unnamed arguments are not allowed here\n The argument's value is NULL") expect.err(try(plotmo:::call.plot(foo3, stop("stop was called"), foo3.aa=99)), "Unnamed arguments are not allowed here (argument ..1 is unnamed)") expect.err(try(plotmo:::call.plot(foo3, cat("side effect\n"), foo3.aa=99)), "Unnamed arguments are not allowed here\n The argument's value is NULL") expect.err(try(plotmo:::call.plot(foo3, nonesuch1=1, nonesuch2, foo3.aa=99)), "Unnamed arguments are not allowed here (argument ..2 is unnamed)") plotmo:::call.plot(foo3, PREFIX="foo3.", foo3.aa=99) test.expand.dotnames(expected=list(foo3.aaa=99), "foo3.", foo3, "foo3", foo3.aaa=99) plotmo:::call.plot(foo3, foo3.aaa=99) expect.err(try(test.expand.dotnames(expected=list(foo3.aaa=99), "foo3.", foo3, "foo3", foo3.aa=88, foo3.aa=99)), "'foo3.aa' for foo3() is duplicated") expect.err(try(test.expand.dotnames(expected=list(foo3.aaa=99), "foo3.", foo3, "foo3", foo3.a=88, foo3.aa=99)), "'a' matches both the 'aaa' and 'aa' arguments of foo3()") expect.err(try(test.expand.dotnames(expected=list(foo3.aaa=99), "foo3.", foo3, "foo3", foo3.aaa=88, foo3.aaa=99)), "'foo3.aaa' for foo3() is duplicated") test.expand.dotnames(expected=list(foo3.bbb=88, foo3.bba=99), "foo3.", foo3, "foo3", foo3.bbb=88, foo3.bba=99) expect.err(try(plotmo:::call.plot(foo3, foo3.bbb=88, foo3.bba=99)), "unused argument (bbb = 88)") # same as above but with TRACE (so don't use try in call.dots) expect.err(try(plotmo:::call.plot(foo3, foo3.bbb=88, foo3.bba=99, TRACE=T)), "unused argument (bbb = 88)") test.expand.dotnames(expected=list(foo3.bb=88), "foo3.", foo3, "foo3", foo3.bb=88) plotmo:::call.plot(foo3, foo3.bb=88) # test with FUNC=NULL test.expand.dotnames(expected=list(foo3.aa=99), "foo3.", NULL, "foo3", foo3.aa=99) plotmo:::call.plot(foo3, foo3.aa=99) test.expand.dotnames(expected=list(foo3.aaa=99), "foo3.", NULL, "foo3", foo3.aaa=99) plotmo:::call.plot(foo3, foo3.aaa=99) expect.err(try(test.expand.dotnames(expected=list(foo3.aaa=99), "foo3.", NULL, "foo3", foo3.aa=88, foo3.aa=99)), "argument 'foo3.aa' for foo3() is duplicated") test.expand.dotnames(expected=list(foo3.a=88, foo3.aa=99), "foo3.", NULL, "foo3", foo3.a=88, foo3.aa=99) expect.err(try(plotmo:::call.plot(foo3, foo3.a=88, foo3.aa=99)), "'a' matches both the 'aaa' and 'aa' arguments of foo3()") expect.err(try(test.expand.dotnames(expected=list(foo3.aaa=99), "foo3.", NULL, "foo3", foo3.aaa=88, foo3.aaa=99)), "argument 'foo3.aaa' for foo3() is duplicated") test.expand.dotnames(expected=list(foo3.bbb=88, foo3.bba=99), "foo3.", NULL, "foo3", foo3.bbb=88, foo3.bba=99) expect.err(try(plotmo:::call.plot(foo3, PREFIX="foo3.", foo3.bbb=88, foo3.bba=99)), "unused argument (bbb = 88)") test.expand.dotnames(expected=list(foo3.bb=88), "foo3.", NULL, "foo3", foo3.bb=88) plotmo:::call.plot(foo3, foo3.bb=88) test.expand.dotnames(expected=list(foo3.bbx=88), "foo3.", NULL, "foo3", foo3.bbx=88) expect.err(try(plotmo:::call.plot(foo3, foo3.bbx=88)), "unused argument (bbx = 88)") test.expand.dotnames(expected=list(foo3.cc=77), "foo3.", NULL, "foo3", foo3.cc=77) expect.err(try(plotmo:::call.plot(foo3, foo3.cc=77)), "'cc' matches both the 'cca' and 'ccb' arguments of foo3()") # following two directly compare FUNC=NULL to FUNC=foo3 test.expand.dotnames(expected=list(foo3.cc=77), "foo3.", FUNC=NULL, "foo3", foo3.cc=77) expect.err(try(test.expand.dotnames(expected=NULL, "foo3.", FUNC=foo3, "foo3", foo3.cc=77)), "'cc' matches both the 'cca' and 'ccb' arguments of foo3()") test.expand.dotnames(expected=list(), "foo3.", foo3, "foo3", d=88, de=99) expect.err(try(plotmo:::call.plot(graphics::plot, x=1:3, y=1:3, 99)), "Unnamed arguments are not allowed here\n The argument's value is 99\n plotmo:::call.plot via try called call.dots(FUNC=plot, PREFIX=PREFIX, ...") # test TRACE print(plotmo:::deprefix(FUNC=nchar, PREFIX="foo3.", TRACE=TRUE, FNAME="nchar", allowN=1, b=2, foo3.c=3)) print(plotmo:::deprefix(FUNC=nchar, PREFIX="foo3.", TRACE=2, allowN=1, b=2, foo3.c=3)) print(plotmo:::deprefix(FUNC=nchar, PREFIX="foo3.", TRACE=3, allowN=1, b=2, foo3.c=3)) expect.err(try(plotmo:::call.plot(foo3, foo3.d=88, foo3.de=99)), "'foo3.d' and 'foo3.de' both match the 'def' argument of foo3()") cat0("=== test stop.if.dots\n") foo3 <- function(x=1, ...) plotmo:::stop.if.dots(...) foo3(1) # ok expect.err(try(foo3(10, y=2)), "foo3: unrecognized argument 'y'") expect.err(try(foo3(10, 99)), "foo3: unrecognized unnamed argument\n The call was foo3(x=10, 99)") expect.err(try(foo3(10, y=plot)), "foo3: unrecognized argument 'y'") expect.err(try(foo3(10, plot)), "foo3: unrecognized unnamed argument\n The call was foo3(x=10, plot)") expect.err(try(foo3(20, c(1,2,3), plot)), "foo3: unrecognized unnamed argument\n The call was foo3(x=20, c(1,2,3), plot)") expect.err(try(foo3(20, c(1,2,3,4,5,6,7,8,9,10,11,12), plot)), "foo3: unrecognized unnamed argument\n The call was foo3(x=20, c(1,2,3,4,5,6,7,8,9,10,11,12), plot)") # test that we don't crash because we eval the argument expect.err(try(foo3(20, y=stop("stop was called"))), "foo3: unrecognized argument 'y'") expect.err(try(foo3(20, stop("stop was called"))), "foo3: unrecognized unnamed argument") expect.err(try(foo3(20, cat("side effect\n"))), "foo3: unrecognized unnamed argument\n The call was foo3(x=20, cat(") foo2 <- function(...) plotmo:::stop.if.dots(...) foo2() # ok expect.err(try(foo2(y=2)), "foo2: unrecognized argument 'y'") expect.err(try(foo2(2)), "foo2: unrecognized unnamed argument\n The call was foo2(2)") expect.err(try(foo2(y=plot)), "foo2: unrecognized argument 'y'") expect.err(try(foo2(plot)), "foo2: unrecognized unnamed argument\n The call was foo2(plot)") foo2a <- function(funcarg, ...) funcarg(...) expect.err(try(foo2a(function(x=1, ...) plotmo:::stop.if.dots(...), x=1, y=2)), "funcarg: unrecognized argument 'y'") cat0("=== test warn.if.dots\n") options(warn=2) # treat warnings as errors foo3 <- function(x=1, ...) plotmo:::warn.if.dots(...) foo3(1) # ok expect.err(try(foo3(1, y=2)), "foo3 ignored argument 'y'") expect.err(try(foo3(1, 2)), "foo3 ignored unnamed argument\n The call was foo3(x=1, 2)") expect.err(try(foo3(1, y=plot)), "foo3 ignored argument 'y'") # TODO would like to improve this error messsage expect.err(try(foo3(1, plot)), "(converted from warning) foo3 ignored unnamed argument\n The call was foo3(x=1, plot)") foo4 <- function(...) plotmo:::warn.if.dots(...) foo4() # ok expect.err(try(foo4(y=2)), "foo4 ignored argument 'y'") expect.err(try(foo4(2)), "foo4 ignored unnamed argument\n The call was foo4(2)") expect.err(try(foo4(y=plot)), "foo4 ignored argument 'y'") expect.err(try(foo4(plot)), "(converted from warning) foo4 ignored unnamed argument\n The call was foo4(plot)") options(warn=1) foo3(1, nonesuch=12, nonesuch2=12, 999) # expect three warnings cat0("=== test using sample functions that invoke call.dots\n") x <- 1:10 y <- x * x lmfit <- lm(y~x) par(mfrow=c(3, 2)) par(oma=c(0, 0, 3, 0)) # plot1: simple example # we choose to use predict() here rather than fitted() because nearly all # models have a fitted() method, but many don't have a fitted() method. plot1 <- function(object, ...) { residuals <- residuals(object, ...) fitted <- predict(object, ...) plot(fitted, residuals, ...) } plot1(lmfit) mtext("example plot functions using prefixed dots", outer=TRUE, font=2, line=1, cex=1) # Following causes error in predict.lm(). The type argument meant for # residuals() is also sent to predict.lm(), where it is rejected. expect.err(try(plot1(lmfit, type="pearson")), "'arg' should be one of \"response\", \"terms\"") # plot2: use prefixed args plot2 <- function(object, ..., TRACE=2) { resids <- plotmo:::call.dots(residuals, object=object, ..., TRACE=TRACE) fitted <- plotmo:::call.dots(predict, object=object, ..., TRACE=TRACE) plotmo:::call.plot(plot, x=fitted, y=resids, ..., TRACE=TRACE) } # we can now direct args using the prefixes "residuals.", "predict.", or "plot.") plot2(lmfit, residuals.type="pearson") # We can also use the usual plot arguments like ylab: call.dots drops # them; call.plot recognizes them and passes them to lines(). plot2(lmfit, residuals.type="pearson", ylab="pearson residuals", main="plot2") # plot3: further refinements # o namespace added to FUNC arg # o full name for plot.default # o force. and def. prefixes # o explicit xlab and ylab for call.plot # o unprefixed args are passed to residuals() plot3 <- function(object, ..., TRACE=2) { resids <- plotmo:::call.dots(stats::residuals, DROP="plotmo:::PLOTARGS,predict.,plot.", TRACE=TRACE, force.object=object, ...) fitted <- plotmo:::call.dots(stats::predict, force.object=object, TRACE=TRACE, ...) plotmo:::call.plot(graphics::plot.default, force.x=fitted, force.y=resids, def.xlab="fitted", def.ylab="residuals", TRACE=TRACE, ...) } plot3(lmfit, type="pearson", main="plot3a") # type goes only to pearson, no prefix needed plot3(lmfit, type="pearson", predict.type="response", main="plot3b") cat0("=== test callers.name\n") test.callers.name <- function(x) { caller0 <- plotmo:::callers.name(0) # test.callers.name caller1 <- plotmo:::callers.name(1) # caller of test.callers.name caller99 <- plotmo:::callers.name(99) # sys.call(-n) : not that many frames on the stack s <- sprint("0 %s 1 %s 99 %s", caller0, caller1, caller99) cat(s, "\n", sep="") s } print(plotmo:::callers.name()) # "eval" myfunc <- function(func) func() stopifnot(myfunc(function(x) test.callers.name(99)) == "0 test.callers.name 1 func 99 unknown") stopifnot(test.callers.name() == "0 test.callers.name 1 stopifnot 99 unknown") source("test.epilog.R") plotmo/inst/slowtests/test.partykit.bat0000755000176200001440000000145514655214117020143 0ustar liggesusers@rem test.partykit.bat @echo test.partykit.bat @"C:\PROGRA~1\R\R-4.4.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/README.txt0000644000176200001440000000114213306016353016304 0ustar liggesusersplotmo/inst/slowtests/README.txt -------------------------------- The tests in this directory must be run manually before submitting a new version of this package to CRAN. They are much more comprehensive than the standard CRAN checks in tests/tests.plotmo.R, but take several minutes to run. Also they compare postscript files, and there are sometimes arbitrary changes to the format of those postscript files due to changes in the postscript driver across R releases. Such changes must be manually checked by comparing the files in a postscript viewer. Complete automation isn't possible. plotmo/inst/slowtests/test.caret.bat0000755000176200001440000000152214655214117017365 0ustar liggesusers@rem test.caret.bat: test plotmo on caret models @rem Stephen Milborrow, Shrewsbury Aug 2016 @echo test.caret.bat @"C:\PROGRA~1\R\R-4.4.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/test.prolog.R0000644000176200001440000000310513727235376017231 0ustar liggesusers# test.prolog.R # A safe version of sprintf. # Like sprintf except that %s on NULL prints "NULL" rather than # preventing the entire string from being printed # # e.g. sprintf("abc %s def", NULL) returns an empty string -- a silent failure! # but sprint("abc %s def", NULL) returns "abc NULL def" # # e.g. sprintf("abc %d def", NULL) returns an empty string! # but sprint("abc %d def", NULL) causes an error msg (not a silent failure) sprint <- function(fmt, ...) { dots <- list(...) dots <- lapply(dots, function(e) if(is.null(e)) "NULL" else e) do.call(sprintf, c(fmt, dots)) } printf <- function(fmt, ...) cat(sprint(fmt, ...), sep="") cat0 <- function(...) cat(..., sep="") strip.space <- function(s) gsub("[ \t\n]", "", s) # test that we got an error as expected from a try() call expect.err <- function(object, expected.msg="") { if(class(object)[1] != "try-error") stop("Did not get expected error: ", expected.msg) else { msg <- attr(object, "condition")$message[1] if(length(grep(expected.msg, msg, fixed=TRUE))) cat0("Got expected error from ", deparse(substitute(object)), "\n") else stop(sprint("Expected: %s\n Got: %s", expected.msg, substr(msg[1], 1, 1000))) } } empty.plot <- function() { plot(0, 0, col=0, bty="n", xaxt="n", yaxt="n", xlab="", ylab="", main="") } options(warn=1) # print warnings as they occur if(!interactive()) postscript(paper="letter") org.par <- par(no.readonly=TRUE) set.seed(2020) plotmo/inst/slowtests/test.degree.Rout.save0000644000176200001440000001776314563614021020651 0ustar liggesusers> # test.pre.R: test the degree1 and degree2 and related args > > source("test.prolog.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix > library(plotmo) > > # test character degree1 and degree2 (added in plotmo version 1.3-0) > > data(ozone1) > a80 <- earth(O3~., data=ozone1, degree=2) > plotmo(a80, degree1="i", degree2="t", + caption='degree1="i", degree2="t"') plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > plotmo(a80, degree1="^temp$", degree2="^dpg$", + caption='degree1="^temp$", degree2="^dpg$"') plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > # Expect Warning: "nonesuch1" in degree1 does not regex-match any variables, ditto for degree2 > plotmo(a80, degree1=c("temp", "nonesuch1"), degree2="vis", + caption='degree1=c("temp", "nonesuch1"), degree2="vis")') Warning: "nonesuch1" in degree1 does not regex-match any names Available names are "vh" "wind" "humidity" "temp" "ibh" "dpg" "ibt" "vis" "doy" plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > # Expect above warnings and also Warning: nothing to plot > plotmo(a80, degree1="nonesuch1", degree2="nonesuch2") Warning: "nonesuch1" in degree1 does not regex-match any names Available names are "vh" "wind" "humidity" "temp" "ibh" "dpg" "ibt" "vis" "doy" Warning: "nonesuch2" in degree2 does not regex-match any names Available names are "vh" "wind" "humidity" "temp" "ibh" "dpg" "ibt" "vis" "doy" Warning: plotmo: nothing to plot > > # tests for plotmo version 3.3.7 (degree1 and degree2 handling changed) > > data(etitanic) > a81 <- earth(survived~., data=etitanic, degree=2) > options(warn=1) # print warnings as they occur > plotmo(a81) plotmo grid: pclass sex age sibsp parch 3rd male 28 0 0 > > # degree1 tests > par(mfrow=c(3,3), mar=c(1,2.5,2,1), oma=c(0,0,4,0)) > plotmo(a81, do.par=FALSE, degree1="pclass", degree2=0, main='degree1="pclass"', + caption="test degree1 with strings") plotmo grid: pclass sex age sibsp parch 3rd male 28 0 0 > options(warn=2) # treat warnings as errors > expect.err(try(plotmo(a81, do.par=FALSE, degree1="survived", degree2=0)), '"survived" in degree1 does not regex-match any names') Error : (converted from warning) "survived" in degree1 does not regex-match any names Available names are "pclass" "sex" "age" "sibsp" "parch" Got expected error from try(plotmo(a81, do.par = FALSE, degree1 = "survived", degree2 = 0)) > options(warn=1) # print warnings as they occur > plotmo(a81, do.par=FALSE, degree1="sibsp", degree2=0, main='degree1="sibsp"') plotmo grid: pclass sex age sibsp parch 3rd male 28 0 0 > # parch does not appear in the standard degree1 plotmo plots, but we can still specify it explictly > plotmo(a81, do.par=FALSE, degree1="parch", degree2=0, trace=0, main='degree1="parch"') plotmo grid: pclass sex age sibsp parch 3rd male 28 0 0 > plotmo(a81, do.par=FALSE, degree1=c("sibsp", "pclass"), degree2=0, main='degree1=c("sibsp", "pclass")') plotmo grid: pclass sex age sibsp parch 3rd male 28 0 0 > par(org.par) > > # degree2 tests > par(mfrow=c(3,3), mar=c(1,2.5,2,1), oma=c(0,0,4,0)) > plotmo(a81, do.par=FALSE, degree1=0, degree2="pclass", main='degree2="pclass"', + caption="test degree2 with two strings") > plotmo(a81, do.par=FALSE, degree1=0, degree2=c("age", "se"), persp.theta=-35, + main='degree2=c("age", "se")\npersp.theta=-35') > plotmo(a81, do.par=FALSE, degree1=0, degree2="ag", main='degree2="ag"') > plotmo(a81, do.par=FALSE, degree1=0, degree2=c("sex", "sibsp"), main='degree2=c("sex", "sibsp"') > plotmo(a81, do.par=FALSE, degree1=0, degree2=c("sibsp", "sex"), main='degree2=c("sibsp", "sex")') > options(warn=2) # treat warnings as errors > expect.err(try(plotmo(a81, do.par=FALSE, degree1=0, degree2=c("pclass", "nonesuch"))), "\"nonesuch\" in degree2 does not regex-match any names") Error : (converted from warning) "nonesuch" in degree2 does not regex-match any names Available names are "pclass" "sex" "age" "sibsp" "parch" Got expected error from try(plotmo(a81, do.par = FALSE, degree1 = 0, degree2 = c("pclass", "nonesuch"))) > expect.err(try(plotmo(a81, do.par=FALSE, degree1=0, degree2=c("nonesuch1", "nonesuch2"))), "\"nonesuch1\" in degree2 does not regex-match any names") Error : (converted from warning) "nonesuch1" in degree2 does not regex-match any names Available names are "pclass" "sex" "age" "sibsp" "parch" Got expected error from try(plotmo(a81, do.par = FALSE, degree1 = 0, degree2 = c("nonesuch1", "nonesuch2"))) > expect.err(try(plotmo(a81, do.par=FALSE, degree1=0, degree2=c("nonesuch", "pclass"))), "\"nonesuch\" in degree2 does not regex-match any names") Error : (converted from warning) "nonesuch" in degree2 does not regex-match any names Available names are "pclass" "sex" "age" "sibsp" "parch" Got expected error from try(plotmo(a81, do.par = FALSE, degree1 = 0, degree2 = c("nonesuch", "pclass"))) > options(warn=1) # print warnings as they occur > par(org.par) > > par(mfrow=c(2,2), mar=c(1,2.5,2,1), oma=c(0,0,4,0)) > > # check that order of strings in two string degree2 is observed > cat('\n\ndegree2=c("age", "se"):\n') degree2=c("age", "se"): > plotmo(a81, do.par=FALSE, degree1=0, + degree2=c("age", "se"), main='degree2=c("age", "se")') > cat('\n\ndegree2=c("se", "age"):\n') degree2=c("se", "age"): > plotmo(a81, do.par=FALSE, degree1=0, + degree2=c("se", "age"), main='degree2=c("se", "age")') > > # check handling of bad strings in two string degree2 > cat('\n\ndegree2=c("nonesuch", "age"):\n') degree2=c("nonesuch", "age"): > try(plotmo(a81, do.par=FALSE, degree1=0, + degree2=c("nonesuch", "age"), main='degree2=c("nonesuch", "age")')) Warning: "nonesuch" in degree2 does not regex-match any names Available names are "pclass" "sex" "age" "sibsp" "parch" Warning: plotmo: nothing to plot > cat('\n\ndegree2=c("age", "nonesuch"):\n') degree2=c("age", "nonesuch"): > try(plotmo(a81, do.par=FALSE, degree1=0, + degree2=c("age", "nonesuch"), + main='degree2=c("age", "nonesuch")')) Warning: "nonesuch" in degree2 does not regex-match any names Available names are "pclass" "sex" "age" "sibsp" "parch" Warning: plotmo: nothing to plot > cat('\n\ndegree2=c("nevermore", "nonesuch"):\n') degree2=c("nevermore", "nonesuch"): > try(plotmo(a81, do.par=FALSE, degree1=0, + degree2=c("nevermore", "nonesuch"), + main='degree2=c("nevermore", "nonesuch")')) Warning: "nevermore" in degree2 does not regex-match any names Available names are "pclass" "sex" "age" "sibsp" "parch" Warning: plotmo: nothing to plot > # follow should still plot the degree1 plot even though degree2 spec is wrong > cat('\n\ndegree1=1, degree2=c("nevermore", "nonesuch"):\n') degree1=1, degree2=c("nevermore", "nonesuch"): > try(plotmo(a81, do.par=FALSE, degree1=1, + degree2=c("nevermore", "nonesuch"), + main='degree1=1\ndegree2=c("nevermore", "nonesuch")')) Warning: "nevermore" in degree2 does not regex-match any names Available names are "pclass" "sex" "age" "sibsp" "parch" plotmo grid: pclass sex age sibsp parch 3rd male 28 0 0 > > # expect warning: both elements of degree2 are the same > cat('\n\ndegree2=c("sex", "sex"):\n') degree2=c("sex", "sex"): > try(plotmo(a81, do.par=FALSE, degree1=0, + degree2=c("sex", "sex"), + main='degree1=1\ndegree2=c("sex", "sex")')) Warning: both elements of degree2 are the same > > par(org.par) > > source("test.epilog.R") plotmo/inst/slowtests/test.degree.bat0000755000176200001440000000156114655214117017525 0ustar liggesusers@rem test.degree.bat: test plotmo's degree1 and degree2 args with character arguments @echo test.degree.bat @"C:\PROGRA~1\R\R-4.4.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/make.bat0000755000176200001440000000557114664213515016237 0ustar liggesusers@rem plotmo/inst/slowtests/make.bat @call test.plotmo.bat @if %errorlevel% NEQ 0 goto err @call test.printcall.bat @if %errorlevel% NEQ 0 goto err @call test.dots.bat @if %errorlevel% NEQ 0 goto err @call test.plotmo.dots.bat @if %errorlevel% NEQ 0 goto err @call test.plotmo.x.bat @if %errorlevel% NEQ 0 goto err @call test.plotmo.args.bat @if %errorlevel% NEQ 0 goto err @call test.degree.bat @if %errorlevel% NEQ 0 goto err @call test.modguide.bat @if %errorlevel% NEQ 0 goto err @call test.linmod.bat @if %errorlevel% NEQ 0 goto err @call test.fac.bat @if %errorlevel% NEQ 0 goto err @call test.plotmo3.bat @if %errorlevel% NEQ 0 goto err @call test.center.bat @if %errorlevel% NEQ 0 goto err @call test.plotres.bat @if %errorlevel% NEQ 0 goto err @call test.partdep.bat @if %errorlevel% NEQ 0 goto err @call test.unusual.vars.bat @if %errorlevel% NEQ 0 goto err @call test.non.earth.bat @if %errorlevel% NEQ 0 goto err @rem The following miscellaneous models are in alphabetical order @call test.c50.bat @if %errorlevel% NEQ 0 goto err @call test.caret.bat @if %errorlevel% NEQ 0 goto err @call test.gbm.bat @if %errorlevel% NEQ 0 goto err @call test.glmnet.bat @if %errorlevel% NEQ 0 goto err @call test.glmnetUtils.bat @if %errorlevel% NEQ 0 goto err @call test.mlr.bat @if %errorlevel% NEQ 0 goto err @call test.parsnip.bat @if %errorlevel% NEQ 0 goto err @call test.partykit.bat @if %errorlevel% NEQ 0 goto err @call test.pre.bat @if %errorlevel% NEQ 0 goto err @rem we also run the earth package tests in \a\r\earth\inst\slowtests\make.bat @cd \a\r\earth\inst\slowtests @if %errorlevel% NEQ 0 goto err @call make.bat @if %errorlevel% NEQ 0 goto err @cd \a\r\plotmo\inst\slowtests @goto done :err @echo ==== ERROR ==== :done @exit /B 0 plotmo/inst/slowtests/test.plotres.R0000644000176200001440000003156713727235376017434 0ustar liggesusers# test.plotres.R source("test.prolog.R") library(earth) data(ozone1) data(etitanic) example(plotres) # basic tests of plotmo on abbreviated titanic data get.tit <- function() { tit <- etitanic pclass <- as.character(tit$pclass) # change the order of the factors so not alphabetical pclass[pclass == "1st"] <- "first" pclass[pclass == "2nd"] <- "class2" pclass[pclass == "3rd"] <- "classthird" tit$pclass <- factor(pclass, levels=c("class2", "classthird", "first")) # log age is so we have a continuous predictor even when model is age~. set.seed(2015) tit$logage <- log(tit$age) + rnorm(nrow(tit)) tit$parch <- NULL # by=12 gives us a small fast model with an additive and a interaction term tit <- tit[seq(1, nrow(etitanic), by=12), ] } tit <- get.tit() plotlm1 <- function(object) { old.par <- par(no.readonly=TRUE) on.exit(par(old.par)) par(mfrow=c(2,2), oma=c(0,0,3,0), mar=c(4, 3, 3, 1.5), mgp=c(1.5, 0.4, 0), tcl=-.3, font.main=1, cex.main=1) plot(object, sub.caption="standard call to plot.lm") } plotlm.using.plotres <- function(object) { old.par <- par(no.readonly=TRUE) on.exit(par(old.par)) par(mfrow=c(2,2), oma=c(0,0,3,0), mar=c(4, 3, 3, 1.5), mgp=c(1.5, 0.4, 0), tcl=-.3, font.main=1, cex.main=1) # residuals vs fitted plotres(object, pch=1, which=3, caption=paste(deparse(object$call), collapse=" ")) # QQ plot plotres(object, pch=1, which=4, standardize=TRUE) # scale-location plot plotres(object, pch=1, which=6, standardize=TRUE) # leverage plot plotres(object, pch=1, which=3, versus=4, standardize=TRUE) } lm.mod <- lm(Volume~., data=trees) plotlm1(lm.mod) plotlm.using.plotres(lm.mod) # various arguments plotres(lm.mod, SHOWCALL=TRUE) plotres(lm.mod, level=.95, id.n=-3, SHOWCALL=TRUE) lm.tit <- lm(survived~., data=tit) col <- ifelse(tit$survived, "green", "red") pch <- ifelse(tit$sex == "male", 20, 6) plotres(lm.tit, level=.95, col=col, pch=pch, level.shade="gray", level.shade2="lightgray", SHOWCALL=TRUE) plotres(lm.tit, col.resp=3, cum.col=2, cum.cex=1.2, grid.col=5, qq.col=1, qq.cex=.3, SHOWCALL=TRUE) plotres(lm.tit, pt.col="pink", smooth.col=0, SHOWCALL=TRUE) plotres(lm.tit, smooth.col=3, smooth.lwd=1.2, smooth.lty=2, smooth.f=.2, label.col=4, label.cex=.9, label.font=2, SHOWCALL=TRUE) foo <- function() { afoo <- earth(O3~., data=ozone1, deg=2) old.par <- par(no.readonly=TRUE) on.exit(par(old.par)) par(mfrow=c(2,2), oma=c(0,0,3,0), mar=c(4, 3, 3, 1.5), mgp=c(1.5, 0.4, 0), tcl=-.3, font.main=1, cex.main=1) # test xlim ylim etc. on qq and cum plots plotres(afoo, which=2, trace=0, xlim=c(0,20), ylim=c(-.2,1.1), grid.col="pink", info=TRUE) plotres(afoo, which=2, trace=0, grid.col="pink", info=TRUE, cum.col=2, cum.cex=1.4) plotres(afoo, which=4) plotres(afoo, which=4, trace=0, xlim=c(-7,7), ylim=c(-20, 20), qq.col=2, qq.cex=.5, label.col=1, qqline.col="orange", qqline.lty=1) # check xlim and ylim apply only to resids plots if multiple plots plotres(afoo, which=c(2:5), trace=0, xlim=c(-1,5), ylim=c(-8, 8), qq.col=2, qq.cex=.5, label.col=1, qqline.col="orange", smooth.col=3, smooth.lwd=2) } foo() # test id.n and npoints set.seed(1066) a20 <- earth(Volume~., data=trees, ncr=3, nfo=3, varmod.method="lm", keepxy=TRUE) par(mfrow=c(2,2), oma=c(0,0,3,0), mar=c(4, 3, 3, 1.5), mgp=c(1.5, 0.4, 0), tcl=-.3, cex=1) plot(a20, which=3, standardize=TRUE, smooth.col=0, id.n=-1, main="a20-00, smooth.col=0, id.n=-1", caption="test id.n and npoints") plot(a20, which=3, standardize=TRUE, smooth.col=0, id.n=10, main="a20-01, smooth.col=0, id.n=10") # this tests cex with do.par=FALSE plot(a20, which=3, standardize=TRUE, smooth.col=0, npoints=10, cex=.8, main="a20-02, smooth.col=0, npoints=10, cex=.8") # TODO labels are hosed in the following plot(a20, which=3, standardize=TRUE, smooth.col=0, npoints=5, id.n=10, main="a20-03, labels hosed\nsmooth.col=0, npoints=10, id.n=10") # test leverages and handling of unity leverages lm.mod <- lm(Volume~., data=trees) par(mfrow=c(2,2), oma=c(0,0,3,0), mar=c(4, 3, 3, 1.5), mgp=c(1.5, 0.4, 0), tcl=-.3, cex=1) a20$leverages[31] <- 1 # fake a unity leverage plot(a20, which=3, versus=4, standardize=TRUE, main="resids vs leverage\nunity leverage", caption="leverage plots") plotres(a20, which=3, standardize=TRUE, main="resids vs fitted\nunity leverage") plotres(lm.mod, which=3, versus=4, standardize=TRUE, main="lever plot for lm.mod") plotres(lm.mod, which=3, versus=4, standardize=TRUE, main="cook args", cook.levels=c(.5, .8, 1), cook.col="blue", cook.lty=2) plot(a20, which=3, versus=4, standardize=TRUE, info=TRUE, main="resids vs leverage\nunity leverage", caption="leverage plots with info=TRUE") plotres(a20, which=3, standardize=TRUE, info=TRUE, main="resids vs fitted\nunity leverage") plotres(lm.mod, which=3, versus=4, standardize=TRUE, info=TRUE, main="lever plot for lm.mod") plotres(lm.mod, which=3, versus=4, standardize=TRUE, info=TRUE, main="cook args", cook.levels=c(.5, .8, 1), cook.col="blue", cook.lty=2) # back compat tests par(mfrow=c(2,2), oma=c(0,0,3,0), mar=c(4, 3, 3, 1.5), mgp=c(1.5, 0.4, 0), tcl=-.3) plotres(a20, which=3, col.smooth=4, smooth.lwd=2, smooth.lty=2, main="a20-04 col.smooth=4, smooth.lwd=2, smooth.lty=2", caption="back compat tests with plot.earth") plotres(a20, which=4, qq.col=3, qqline.col="lightblue", qqline.lty=2, main="a20-05 qq.col=3") plotres(a20, which=4, qqline.col=0, main="a20-06 qqline.col=0") # set.seed(1066) # mod.earth.tit <- earth(tit[,-3], tit[,3], degree=2, nfold=3, ncross=3, varmod.method="earth", keepxy=TRUE) plot(0,0) plot(a20, which=1, col.grid="pink", col.rsq=3, lty.rsq=1, main="a20-07 col.grid=\"pink\", col.rsq=3, lty.rsq=1") # TODO following not working? plot(a20, which=3, col.cv=4, col.grid="pink", main="a20-08 col.cv=4, col.grid=\"pink\"") plot(a20, which=3, col.points="orange", cex.points=1.5, main="a20-09 col.points=\"orange\", cex.points=1.5") plot(a20, which=3, col.residuals="orange", smooth.f=.2, col.line=3, main="a20-10 col.residuals=\"orange\", smooth.f=.2, col.line=3") # test graphics args outside do.par par(col.main="#456789") cat("before par: cex=", par("cex"), " col.main=", par("col.main"), " col.axis=", par("col.axis"), "\n", sep="") plot(a20, which=c(2,3), caption="a20 which=c(2,3) (i.e. do.par=TRUE) no cex") plot(a20, which=c(2,3), cex=1, caption="a20 which=c(2,3) (i.e. do.par=TRUE) cex=1, plot should be identical to previous page") plot(a20, which=c(2,3), cex=1.2, caption="a20 which=c(2,3) (i.e. do.par=TRUE) cex=1.2") plot(a20, which=3, main="no cex", caption="a20 test graphics args with do.par=FALSE") plot(a20, which=3, cex=1, main="cex=1") plot(a20, which=3, cex=.8, main="cex=.8") plot(a20, which=3, cex=1.1, col.main=2, col.axis="blue", col.lab=3, font.lab=2, main="cex=1.1, col.main=2, col.axis=\"blue\", col.lab=3, font.lab=2") # all of these should have been restored cat("after par: cex=", par("cex"), " col.main=", par("col.main"), " col.axis=", par("col.axis"), "\n", sep="") stopifnot(par("col.main") == "#456789") par(col.main=1) survived <- as.numeric(tit$survived) # 0 or 1 sex <- as.numeric(tit$sex) # 1 or 2 pclass <- as.numeric(tit$pclass) # 1,2, or 3 age <- tit$age # .2 to 80 printf("======== basic operation, compare to plot.lm etc.\n") par(mfrow=c(2,2), mar=c(3,3,3,1), mgp=c(1.5,0.5,0), oma=c(0,0,2.5,0)) lm <- lm(survived~sex+pclass+age) plot(lm, which=5, pch=20) plot(0, 0) plot(lm, which=1, pch=20) plot(lm, which=2, pch=20) plotres(lm, standardize=1, cook.levels=c(.1,.2,.3), SHOWCALL=TRUE) elm <- earth(survived~sex+pclass+age, linpreds=TRUE, thresh=0, penalty=-1) plotres(elm, col=survived+2, SHOWCALL=TRUE) set.seed(2015) elm.glm <- earth(survived~sex+pclass+age, linpreds=TRUE, thresh=0, penalty=-1, glm=list(family=binomial), ncr=3, nfold=3, varmod.method="lm") plotres(elm.glm, col=survived+2, SHOWCALL=TRUE) printf("======== check type arg with earth\n") par(mfrow=c(2,2), mar=c(3,3,3,1), mgp=c(1.5,0.5,0), oma=c(0,0,2.5,0)) # following two are equivalent # TODO $$ following look wrong (the plots have changed from plotmo/earth pre Sep 2020) plotres(elm.glm, col=survived+2, standardize=TRUE, which=3, do.par=FALSE, main="standardize=TRUE") mtext("elm.glm with various type options", outer=TRUE, font=2, line=1, cex=1) plotres(elm.glm, col=survived+2, type="standardize", which=3, do.par=FALSE, main="type=\"standardize\"\nequivalent to standardize=TRUE") # TODO double standardization, should not be allowed plotres(elm.glm, col=survived+2, standardize=TRUE, type="standardize", which=3, do.par=FALSE, main="standard=TRUE, type=\"deviance\"\ndouble standardization") plotres(elm.glm, col=survived+2, type="deviance", which=3, do.par=FALSE, main="type=\"deviance\"") printf("======== multiple response earth models\n") par(mfrow=c(2,2), mar=c(3,3,3,1), mgp=c(1.5,0.5,0), oma=c(0,0,2.5,0)) set.seed(2015) emulti0 <- earth(cbind(Volume, Volume + 100 + 5 * rnorm(nrow(trees)))~., data=trees) set.seed(2015) plot(emulti0, nresponse=2, which=3, do.par=FALSE, main="emulti0 nresponse=2") set.seed(2015) rnorm1 <- rnorm(nrow(trees)) emulti <- earth(cbind(Volume, Volume + 100 + 5 * rnorm1)~., data=trees) plot(emulti, nresponse=2, which=3, do.par=FALSE, main="emulti nresponse=2") mtext("multiple response earth models", outer=TRUE, font=2, line=1, cex=1) plot(emulti, nresponse=2, FORCEPREDICT=TRUE, which=3, do.par=FALSE, main="emulti, nresponse=2\nFORCEPREDICT=TRUE") printf("======== earth model with a factor response\n") epclass <- earth(pclass~., data=tit) par(mfrow=c(2,2), mar=c(3,3,3,1), mgp=c(1.5,0.5,0), oma=c(0,0,2.5,0)) set.seed(2015) plot(epclass, nresponse="first", trace=1, which=3, do.par=FALSE, main="pclass response, nresponse=\"first\"") mtext("earth model with a factor response", outer=TRUE, font=2, line=1, cex=1) plot(epclass, nresponse="first", trace=1, FORCEPREDICT=TRUE, which=3, do.par=FALSE, main="pclass response, nresponse=\"first\"\nFORCEPREDICT=TRUE") printf("======== glm\n") glm <- glm(survived~sex+pclass+age, family=binomial) par(mfrow=c(2,2), mar=c(3,3,3,1), mgp=c(1.5,0.5,0), oma=c(0,0,2.5,0)) plot(glm, which=1, pch=20, main="plot.lm") mtext("glm model with plot.lm and plotres", outer=TRUE, font=2, line=1, cex=1) plotres(glm, which=3, main="plotres glm survived") # with plotres we can also plot pearson etc. residuals plotres(glm, which=3, type="pearson", main="plotres glm survived\ntype=\"pearson\"") printf("======== rpart\n") library(rpart) par(mfrow=c(2,2), mar=c(3,3,3,1), mgp=c(1.5,0.5,0), oma=c(0,0,2.5,0)) rpart <- rpart(survived~sex+pclass+age) plotres(rpart, SHOWCALL=TRUE) plotres(rpart, SHOWCALL=TRUE, FORCEPREDICT=TRUE) # identical # TODO following fails in plotmo.predict.rpart (which is called to get the fitted values) # plotres(rpart, type="pearson") plotres(rpart, jitter=3, w1.extra=100, w1.under=TRUE, w1.branch.type=5, col=survived+2, smooth.col=NA, label.col=1, SHOWCALL=TRUE) fit <- rpart(Kyphosis ~ Age + Number + Start, data = kyphosis) plotres(fit, nresponse=1, SHOWCALL=TRUE, jitter=5) plotres(fit, nresponse=2, SHOWCALL=TRUE, jitter=TRUE) printf("======== versus=\"b:\"\n") library(gam) gam.package.loaded <- "package:gam" %in% search() mgcv.package.loaded <- "package:mgcv" %in% search() if(mgcv.package.loaded && gam.package.loaded) { # prevent downstream confusing error messages stop0("both 'gam' and 'mgcv' are loaded") } library(earth) data(ozone1) data(ozone1) oz <- ozone1[, c("O3", "humidity", "temp", "ibt")] gam.mod <- gam(O3^(1/3) ~ lo(humidity)+lo(ibt,temp), data=oz) plotmo(gam.mod, SHOWCALL=TRUE) plotres(gam.mod, SHOWCALL=TRUE) plotres(gam.mod, versus="b:", SHOWCALL=TRUE) plotres(gam.mod, versus="b:ib", info=TRUE, SHOWCALL=TRUE) gam.linear.humidity.only <- gam(O3^(1/3) ~ humidity, data=oz) plotres(gam.linear.humidity.only, versus="b:", SHOWCALL=TRUE) library(mda) mars <- mars(ozone1[,2:3], ozone1[,1], degree=2) mars.to.earth <- mars.to.earth(mars) plotres(mars, versus="b:", caption="mars model, versus=\"b:\"", SHOWCALL=TRUE) plotres(mars.to.earth, versus="b:", caption="earth model, versus=\"b:\", should be same as previous page", SHOWCALL=TRUE) plotres(mars, versus="b:1", caption="mars model, versus=\"b:1\"", SHOWCALL=TRUE) # lars is tested in plotmo3.R # gbm is tested in plotmo3.R # TODO fda is not tested source("test.epilog.R") plotmo/inst/slowtests/test.plotmo.args.bat0000755000176200001440000000160114655214117020532 0ustar liggesusers@rem test.plotmo.args.bat: test dot and other argument handling in plotmo @echo test.plotmo.args.bat @"C:\PROGRA~1\R\R-4.4.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.pre.R0000644000176200001440000000745213727235376016526 0ustar liggesusers# test.pre.R: test the "pre" package with plotmo and plotres source("test.prolog.R") library(pre) library(plotmo) library(earth) # for ozone1 options(warn=1) # print warnings as they occur data(airquality) airq <- airquality[complete.cases(airquality), (c("Ozone", "Wind", "Temp"))] # prevent confusion caused by integer rownames which don't match row numbers rownames(airq) <- NULL airq <- airq[1:50, ] # small set of data for quicker test coef.glmnet <- glmnet:::coef.glmnet # TODO workaround required for glmnet 3.0 predict.cv.glmnet <- glmnet:::predict.cv.glmnet set.seed(2018) pre.mod <- pre(Ozone~., data=airq, ntrees=10) # ntrees=10 for faster test plotres(pre.mod) # variable importance and residual plots plotres(pre.mod, which=3, main="pre.mod residuals") # which=3 for just the residual vs fitted plot plotmo(pre.mod) # plot model surface with background variables held at their medians # sanity check: compare model surface to to randomForest # (commented out to save test time) # # library(randomForest) # set.seed(2018) # rf.mod <- randomForest(Ozone~., data=airq) # plotmo(rf.mod) # compare singleplot and plotmo par(mfrow=c(2,2)) # 4 plots per page singleplot(pre.mod, varname="Temp", main="Temp\n(singleplot)") plotmo(pre.mod, pmethod="partdep", # plot partial dependence plot, degree1="Temp", degree2=0, # plot only Temp, no degree2 plots do.par=FALSE, # don't automatically set par(), use above par(mfrow) main="Temp\n(plotmo partdep)") # test penalty.par.val="lambda.min" singleplot(pre.mod, varname="Temp", main="penalty.par.val=lambda.min\n(singleplot)", penalty.par.val="lambda.min") plotmo(pre.mod, pmethod="partdep", degree1="Temp", degree2=0, do.par=FALSE, main="penalty.par.val=lambda.min\n(plotmo partdep)", predict.penalty.par.val="lambda.min") # use "predict." to pass it on to predict.pre par(org.par) # compare pairplot and plotmo par(mfrow=c(2,3)) # 6 plots per page pairplot(pre.mod, c("Temp", "Wind"), main="pairplot") plotmo(pre.mod, main="plotmo partdep", pmethod="partdep", degree1=0, degree2="Temp", do.par=FALSE) # Compare to pmethod="apartdep". An approximate partdep plot is # faster than a full partdep plot (plotmo vignette Section 9.2). plotmo(pre.mod, main="plotmo apartdep", pmethod="apartdep", degree1=0, degree2="Temp", do.par=FALSE) # plot contour and image plots with plotmo plotmo(pre.mod, type2="contour", degree1=0, degree2="Temp", do.par=FALSE) plotmo(pre.mod, type2="image", degree1=0, degree2="Temp", do.par=FALSE) par(org.par) # test gpe models set.seed(2018) gpe.mod <- gpe(Ozone~., data=airq, base_learners=list(gpe_linear(), gpe_trees(), gpe_earth())) plotmo(gpe.mod) # by default no degree2 plots because importance(gpe) not available plotmo(gpe.mod, all2=TRUE, # force degree2 plot(s) by specifying all2=TRUE persp.ticktype="detailed", persp.nticks=2) # optional (these get passed on to persp) plotmo(gpe.mod, degree1=0, degree2=c("Wind", "Temp"), SHOWCALL=TRUE) # explictly specify degree2 plot # which=3 below for only the residuals-vs-fitted plot # optional info=TRUE to plot some extra information (RSq etc.) plotres(gpe.mod, which=3, info=TRUE, main="gpe.mod residuals") # multinomial response set.seed(2018) pre.iris <- pre(Species~., data=iris, ntrees=10) # ntrees=10 for faster testoptions(warn=2) # treat warnings as errors options(warn=2) # treat warnings as errors expect.err(try(plotmo(pre.iris)), "Defaulting to nresponse=1, see above messages") options(warn=1) # print warnings as they occur plotmo(pre.iris, all2=TRUE, nresponse="virginica", trace=1) source("test.epilog.R") plotmo/inst/slowtests/test.pre.bat0000755000176200001440000000142314655214117017055 0ustar liggesusers@rem test.pre.bat: pre tests for plotmo and plotres @echo test.pre.bat @"C:\PROGRA~1\R\R-4.4.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/test.fac.Rout.save0000644000176200001440000004213514563614021020136 0ustar liggesusers> # test.fac.R: test factor plotting in plotmo. This also tests swapxy, xflip, and yflip > # Stephen Milborrow, Berea Mar 2011 > > source("test.prolog.R") > library(plotmo) Loading required package: Formula Loading required package: plotrix > library(earth) > library(rpart) > data(ozone1) > data(etitanic) > > cat("==test plotmo with factors==\n") ==test plotmo with factors== > test.fac.with.rpart <- function(ngrid2=20) + { + et <- etitanic + + col.response <- as.numeric(et$sex)+2 + et$pclass.fac <- et$pclass + et$parch.int <- et$parch + parch.fac <- et$parch + parch.fac[parch.fac >= 3] <- 3 + # use non alphabetically sorted factor levels + et$parch.fac <- factor(parch.fac, labels=c( "levz", "lev1", "lev2", "levf")) + et$pclass.num <- as.numeric(et$pclass) + et$pclass <- et$sex <- et$age <- et$sibsp <- et$parch <- NULL + cat("names(et):", names(et), "\n") # survived pclass.fac parch.int parch.fac pclass.num + + old.par <- par(no.readonly=TRUE) + on.exit(par(old.par)) + par(mfrow=c(4,5)) + par(mar = c(2, 2, 3, 0.5), cex=.6) + + # numeric x numeric + a2 <- rpart(survived ~ pclass.num+parch.int, data=et) + set.seed(145) + plotmo(a2, do.par=F, type2="im", degree1=2, + col.response=col.response, pt.cex=.3) + set.seed(145) + plotmo(a2, do.par=F, type2="con", degree1=NA, + col.response=col.response, pt.cex=.3) + set.seed(145) + plotmo(a2, do.par=F, type2="persp", degree1=NA, + ngrid2=40, persp.theta=NA, persp.ticktype="d", cex.lab=.8, persp.ntick=2) + + # factor x numeric + a3 <- rpart(survived ~ pclass.fac+parch.int, data=et) + set.seed(145) + plotmo(a3, do.par=F, type2="im", + col.response=col.response, pt.cex=.3) + set.seed(145) + plotmo(a3, do.par=F, type2="con", degree1=NA, + col.response=col.response, pt.cex=.3) + + set.seed(145) + plotmo(a3, do.par=F, type2="persp", degree1=NA, + ngrid2=40, persp.theta=NA, persp.ticktype="d", persp.border=NA, cex.lab=.8, persp.ntick=2) + + # numeric x factor + a4 <- rpart(survived ~ pclass.num+parch.fac, data=et) + set.seed(145) + plotmo(a4, do.par=F, type2="im", tra=1, + col.response=col.response, pt.cex=.3) + set.seed(145) + plotmo(a4, do.par=F, type2="con", degree1=NA, + col.response=col.response, pt.cex=.3) + set.seed(145) + plotmo(a4, do.par=F, type2="persp", degree1=NA, + ngrid2=40, persp.theta=NA, persp.ticktype="d", persp.border=NA, cex.lab=.8, persp.ntick=2) + + # factor x factor + a5 <- rpart(survived ~ pclass.fac+parch.fac, data=et) + set.seed(145) + plotmo(a5, do.par=F, type2="im", nrug=TRUE, + col.response=col.response, pt.cex=.3) + set.seed(145) + plotmo(a5, do.par=F, type2="con", degree1=NA, + col.response=col.response, pt.cex=.3) + set.seed(145) + plotmo(a5, do.par=F, type2="persp", degree1=NA, + ngrid2=40, persp.theta=NA, persp.ticktype="d", persp.border=NA, cex.lab=.8, persp.ntick=2) + + # test ndiscrete + par(mfrow=c(3,5)) + par(mar = c(2, 2, 3, 0.5), cex=.6) + + plotmo(a2, do.par=F, type2="persp", degree1=2, ndiscrete=0, main="ndiscrete=0", + persp.theta=NA, persp.ticktype="d", persp.ntick=2, + col.response=col.response, pt.cex=.3) + plotmo(a2, do.par=F, type2="im", degree1=NA, ndiscrete=0) + plotmo(a2, do.par=F, type2="con", degree1=NA, ndiscrete=0) + plotmo(a2, do.par=F, type2="persp", degree1=2, degree2=NA, ndiscrete=0, main="center", center=TRUE, + col.response=col.response, pt.cex=.3) + + plotmo(a2, do.par=F, type2="persp", degree1=2, ndiscrete=3, main="ndiscrete=3", + persp.theta=NA, persp.ticktype="d", persp.ntick=2, + col.response=col.response, pt.cex=.3) + plotmo(a2, do.par=F, type2="im", degree1=NA, ndiscrete=3) + plotmo(a2, do.par=F, type2="con", degree1=NA, ndiscrete=3) + plotmo(a2, do.par=F, type2="persp", degree1=2, degree2=NA, ndiscrete=3, main="center", center=TRUE, + col.response=col.response, pt.cex=.3) + + plotmo(a2, do.par=F, type2="persp", degree1=2, ndiscrete=10, main="ndiscrete=10", + persp.theta=NA, persp.ticktype="d", persp.ntick=2, + col.response=col.response, pt.cex=.3) + plotmo(a2, do.par=F, type2="im", degree1=NA, ndiscrete=10) + plotmo(a2, do.par=F, type2="con", degree1=NA, ndiscrete=10) + plotmo(a2, do.par=F, type2="persp", degree1=2, degree2=NA, ndiscrete=10, main="center", center=TRUE, + col.response=col.response, pt.cex=.3) + } > test.fac.with.rpart() names(et): survived pclass.fac parch.int parch.fac pclass.num plotmo grid: pclass.num parch.int 2 0 plotmo grid: pclass.fac parch.int 3rd 0 stats::predict(rpart.object, data.frame[3,2], type="vector") stats::fitted(object=rpart.object) fitted() was unsuccessful, will use predict() instead got model response from model.frame(survived ~ pclass.num + parch.fac, data=call$data, na.action="na.pass") plotmo grid: pclass.num parch.fac 2 levz plotmo grid: pclass.fac parch.fac 3rd levz plotmo grid: pclass.num parch.int 2 0 Warning: forcing clip=FALSE because center=TRUE (a limitation of the current implementation) plotmo grid: pclass.num parch.int 2 0 plotmo grid: pclass.num parch.int 2 0 Warning: forcing clip=FALSE because center=TRUE (a limitation of the current implementation) plotmo grid: pclass.num parch.int 2 0 plotmo grid: pclass.num parch.int 2 0 Warning: forcing clip=FALSE because center=TRUE (a limitation of the current implementation) plotmo grid: pclass.num parch.int 2 0 > cat("==test plotmo swapxy with factors==\n") ==test plotmo swapxy with factors== > test.swapxy.with.rpart <- function(ngrid2=20) + { + et <- etitanic[c(1:50,300:350,600:650),] + + col.response <- as.numeric(et$sex)+2 + et$pclass.fac <- et$pclass + et$parch.int <- et$parch + parch.fac <- et$parch + parch.fac[parch.fac > 2] <- 2 + # use non alphabetically sorted factor levels + et$parch.fac <- factor(parch.fac, labels=c("lev.zero", "lev.one", "lev.two.or.more")) + print(et$parch.fac) + et$pclass.num <- as.numeric(et$pclass) + et$pclass <- et$sex <- et$age <- et$sibsp <- et$parch <- NULL + cat("names(et):", names(et), "\n") # survived pclass.fac parch.int parch.fac pclass.num + + old.par <- par(no.readonly=TRUE) + on.exit(par(old.par)) + par(mfrow=c(4,4)) + par(mar = c(2, 3, 5, 0.5), cex=.6) + + # factor x factor + a5 <- rpart(survived ~ pclass.fac+parch.fac, data=et) + for(swapxy in c(F,T)) { + for(xflip in c(F,T)) + for(yflip in c(F,T)) { + set.seed(145) + plotmo(a5, do.par=F, type2="im", degree1=NA, + swapxy=swapxy, xflip=xflip, yflip=yflip, + main=paste("swapxy=", swapxy, "\nxflip=", xflip, "\nyflip=", yflip), + col.response=col.response, pt.cex=3, + pt.pch=".") + set.seed(145) + plotmo(a5, do.par=F, type2="con", degree1=NA, + swapxy=swapxy, xflip=xflip, yflip=yflip, + main=paste("swapxy=", swapxy, "\nxflip=", xflip, "\nyflip=", yflip), + col.response=col.response, pt.cex=.3) + } + } + par(mfrow=c(2,2)) + set.seed(146) + plotmo(a5, do.par=F, type2="persp", degree1=NA, + swapxy=FALSE, main=paste("swapxy=", FALSE), + ngrid2=40, persp.theta=145, persp.ticktype="d", cex.lab=.8, persp.ntick=5) + set.seed(146) + plotmo(a5, do.par=F, type2="persp", degree1=NA, + swapxy=TRUE, main=paste("swapxy=", TRUE), + ngrid2=40, persp.theta=145, persp.ticktype="d", cex.lab=.8, persp.ntick=5) + set.seed(146) + plotmo(a5, do.par=F, type2="im", degree1=2, + swapxy=FALSE, main=paste("swapxy=", FALSE)) + } > test.swapxy.with.rpart() [1] lev.zero lev.two.or.more lev.two.or.more lev.two.or.more [5] lev.two.or.more lev.zero lev.zero lev.zero [9] lev.zero lev.zero lev.zero lev.zero [13] lev.zero lev.zero lev.zero lev.one [17] lev.one lev.zero lev.zero lev.one [21] lev.one lev.zero lev.zero lev.zero [25] lev.zero lev.zero lev.zero lev.zero [29] lev.zero lev.zero lev.zero lev.zero [33] lev.zero lev.zero lev.zero lev.one [37] lev.zero lev.zero lev.zero lev.zero [41] lev.zero lev.zero lev.zero lev.zero [45] lev.zero lev.one lev.one lev.zero [49] lev.zero lev.zero lev.zero lev.one [53] lev.one lev.one lev.two.or.more lev.zero [57] lev.zero lev.zero lev.zero lev.zero [61] lev.zero lev.zero lev.two.or.more lev.one [65] lev.one lev.zero lev.zero lev.zero [69] lev.zero lev.zero lev.zero lev.two.or.more [73] lev.one lev.one lev.zero lev.zero [77] lev.zero lev.zero lev.zero lev.zero [81] lev.zero lev.one lev.two.or.more lev.zero [85] lev.zero lev.zero lev.zero lev.zero [89] lev.two.or.more lev.one lev.one lev.zero [93] lev.zero lev.zero lev.one lev.zero [97] lev.two.or.more lev.zero lev.zero lev.zero [101] lev.zero lev.zero lev.zero lev.zero [105] lev.one lev.one lev.one lev.two.or.more [109] lev.zero lev.zero lev.zero lev.zero [113] lev.one lev.one lev.zero lev.zero [117] lev.zero lev.zero lev.zero lev.zero [121] lev.zero lev.zero lev.zero lev.zero [125] lev.one lev.one lev.one lev.one [129] lev.zero lev.zero lev.zero lev.zero [133] lev.zero lev.zero lev.zero lev.zero [137] lev.zero lev.zero lev.zero lev.zero [141] lev.zero lev.zero lev.zero lev.zero [145] lev.zero lev.zero lev.zero lev.zero [149] lev.zero lev.zero lev.zero lev.zero Levels: lev.zero lev.one lev.two.or.more names(et): survived pclass.fac parch.int parch.fac pclass.num plotmo grid: pclass.fac parch.fac 2nd lev.zero > > aflip <- earth(O3~vh + wind + humidity + temp, data=ozone1, degree=2) > col.response<- ifelse(ozone1$O3 == 38, "red", "pink") > > # test xflip arg, degree1 plots > par(mfrow=c(2,2)) > set.seed(102) > plotmo(aflip, degree1=1:2, degree2=0, do.par=F, col.response=col.response, nrug=-1, ylab="O3", smooth.col="gray") plotmo grid: vh wind humidity temp 5760 5 64 62 > plotmo(aflip, degree1=1:2, degree2=F, do.par=F, col.response=col.response, nrug=-1, ylab="O3", xflip=T, main="xflip=TRUE, degree1 plots", , smooth.col="gray") plotmo grid: vh wind humidity temp 5760 5 64 62 > > col.response<- ifelse(ozone1$O3 == 1, "green", "pink") > > # test flip args, type2=persp > par(mfrow=c(2,2)) > plotmo(aflip, degree1=0, degree2=2, do.par=F, persp.ticktype="d") > plotmo(aflip, degree1=0, degree2=2, do.par=F, persp.tickt="d", swapxy=T, main="swapxy=TRUE") > plot(0, 0, type="n", axes=FALSE, xlab="", ylab="") > plot(0, 0, type="n", axes=FALSE, xlab="", ylab="") > > # test swapxy args, type2=image > par(mfrow=c(3,3)) > > plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="im", col.response=col.response, main="test swapxy on image plots\nreference plot") > plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="im", col.response=col.response, swapxy=T, main="swapxy=T") > plot(0, 0, type="n", axes=FALSE, xlab="", ylab="") > > plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="im", col.response=col.response, xflip=T, main="xflip=T") > plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="im", col.response=col.response, yflip=T, main="yflip=T") > plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="im", col.response=col.response, xflip=T, yflip=T, main="xflip=T, yflip=T") > > plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="im", col.response=col.response, swapxy=T, xflip=T, main="swapxy=T, xflip=T") > plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="im", col.response=col.response, swapxy=T, yflip=T, main="swapxy=T, yflip=T") > plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="im", col.response=col.response, swapxy=T, xflip=T, yflip=T, main="swapxy=T, xflip=T, yflip=T") > > # test flip args, type2=contour > plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="con", col.response=col.response, main="test flip on contour plots\nreference plot") > plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="con", col.response=col.response, swapxy=T) > plot(0, 0, type="n", axes=FALSE, xlab="", ylab="") > > plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="con", col.response=col.response, xflip=T) > plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="con", col.response=col.response, yflip=T) > plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="con", col.response=col.response, xflip=T, yflip=T) > > plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="con", col.response=col.response, swapxy=T, xflip=T) > plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="con", col.response=col.response, swapxy=T, yflip=T) > plotmo(aflip, degree1=0, degree2=2, do.par=F, type2="con", col.response=col.response, swapxy=T, xflip=T, yflip=T) > > # ordered factor > > cat("==test plotmo with ordered factor==\n") ==test plotmo with ordered factor== > par(mfcol=c(2,2)) > par(mar=c(3, 3, 3, 1)) > par(mgp=c(1.5, .5, 0)) > a <- lm(height~., data=Loblolly) > termplot(a, partial.resid=T, rug=T, terms=2, main="Seed is an ordered factor") # compare to termplot > plotmo(a, do.par=F, col.resp="gray", nrug=T, all2=T) plotmo grid: age Seed 12.5 329 > > #--------------------------------------------------------------------------- > # test ndiscrete with integer and non integer predictors, with missing values > > par(mfcol=c(2,4)) > par(mar=c(3, 3, 3, 1)) > par(mgp=c(1.5, .5, 0)) > et <- etitanic > et$var <- et$parch > et$var[et$var==1] <- 0 # want a "hole" in var's value, for testing > et$var[1:3] <- 6 > cat("table(et$var):") table(et$var):> print(table(et$var)) 0 2 3 4 5 6 927 95 8 5 6 5 > cat("\n") > a <- earth(survived~var+age, data=et, degree=2, pm="none") > > plotmo(a, trace=FALSE, ndiscrete=0, + main="integral var\n(var levels are 0 2 3 4 5 6)\nndiscrete=0", cex.lab=.8, + do.par=F, smooth.col="indianred", persp.ticktype="d", clip=F, degree1=0, persp.theta=40) > > plotmo(a, ndiscrete=0, + do.par=F, smooth.col="indianred", ylim=c(-.5,1), degree2=0, degree1=1) plotmo grid: var age 0 28 > > #------------ > plotmo(a, ndiscrete=10, main="integral var\nndiscrete=10", cex.lab=.8, + do.par=F, smooth.col="indianred", persp.ticktype="d", clip=F, degree1=0, persp.theta=40) > > plotmo(a, trace=0, ndiscrete=10, + do.par=F, smooth.col="indianred", ylim=c(-.5,1), degree2=0, degree1=1) plotmo grid: var age 0 28 > > #------------ > et$var <- et$var / 2 > cat("table(et$var):") table(et$var):> print(table(et$var)) 0 1 1.5 2 2.5 3 927 95 8 5 6 5 > cat("\n") > a <- earth(survived~var+age, data=et, degree=2, pm="none") > > plotmo(a, ndiscrete=0, + main="integral var\n(var levels are 0 1 1.5 2 2.5 3)\nndiscrete=0", cex.lab=.8, + do.par=F, smooth.col="indianred", persp.ticktype="d", clip=F, degree1=0, persp.theta=40) > > plotmo(a, ndiscrete=0, + do.par=F, smooth.col="indianred", ylim=c(-.5,1), degree2=0, degree1=1) plotmo grid: var age 0 28 > > #------------ > plotmo(a, ndiscrete=10, main="non integral var\nndiscrete=10", cex.lab=.8, + do.par=F, smooth.col="indianred", persp.ticktype="d", clip=F, degree1=0, persp.theta=40) > > plotmo(a, ndiscrete=10, + do.par=F, smooth.col="indianred", ylim=c(-.5,1), degree2=0, degree1=1) plotmo grid: var age 0 28 > > source("test.epilog.R") plotmo/inst/slowtests/test.linmod.Rout.save0000644000176200001440000041752514563614021020700 0ustar liggesusers> # test.linmod.R: test example S3 model at http://www.milbo.org/doc/linmod.R > > source("test.prolog.R") > source("linmod.R") # linear model code (http://www.milbo.org/doc/linmod.R) > source("linmod.methods.R") # additional method functions for linmod > options(warn=1) # print warnings as they occur > > almost.equal <- function(x, y, max=1e-8) + { + stopifnot(max >= 0 && max < .01) + length(x) == length(y) && max(abs(x - y)) < max + } > # check that linmod model matches reference lm model in all essential details > check.lm <- function(fit, ref, newdata=trees[3:5,], + check.coef.names=TRUE, + check.casenames=TRUE, + check.newdata=TRUE, + check.sigma=TRUE) + { + check.names <- function(fit.names, ref.names) + { + if(check.casenames && + # lm always adds rownames even if "1", "2", "3": this seems + # wasteful and not particulary helpful, so linmod doesn't do + # this, hence the first !isTRUE(all.equal) below + !isTRUE(all.equal(ref.names, paste(1:length(ref.names)))) && + !isTRUE(all.equal(fit.names, ref.names))) { + print(fit.names) + print(ref.names) + stop(deparse(substitute(fit.names)), " != ", + deparse(substitute(ref.names))) + } + } + cat0("check ", deparse(substitute(fit)), " vs ", + deparse(substitute(ref)), "\n") + + stopifnot(coef(fit) == coef(ref)) + if(check.coef.names) + stopifnot(identical(names(coef(fit)), names(coef(ref)))) + + stopifnot(identical(dim(fit$coefficients), dim(ref$coefficients))) + stopifnot(length(fit$coefficients) == length(ref$coefficients)) + stopifnot(almost.equal(fit$coefficients, ref$coefficients)) + + stopifnot(identical(dim(fit$residuals), dim(ref$residuals))) + stopifnot(length(fit$residuals) == length(ref$residuals)) + stopifnot(almost.equal(fit$residuals, ref$residuals)) + + stopifnot(identical(dim(fit$fitted.values), dim(ref$fitted.values))) + stopifnot(length(fit$fitted.values) == length(ref$fitted.values)) + stopifnot(almost.equal(fit$fitted.values, ref$fitted.values)) + + stopifnot(identical(fit$rank, ref$rank)) + + if(!is.null(fit$vcov) && !is.null(ref$vcov)) { + stopifnot(identical(dim(fit$vcov), dim(ref$vcov))) + stopifnot(length(fit$vcov) == length(ref$vcov)) + stopifnot(almost.equal(fit$vcov, ref$vcov)) + } + if(check.sigma) { + ref.sigma <- ref$sigma + if(is.null(ref.sigma)) # in lm models, sigma is only available from summary() + ref.sigma <- summary(ref)$sigma + stopifnot(almost.equal(fit$sigma, ref.sigma)) + } + stopifnot(almost.equal(fit$df.residual, ref$df.residual)) + + stopifnot(almost.equal(fitted(fit), fitted(ref))) + check.names(names(fitted(fit)), names(fitted(ref))) + + stopifnot(almost.equal(residuals(fit), residuals(ref))) + check.names(names(residuals(fit)), names(residuals(ref))) + + stopifnot(almost.equal(predict(fit), predict(ref))) + check.names(names(predict(fit)), names(predict(ref))) + if(check.newdata) { + stopifnot(almost.equal(predict(fit, newdata=newdata), + predict(ref, newdata=newdata))) + check.names(names(predict(fit, newdata=newdata)), + names(predict(ref, newdata=newdata))) + } + } > tr <- trees # trees data but with rownames > rownames(tr) <- paste("tree", 1:nrow(trees), sep="") > > linmod.form.Volume.tr <- linmod(Volume~., data=tr) > cat0("==print(summary(linmod.form.Volume.tr))\n") ==print(summary(linmod.form.Volume.tr)) > print(summary(linmod.form.Volume.tr)) Call: linmod.formula(formula = Volume ~ ., data = tr) Estimate StdErr t.value p.value (Intercept) -57.9876589 8.6382259 -6.712913 2.749507e-07 Girth 4.7081605 0.2642646 17.816084 8.223304e-17 Height 0.3392512 0.1301512 2.606594 1.449097e-02 > lm.Volume.tr <- lm(Volume~., data=tr) > check.lm(linmod.form.Volume.tr, lm.Volume.tr) check linmod.form.Volume.tr vs lm.Volume.tr > stopifnot(almost.equal(predict(linmod.form.Volume.tr, newdata=data.frame(Girth=10, Height=80)), + 16.234045, max=1e-5)) > stopifnot(almost.equal(predict(linmod.form.Volume.tr, newdata=as.matrix(tr[1:3,])), + c(4.8376597, 4.5538516, 4.8169813), max=1e-5)) > # character new data (instead of numeric) > newdata.allchar <- as.data.frame(matrix("blank", ncol=3, nrow=3)) > colnames(newdata.allchar) <- colnames(trees) > expect.err(try(predict(lm.Volume.tr, newdata=newdata.allchar)), + "variables 'Girth', 'Height' were specified with different types from the fit") Error : variables 'Girth', 'Height' were specified with different types from the fit Got expected error from try(predict(lm.Volume.tr, newdata = newdata.allchar)) > expect.err(try(predict(linmod.form.Volume.tr, newdata=newdata.allchar)), + "variables 'Girth', 'Height' were specified with different types from the fit") Error : variables 'Girth', 'Height' were specified with different types from the fit Got expected error from try(predict(linmod.form.Volume.tr, newdata = newdata.allchar)) > > linmod.xy.Volume.tr <- linmod(tr[,1:2], tr[,3,drop=FALSE]) # x=data.frame y=data.frame > cat0("==print(summary(linmod.xy.Volume.tr))\n") ==print(summary(linmod.xy.Volume.tr)) > print(summary(linmod.xy.Volume.tr)) Call: linmod.default(x = tr[, 1:2], y = tr[, 3, drop = FALSE]) Estimate StdErr t.value p.value (Intercept) -57.9876589 8.6382259 -6.712913 2.749507e-07 Girth 4.7081605 0.2642646 17.816084 8.223304e-17 Height 0.3392512 0.1301512 2.606594 1.449097e-02 > newdata.2col <- trees[3:5,1:2] > check.lm(linmod.xy.Volume.tr, lm.Volume.tr, newdata=newdata.2col) check linmod.xy.Volume.tr vs lm.Volume.tr > stopifnot(almost.equal(predict(linmod.xy.Volume.tr, newdata=data.frame(Girth=10, Height=80)), + 16.234045, max=1e-5)) > stopifnot(almost.equal(predict(linmod.xy.Volume.tr, newdata=tr[1:3,1:2]), + c(4.8376597, 4.5538516, 4.8169813), max=1e-5)) > > linmod50.xy.Volume.tr <- linmod(as.matrix(tr[,1:2]), as.matrix(tr[,3,drop=FALSE])) # x=matrix y=matrix > check.lm(linmod50.xy.Volume.tr, lm.Volume.tr, newdata=newdata.2col) check linmod50.xy.Volume.tr vs lm.Volume.tr > linmod51.xy.Volume.tr <- linmod(tr[,1:2], tr[,3]) # x=data.frame y=vector > check.lm(linmod51.xy.Volume.tr, lm.Volume.tr, newdata=newdata.2col) check linmod51.xy.Volume.tr vs lm.Volume.tr > linmod52.xy.Volume.tr <- linmod(as.matrix(tr[,1:2]), tr[,3]) # x=matrix y=vector > check.lm(linmod52.xy.Volume.tr, lm.Volume.tr, newdata=newdata.2col) check linmod52.xy.Volume.tr vs lm.Volume.tr > > # newdata can be a vector > stopifnot(almost.equal(predict(linmod.xy.Volume.tr, newdata=c(8.3, 70)), + 4.8376597, max=1e-5)) > stopifnot(almost.equal(predict(linmod.xy.Volume.tr, + newdata=c(8.3, 8.6, 70, 65)), # 4 element vector, byrow=FALSE + c(4.8376597, 4.5538516), max=1e-5)) > options(warn=1) # print warnings as they occur > # expect Warning: data length [3] is not a sub-multiple or multiple of the number of rows [2] > stopifnot(almost.equal(predict(linmod.xy.Volume.tr, newdata=c(8.3, 9, 70)), # 3 element vector + c(4.8376597, -12.7984291), max=1e-5)) Warning in matrix(newdata, ncol = length(object$coefficients) - 1) : data length [3] is not a sub-multiple or multiple of the number of rows [2] > options(warn=2) # treat warnings as errors > > stopifnot(almost.equal(predict(linmod.xy.Volume.tr, newdata=as.matrix(data.frame(Girth=10, Height=80))), + 16.234045, max=1e-5)) > # column names in newdata are ignored for linmod.default models > stopifnot(almost.equal(predict(linmod.xy.Volume.tr, newdata=data.frame(name1.not.in.orig.data=10, name2.not.in.orig.datax2=80)), + 16.234045, max=1e-5)) > # note name reversed below but names still ignored, same predict result as c(Girth=10, Height=80) > stopifnot(almost.equal(predict(linmod.xy.Volume.tr, newdata=data.frame(Height=10, Girth=80)), + 16.234045, max=1e-5)) > > cat0("==print.default(linmod.form.Volume.tr)\n") ==print.default(linmod.form.Volume.tr) > print.default(linmod.form.Volume.tr) $coefficients (Intercept) Girth Height -57.9876589 4.7081605 0.3392512 $residuals tree1 tree2 tree3 tree4 tree5 tree6 5.46234035 5.74614837 5.38301873 0.52588477 -1.06900844 -1.31832696 tree7 tree8 tree9 tree10 tree11 tree12 -0.59268807 -1.04594918 1.18697860 -0.28758128 2.18459773 -0.46846462 tree13 tree14 tree15 tree16 tree17 tree18 -0.06846462 0.79384587 -4.85410969 -5.65220290 2.21603352 -6.40648192 tree19 tree20 tree21 tree22 tree23 tree24 -4.90097760 -3.79703501 0.11181561 -4.30831896 0.91474029 -3.46899800 tree25 tree26 tree27 tree28 tree29 tree30 -2.27770232 4.45713224 3.47624891 4.87148717 -2.39932888 -2.89932888 tree31 8.48469518 $rank [1] 3 $fitted.values tree1 tree2 tree3 tree4 tree5 tree6 tree7 tree8 4.837660 4.553852 4.816981 15.874115 19.869008 21.018327 16.192688 19.245949 tree9 tree10 tree11 tree12 tree13 tree14 tree15 tree16 21.413021 20.187581 22.015402 21.468465 21.468465 20.506154 23.954110 27.852203 tree17 tree18 tree19 tree20 tree21 tree22 tree23 tree24 31.583966 33.806482 30.600978 28.697035 34.388184 36.008319 35.385260 41.768998 tree25 tree26 tree27 tree28 tree29 tree30 tree31 44.877702 50.942868 52.223751 53.428513 53.899329 53.899329 68.515305 $vcov (Intercept) Girth Height (Intercept) 74.6189461 0.43217138 -1.05076889 Girth 0.4321714 0.06983578 -0.01786030 Height -1.0507689 -0.01786030 0.01693933 $sigma [1] 3.881832 $df.residual [1] 28 $call linmod.formula(formula = Volume ~ ., data = tr) $terms Volume ~ Girth + Height attr(,"variables") list(Volume, Girth, Height) attr(,"factors") Girth Height Volume 0 0 Girth 1 0 Height 0 1 attr(,"term.labels") [1] "Girth" "Height" attr(,"order") [1] 1 1 attr(,"intercept") [1] 1 attr(,"response") [1] 1 attr(,".Environment") attr(,"predvars") list(Volume, Girth, Height) attr(,"dataClasses") Volume Girth Height "numeric" "numeric" "numeric" $xlevels named list() attr(,"class") [1] "linmod" > > cat0("==check single x variable\n") ==check single x variable > linmod1a.form <- linmod(Volume~Height, data=tr) > cat0("==print(summary(linmod1a.form))\n") ==print(summary(linmod1a.form)) > print(summary(linmod1a.form)) Call: linmod.formula(formula = Volume ~ Height, data = tr) Estimate StdErr t.value p.value (Intercept) -87.12361 29.2731221 -2.976232 0.0058346689 Height 1.54335 0.3838693 4.020509 0.0003783823 > lma.tr <- lm(Volume~Height, data=tr) > check.lm(linmod1a.form, lma.tr) check linmod1a.form vs lma.tr > > stopifnot(almost.equal(predict(linmod1a.form, newdata=data.frame(Height=80)), + 36.34437, max=1e-5)) > stopifnot(almost.equal(predict(linmod1a.form, newdata=data.frame(Girth=99, Height=80)), + 36.34437, max=1e-5)) > stopifnot(almost.equal(predict(linmod1a.form, newdata=as.matrix(tr[1:3,])), + c(20.91087, 13.19412, 10.10742), max=1e-5)) > > linmod1a.xy <- linmod(tr[,2,drop=FALSE], tr[,3]) > cat0("==print(summary(linmod1a.xy))\n") ==print(summary(linmod1a.xy)) > print(summary(linmod1a.xy)) Call: linmod.default(x = tr[, 2, drop = FALSE], y = tr[, 3]) Estimate StdErr t.value p.value (Intercept) -87.12361 29.2731221 -2.976232 0.0058346689 Height 1.54335 0.3838693 4.020509 0.0003783823 > check.lm(linmod1a.xy, lma.tr, newdata=trees[3:5,2,drop=FALSE]) check linmod1a.xy vs lma.tr > check.lm(linmod1a.xy, lma.tr, newdata=trees[3:5,2,drop=TRUE], + check.newdata=FALSE) # needed because predict.lm gives 'data' must be a data.frame, environment, or list check linmod1a.xy vs lma.tr > stopifnot(almost.equal(predict(linmod1a.xy, newdata=trees[3:5,2,drop=FALSE]), + predict(linmod1a.xy, newdata=trees[3:5,2,drop=TRUE]))) > stopifnot(almost.equal(predict(linmod1a.xy, newdata=data.frame(Height=80)), + 36.34437, max=1e-5)) > stopifnot(almost.equal(predict(linmod1a.xy, newdata=tr[1:3,2]), + c(20.91087, 13.19412, 10.10742), max=1e-5)) > stopifnot(almost.equal(predict(linmod1a.xy, newdata=as.matrix(data.frame(Height=80))), + 36.34437, max=1e-5)) > > # check that extra fields in predict newdata are ok with formula models > stopifnot(almost.equal(predict(linmod.form.Volume.tr, newdata=data.frame(Girth=10, Height=80, extra=99)), + predict(lm.Volume.tr, newdata=data.frame(Girth=10, Height=80)))) > stopifnot(almost.equal(predict(linmod.form.Volume.tr, newdata=data.frame(Girth=10, Height=80, extra=99)), + predict(lm.Volume.tr, newdata=data.frame(Girth=10, Height=80, extra=99)))) > # check that extra fields in predict newdata are not ok with x,y models > expect.err(try(predict(linmod.xy.Volume.tr, newdata=data.frame(Girth=10, Height=80, extra=99))), + "ncol(newdata) is 3 but should be 2") Error in predict.linmod(linmod.xy.Volume.tr, newdata = data.frame(Girth = 10, : ncol(newdata) is 3 but should be 2 Got expected error from try(predict(linmod.xy.Volume.tr, newdata = data.frame(Girth = 10, Height = 80, extra = 99))) > > # missing variables in newdata > expect.err(try(predict(linmod.form.Volume.tr, newdata=data.frame(Girth=10))), + "object 'Height' not found") Error in eval(predvars, data, env) : object 'Height' not found Got expected error from try(predict(linmod.form.Volume.tr, newdata = data.frame(Girth = 10))) > expect.err(try(predict(linmod.form.Volume.tr, newdata=c(8.3, 70))), + "object 'Girth' not found") Error in eval(predvars, data, env) : object 'Girth' not found Got expected error from try(predict(linmod.form.Volume.tr, newdata = c(8.3, 70))) > expect.err(try(predict(lm.Volume.tr, newdata=data.frame(Girth=10))), + "object 'Height' not found") Error in eval(predvars, data, env) : object 'Height' not found Got expected error from try(predict(lm.Volume.tr, newdata = data.frame(Girth = 10))) > expect.err(try(predict(linmod.xy.Volume.tr, newdata=data.frame(Girth=10))), + "ncol(newdata) is 1 but should be 2") Error in predict.linmod(linmod.xy.Volume.tr, newdata = data.frame(Girth = 10)) : ncol(newdata) is 1 but should be 2 Got expected error from try(predict(linmod.xy.Volume.tr, newdata = data.frame(Girth = 10))) > > # check that rownames got propagated > stopifnot(names(linmod.form.Volume.tr$residuals)[1] == "tree1") > stopifnot(names(linmod.form.Volume.tr$fitted.values)[3] == "tree3") > stopifnot(names(linmod.xy.Volume.tr$residuals)[1] == "tree1") > stopifnot(names(linmod.xy.Volume.tr$fitted.values)[3] == "tree3") > stopifnot(!is.null(names(linmod.xy.Volume.tr$residuals))) > stopifnot(!is.null(names(linmod.xy.Volume.tr$fitted.values))) > cat0("==print.default(linmod.xy.Volume.tr)\n") ==print.default(linmod.xy.Volume.tr) > print.default(linmod.xy.Volume.tr) $coefficients (Intercept) Girth Height -57.9876589 4.7081605 0.3392512 $residuals tree1 tree2 tree3 tree4 tree5 tree6 5.46234035 5.74614837 5.38301873 0.52588477 -1.06900844 -1.31832696 tree7 tree8 tree9 tree10 tree11 tree12 -0.59268807 -1.04594918 1.18697860 -0.28758128 2.18459773 -0.46846462 tree13 tree14 tree15 tree16 tree17 tree18 -0.06846462 0.79384587 -4.85410969 -5.65220290 2.21603352 -6.40648192 tree19 tree20 tree21 tree22 tree23 tree24 -4.90097760 -3.79703501 0.11181561 -4.30831896 0.91474029 -3.46899800 tree25 tree26 tree27 tree28 tree29 tree30 -2.27770232 4.45713224 3.47624891 4.87148717 -2.39932888 -2.89932888 tree31 8.48469518 $rank [1] 3 $fitted.values tree1 tree2 tree3 tree4 tree5 tree6 tree7 tree8 4.837660 4.553852 4.816981 15.874115 19.869008 21.018327 16.192688 19.245949 tree9 tree10 tree11 tree12 tree13 tree14 tree15 tree16 21.413021 20.187581 22.015402 21.468465 21.468465 20.506154 23.954110 27.852203 tree17 tree18 tree19 tree20 tree21 tree22 tree23 tree24 31.583966 33.806482 30.600978 28.697035 34.388184 36.008319 35.385260 41.768998 tree25 tree26 tree27 tree28 tree29 tree30 tree31 44.877702 50.942868 52.223751 53.428513 53.899329 53.899329 68.515305 $vcov (Intercept) Girth Height (Intercept) 74.6189461 0.43217138 -1.05076889 Girth 0.4321714 0.06983578 -0.01786030 Height -1.0507689 -0.01786030 0.01693933 $sigma [1] 3.881832 $df.residual [1] 28 $call linmod.default(x = tr[, 1:2], y = tr[, 3, drop = FALSE]) attr(,"class") [1] "linmod" > > # check that we don't artificially add rownames when no original rownames > linmod1a.xy <- linmod(trees[,1:2], trees[,3]) > stopifnot(is.null(names(linmod1a.xy$residuals))) > stopifnot(is.null(names(linmod1a.xy$fitted.values))) > > cat0("==example plots\n") ==example plots > > library(plotmo) Loading required package: Formula Loading required package: plotrix > data(trees) > > linmod.form.Volume.trees <- linmod(Volume~., data=trees) > print(linmod.form.Volume.trees) Call: linmod.formula(formula = Volume ~ ., data = trees) (Intercept) Girth Height -57.9876589 4.7081605 0.3392512 > print(summary(linmod.form.Volume.trees)) Call: linmod.formula(formula = Volume ~ ., data = trees) Estimate StdErr t.value p.value (Intercept) -57.9876589 8.6382259 -6.712913 2.749507e-07 Girth 4.7081605 0.2642646 17.816084 8.223304e-17 Height 0.3392512 0.1301512 2.606594 1.449097e-02 > > linmod1.xy <- linmod(trees[,1:2], trees[,3]) > print(linmod1.xy) Call: linmod.default(x = trees[, 1:2], y = trees[, 3]) (Intercept) Girth Height -57.9876589 4.7081605 0.3392512 > print(summary(linmod1.xy)) Call: linmod.default(x = trees[, 1:2], y = trees[, 3]) Estimate StdErr t.value p.value (Intercept) -57.9876589 8.6382259 -6.712913 2.749507e-07 Girth 4.7081605 0.2642646 17.816084 8.223304e-17 Height 0.3392512 0.1301512 2.606594 1.449097e-02 > > plotmo(linmod.form.Volume.trees) plotmo grid: Girth Height 12.9 76 > plotmo(linmod1.xy) plotmo grid: Girth Height 12.9 76 > > plotres(linmod.form.Volume.trees) > plotres(linmod1.xy) > > cat0("==test keep arg\n") ==test keep arg > > trees1 <- trees > linmod.form.Volume.trees.keep <- linmod(Volume~., data=trees1, keep=TRUE) > print(summary(linmod.form.Volume.trees.keep)) Call: linmod.formula(formula = Volume ~ ., data = trees1, keep = TRUE) Estimate StdErr t.value p.value (Intercept) -57.9876589 8.6382259 -6.712913 2.749507e-07 Girth 4.7081605 0.2642646 17.816084 8.223304e-17 Height 0.3392512 0.1301512 2.606594 1.449097e-02 > print(head(linmod.form.Volume.trees.keep$data)) Girth Height Volume 1 8.3 70 10.3 2 8.6 65 10.3 3 8.8 63 10.2 4 10.5 72 16.4 5 10.7 81 18.8 6 10.8 83 19.7 > stopifnot(dim(linmod.form.Volume.trees.keep$data) == c(nrow(trees1), ncol(trees1))) > trees1 <- NULL # destroy orginal data so plotmo has to use keep data > plotmo(linmod.form.Volume.trees.keep, pt.col=3) plotmo grid: Girth Height 12.9 76 > plotres(linmod.form.Volume.trees.keep) > > linmod.xy.keep <- linmod(trees[,1:2], trees[,3], keep=TRUE) > print(summary(linmod.xy.keep)) Call: linmod.default(x = trees[, 1:2], y = trees[, 3], keep = TRUE) Estimate StdErr t.value p.value (Intercept) -57.9876589 8.6382259 -6.712913 2.749507e-07 Girth 4.7081605 0.2642646 17.816084 8.223304e-17 Height 0.3392512 0.1301512 2.606594 1.449097e-02 > print(head(linmod.xy.keep$x)) Girth Height [1,] 8.3 70 [2,] 8.6 65 [3,] 8.8 63 [4,] 10.5 72 [5,] 10.7 81 [6,] 10.8 83 > stopifnot(dim(linmod.xy.keep$x) == c(nrow(trees), 2)) > stopifnot(class(linmod.xy.keep$x)[1] == "matrix") > print(head(linmod.xy.keep$y)) trees[,3] [1,] 10.3 [2,] 10.3 [3,] 10.2 [4,] 16.4 [5,] 18.8 [6,] 19.7 > stopifnot(dim(linmod.xy.keep$y) == c(nrow(trees), 1)) > stopifnot(class(linmod.xy.keep$y)[1] == "matrix") > linmod.xy.keep$call <- NULL # trick to force use of x and y in plotmo > plotmo(linmod.xy.keep, pt.col=3) plotmo grid: Girth Height 12.9 76 > plotres(linmod.xy.keep) > > check.lm(linmod.form.Volume.trees.keep, linmod.xy.keep, check.casenames=FALSE, check.newdata=FALSE) check linmod.form.Volume.trees.keep vs linmod.xy.keep > > cat0("==test keep arg with vector x\n") ==test keep arg with vector x > > n <- 20 > linmod.vecx.form.keep <- linmod(Volume~Height, data=trees[1:n,], keep=TRUE) > print(summary(linmod.vecx.form.keep)) Call: linmod.formula(formula = Volume ~ Height, data = trees[1:n, ], keep = TRUE) Estimate StdErr t.value p.value (Intercept) -19.3368332 11.9072601 -1.623953 0.121767815 Height 0.5318092 0.1597269 3.329491 0.003730259 > print(head(linmod.vecx.form.keep$data)) Girth Height Volume 1 8.3 70 10.3 2 8.6 65 10.3 3 8.8 63 10.2 4 10.5 72 16.4 5 10.7 81 18.8 6 10.8 83 19.7 > stopifnot(dim(linmod.vecx.form.keep$data) == c(n, ncol(trees))) > stopifnot(class(linmod.vecx.form.keep$data) == class(trees)) > plotmo(linmod.vecx.form.keep, pt.col=3) > plotres(linmod.vecx.form.keep) > > linmod.vecx.xy.keep <- linmod(trees[1:n,2], trees[1:n,3], keep=TRUE) > print(summary(linmod.vecx.xy.keep)) Call: linmod.default(x = trees[1:n, 2], y = trees[1:n, 3], keep = TRUE) Estimate StdErr t.value p.value (Intercept) -19.3368332 11.9072601 -1.623953 0.121767815 V1 0.5318092 0.1597269 3.329491 0.003730259 > print(head(linmod.vecx.xy.keep$x)) [,1] [1,] 70 [2,] 65 [3,] 63 [4,] 72 [5,] 81 [6,] 83 > stopifnot(dim(linmod.vecx.xy.keep$x) == c(n, 1)) > stopifnot(class(linmod.vecx.xy.keep$x)[1] == "matrix") > print(head(linmod.vecx.xy.keep$y)) trees[1:n,3] [1,] 10.3 [2,] 10.3 [3,] 10.2 [4,] 16.4 [5,] 18.8 [6,] 19.7 > stopifnot(dim(linmod.vecx.xy.keep$y) == c(n, 1)) > stopifnot(class(linmod.vecx.xy.keep$y)[1] == "matrix") > linmod.vecx.xy.keep$call <- NULL # trick to force use of x and y in plotmo > plotmo(linmod.vecx.xy.keep, pt.col=3) > plotres(linmod.vecx.xy.keep) > > check.lm(linmod.vecx.form.keep, linmod.vecx.xy.keep, newdata=trees[3:5,2,drop=FALSE], + check.coef.names=FALSE, check.casenames=FALSE) check linmod.vecx.form.keep vs linmod.vecx.xy.keep > > cat0("==test model building with assorted numeric args\n") ==test model building with assorted numeric args > > x <- tr[,1:2] > y <- tr[,3] > cat0("class(x)=", class(x), " class(y)=", class(y), "\n") # class(x)=data.frame class(y)=numeric class(x)=data.frame class(y)=numeric > linmod2.xy <- linmod(x, y) > check.lm(linmod2.xy, lm.Volume.tr, newdata=newdata.2col) check linmod2.xy vs lm.Volume.tr > > # check consistency with lm > expect.err(try(linmod(y~x)), "invalid type (list) for variable 'x'") Error in model.frame.default(formula = formula, data = data, na.action = na.pass) : invalid type (list) for variable 'x' Got expected error from try(linmod(y ~ x)) > expect.err(try(lm(y~x)), "invalid type (list) for variable 'x'") Error in model.frame.default(formula = y ~ x, drop.unused.levels = TRUE) : invalid type (list) for variable 'x' Got expected error from try(lm(y ~ x)) > > linmod3.xy <- linmod(as.matrix(x), as.matrix(y)) > check.lm(linmod3.xy, lm.Volume.tr, newdata=newdata.2col) check linmod3.xy vs lm.Volume.tr > > linmod4.form <- linmod(y ~ as.matrix(x)) > lm4 <- lm(y ~ as.matrix(x)) > check.lm(linmod4.form, lm4, check.newdata=FALSE) check linmod4.form vs lm4 > stopifnot(coef(linmod4.form) == coef(lm.Volume.tr), + gsub("as.matrix(x)", "", names(coef(linmod4.form)), fixed=TRUE) == names(coef(lm.Volume.tr))) > > xm <- as.matrix(x) > cat0("class(xm)=", class(xm), " class(y)=", class(y), "\n") # class(xm)=matrix class(y)=numeric class(xm)=matrixarray class(y)=numeric > linmod5.form <- linmod(y ~ xm) > lm5 <- lm(y ~ xm) > check.lm(linmod5.form, lm5, check.newdata=FALSE) check linmod5.form vs lm5 > stopifnot(coef(linmod5.form) == coef(lm.Volume.tr), + gsub("xm", "", names(coef(linmod5.form)), fixed=TRUE) == names(coef(lm.Volume.tr))) > > cat0("==test correct use of global x1 and y1, and of predict error handling\n") ==test correct use of global x1 and y1, and of predict error handling > x1 <- tr[,1] > y1 <- tr[,3] > cat0("class(x1)=", class(x1), " class(y1)=", class(y1), "\n") # class(x1)=numeric class(y1)=numeric class(x1)=numeric class(y1)=numeric > linmod.y1.x1 <- linmod(y1~x1) > lm1 <- lm(y1~x1) > linmod6.xy <- linmod(x1, y1) > > newdata.x1 <- trees[3:5,1,drop=FALSE] > colnames(newdata.x1) <- "x1" > stopifnot(almost.equal(predict(linmod.y1.x1, newdata=newdata.x1), + c(7.63607739644657, 16.24803331528098, 17.26120459984973))) > > check.lm(linmod6.xy, linmod.y1.x1, newdata=x1[3:5], + check.newdata=FALSE, # TODO needed because linmod.y1.x1 ignores newdata(!) + check.coef.names=FALSE, check.casenames=FALSE) check linmod6.xy vs linmod.y1.x1 > print(predict(linmod6.xy, newdata=x1[3:5])) [1] 7.636077 16.248033 17.261205 > stopifnot(almost.equal(predict(linmod6.xy, newdata=x1[3]), 7.63607739644657)) > > stopifnot(coef(linmod6.xy) == coef(linmod.y1.x1)) # names(coef(linmod.y1.x1) are "(Intercept)" "x1" > stopifnot(names(coef(linmod6.xy)) == c("(Intercept)", "V1")) > > # following checks some confusing behaviour of predict.lm > options(warn=2) # treat warnings as errors > expect.err(try(predict(lm1, newdata=trees[3:5,1,drop=FALSE])), + "'newdata' had 3 rows but variables found have 31 rows") Error : (converted from warning) 'newdata' had 3 rows but variables found have 31 rows Got expected error from try(predict(lm1, newdata = trees[3:5, 1, drop = FALSE])) > expect.err(try(predict(lm1, newdata=trees[3:5,1,drop=TRUE])), + "'data' must be a data.frame, environment, or list") Error in model.frame.default(Terms, newdata, na.action = na.action, xlev = object$xlevels) : 'data' must be a data.frame, environment, or list Got expected error from try(predict(lm1, newdata = trees[3:5, 1, drop = TRUE])) > > # following checks messages when missing variables in newdata > > options(warn=2) # treat warnings as errors to check that we get a warning in stats::model.frame > expect.err(try(predict(linmod.y1.x1, newdata=trees[3:5,1,drop=FALSE])), + "(converted from warning) 'newdata' had 3 rows but variables found have 31 rows") Error : (converted from warning) 'newdata' had 3 rows but variables found have 31 rows Got expected error from try(predict(linmod.y1.x1, newdata = trees[3:5, 1, drop = FALSE])) > expect.err(try(predict(lm1, newdata=trees[3:5,1,drop=FALSE])), + "(converted from warning) 'newdata' had 3 rows but variables found have 31 rows") Error : (converted from warning) 'newdata' had 3 rows but variables found have 31 rows Got expected error from try(predict(lm1, newdata = trees[3:5, 1, drop = FALSE])) > expect.err(try(predict(linmod.y1.x1, newdata=trees[3:5,1,drop=TRUE])), + "(converted from warning) 'newdata' had 3 rows but variables found have 31 rows") Error : (converted from warning) 'newdata' had 3 rows but variables found have 31 rows Got expected error from try(predict(linmod.y1.x1, newdata = trees[3:5, 1, drop = TRUE])) > > # following checks predict.linmod error messages when missing variables > # (it tries to give better error messages than predict.lm) > > options(warn=1) # print warnings as they occur to test stop() in linmod.R::process.newdata.formula > expect.err(try(predict(linmod.y1.x1, newdata=trees[3:5,1,drop=FALSE])), + "newdata has 3 rows but model.frame returned 31 rows (variable 'x1' may be missing from newdata)") Warning: 'newdata' had 3 rows but variables found have 31 rows Error in process.newdata.formula(object, newdata) : newdata has 3 rows but model.frame returned 31 rows (variable 'x1' may be missing from newdata) Got expected error from try(predict(linmod.y1.x1, newdata = trees[3:5, 1, drop = FALSE])) > expect.err(try(predict(linmod.y1.x1, newdata=trees[3:5,1,drop=TRUE])), + "newdata has 3 rows but model.frame returned 31 rows (variable 'x1' may be missing from newdata)") Warning: 'newdata' had 3 rows but variables found have 31 rows Error in process.newdata.formula(object, newdata) : newdata has 3 rows but model.frame returned 31 rows (variable 'x1' may be missing from newdata) Got expected error from try(predict(linmod.y1.x1, newdata = trees[3:5, 1, drop = TRUE])) > options(warn=2) # back to treating warnings as errors > > # test old version of linmod.R (pre Sep 2020) > # > # expect.err(try(predict(linmod.y1.x1, newdata=trees[3:5,1,drop=FALSE])), > # "variable 'x1' is missing from newdata") > # expect.err(try(predict(lm1, newdata=trees[3:5,1,drop=FALSE])), > # "(converted from warning) 'newdata' had 3 rows but variables found have 31 rows") > # expect.err(try(predict(linmod.y1.x1, newdata=trees[3:5,1,drop=TRUE])), > # "variable 'x1' is missing from newdata") > > linmod6.form <- linmod(y1~x1) > check.lm(linmod6.form, linmod.y1.x1, check.newdata=FALSE) check linmod6.form vs linmod.y1.x1 > > newdata <- trees[5:6,] > colnames(newdata) <- c("Girth", "Height", "Volume999") # doesn't matter what we call the response > stopifnot(identical(predict(linmod.form.Volume.tr, newdata=newdata), + predict(linmod.form.Volume.tr, newdata=trees[5:6,]))) > newdata <- trees[5:6,3:1] # reverse columns and their colnames > colnames(newdata) <- c("Volume", "Height", "Girth") > stopifnot(identical(predict(linmod.form.Volume.tr, newdata=newdata), + predict(linmod.form.Volume.tr, newdata=trees[5:6,]))) > newdata <- trees[5:6,2:1] # reverse columns and their colnames, delete response column > colnames(newdata) <- c("Height", "Girth") > stopifnot(identical(predict(linmod.form.Volume.tr, newdata=newdata), + predict(linmod.form.Volume.tr, newdata=trees[5:6,]))) > stopifnot(identical(predict(linmod.form.Volume.tr, newdata=as.matrix(trees[5:6,])), # allow matrix newdata + predict(linmod.form.Volume.tr, newdata=trees[5:6,]))) > newdata <- trees[5:6,] > colnames(newdata) <- c("Girth99", "Height", "Volume") > expect.err(try(predict(linmod.form.Volume.tr, newdata=newdata)), + "object 'Girth' not found") Error in eval(predvars, data, env) : object 'Girth' not found Got expected error from try(predict(linmod.form.Volume.tr, newdata = newdata)) > colnames(newdata) <- c("Girth", "Height99", "Volume") > expect.err(try(predict(linmod.form.Volume.tr, newdata=newdata)), + "object 'Height' not found") Error in eval(predvars, data, env) : object 'Height' not found Got expected error from try(predict(linmod.form.Volume.tr, newdata = newdata)) > > cat0("==check integer input (sibsp is an integer)\n") ==check integer input (sibsp is an integer) > > library(earth) # for etitanic data > data(etitanic) > tit <- etitanic[seq(1, nrow(etitanic), by=60), ] # small set of data for tests (18 cases) > tit$survived <- tit$survived != 0 # convert to logical > rownames(tit) <- paste("pas", 1:nrow(tit), sep="") > cat0(paste(colnames(tit), "=", sapply(tit, class), sep="", collapse=", "), "\n") pclass=factor, survived=logical, sex=factor, age=numeric, sibsp=integer, parch=integer > > linmod7.xy <- linmod(tit$age, tit$sibsp) > lm7 <- lm.fit(cbind(1, tit$age), tit$sibsp) > stopifnot(coef(linmod7.xy) == coef(lm7)) # coef names will differ > > linmod7.form <- linmod(sibsp~age, data=tit) > lm7.form <- lm(sibsp~age, data=tit) > check.lm(linmod7.form, lm7.form, newdata=tit[3:5,]) check linmod7.form vs lm7.form > > linmod8.xy <- linmod(tit$sibsp, tit$age) > lm8 <- lm.fit(cbind(1, tit$sibsp), tit$age) > stopifnot(coef(linmod8.xy) == coef(lm8)) # coef names will differ > > linmod8.form <- linmod(age~sibsp, data=tit) > lm8.form <- lm(age~sibsp, data=tit) > check.lm(linmod8.form, lm8.form, newdata=tit[3:5,]) check linmod8.form vs lm8.form > > # drop=FALSE so response is a data frame > linmod1a.xy <- linmod(trees[,1:2], trees[, 3, drop=FALSE]) > print(linmod1a.xy) Call: linmod.default(x = trees[, 1:2], y = trees[, 3, drop = FALSE]) (Intercept) Girth Height -57.9876589 4.7081605 0.3392512 > print(summary(linmod1a.xy)) Call: linmod.default(x = trees[, 1:2], y = trees[, 3, drop = FALSE]) Estimate StdErr t.value p.value (Intercept) -57.9876589 8.6382259 -6.712913 2.749507e-07 Girth 4.7081605 0.2642646 17.816084 8.223304e-17 Height 0.3392512 0.1301512 2.606594 1.449097e-02 > plotres(linmod1a.xy) # plot caption shows response name "Volume" > > cat0("==test model building with assorted non-numeric args\n") ==test model building with assorted non-numeric args > > library(earth) # for etitanic data > data(etitanic) > etit <- etitanic[seq(1, nrow(etitanic), by=60), ] # small set of data for tests (18 cases) > etit$survived <- etit$survived != 0 # convert to logical > rownames(etit) <- paste("pas", 1:nrow(etit), sep="") > cat0(paste(colnames(etit), "=", sapply(etit, class), sep="", collapse=", "), "\n") pclass=factor, survived=logical, sex=factor, age=numeric, sibsp=integer, parch=integer > > lm9 <- lm(survived~., data=etit) > linmod9.form <- linmod(survived~., data=etit) > check.lm(linmod9.form, lm9, newdata=etit[3:5,]) check linmod9.form vs lm9 > > # change class of pclass to numeric > etit.pclass.numeric <- etit > etit.pclass.numeric$pclass <- as.numeric(etit$pclass) > expect.err(try(predict(lm9, newdata=etit.pclass.numeric)), + "(converted from warning) variable 'pclass' is not a factor") Error in model.frame.default(Terms, newdata, na.action = na.action, xlev = object$xlevels) : (converted from warning) variable 'pclass' is not a factor Got expected error from try(predict(lm9, newdata = etit.pclass.numeric)) > expect.err(try(predict(linmod9.form, newdata=etit.pclass.numeric)), + "(converted from warning) variable 'pclass' is not a factor") Error in model.frame.default(terms, newdata, na.action = na.pass, xlev = object$xlevels) : (converted from warning) variable 'pclass' is not a factor Got expected error from try(predict(linmod9.form, newdata = etit.pclass.numeric)) > > # change class of age to factor > etit.age.factor <- etit > etit.age.factor$age <- etit$pclass > expect.err(try(predict(lm9, newdata=etit.age.factor)), + "variable 'age' was fitted with type \"numeric\" but type \"factor\" was supplied") Error : variable 'age' was fitted with type "numeric" but type "factor" was supplied Got expected error from try(predict(lm9, newdata = etit.age.factor)) > expect.err(try(predict(linmod9.form, newdata=etit.age.factor)), + "variable 'age' was fitted with type \"numeric\" but type \"factor\" was supplied") Error : variable 'age' was fitted with type "numeric" but type "factor" was supplied Got expected error from try(predict(linmod9.form, newdata = etit.age.factor)) > > # predict for formula model ignores extra column(s) in newdata > etit.extra.col <- etit > etit.extra.col$extra <- etit$sibsp > stopifnot(identical(predict(lm9, newdata=etit), predict(lm9, newdata=etit.extra.col))) > stopifnot(identical(predict(linmod9.form, newdata=etit), predict(linmod9.form, newdata=etit.extra.col))) > etit.extra.col$extra2 <- etit$sibsp > stopifnot(identical(predict(lm9, newdata=etit), predict(lm9, newdata=etit.extra.col))) > stopifnot(identical(predict(linmod9.form, newdata=etit), predict(linmod9.form, newdata=etit.extra.col))) > > # predict for formula model doesn't care if columns in different order > etit.different.col.order <- etit[,ncol(etit):1] # reverse order of columns > stopifnot(identical(predict(lm9, newdata=etit), predict(lm9, newdata=etit.different.col.order))) > stopifnot(identical(predict(linmod9.form, newdata=etit), predict(linmod9.form, newdata=etit.different.col.order))) > > # linmod.default, non numeric x (factors in x) > expect.err(try(linmod(etit[c(1,3,4,5,6)], etit[,"survived"])), + "non-numeric column in 'x'") Error in check.linmod.x(x) : non-numeric column in 'x' Got expected error from try(linmod(etit[c(1, 3, 4, 5, 6)], etit[, "survived"])) > expect.err(try(linmod.fit(etit[c(1,3,4,5,6)], etit[,"survived"])), + "'x' is not a matrix or could not be converted to a matrix") Error in check.linmod.x(x) : 'x' is not a matrix or could not be converted to a matrix Got expected error from try(linmod.fit(etit[c(1, 3, 4, 5, 6)], etit[, "survived"])) > # lousy error message from lm.fit > expect.err(try(lm.fit(etit[,c(1,3,4,5,6)], etit[,"survived"])), + "INTEGER() can only be applied to a 'integer', not a 'NULL'") Error in lm.fit(etit[, c(1, 3, 4, 5, 6)], etit[, "survived"]) : INTEGER() can only be applied to a 'integer', not a 'NULL' Got expected error from try(lm.fit(etit[, c(1, 3, 4, 5, 6)], etit[, "survived"])) > > expect.err(try(linmod(data.matrix(cbind("(Intercept)"=1, etit[,c(1,3,4,5,6)])), etit[,"survived"])), + "column name \"(Intercept)\" in 'x' is duplicated") Error in check.linmod.x(x) : column name "(Intercept)" in 'x' is duplicated Got expected error from try(linmod(data.matrix(cbind(`(Intercept)` = 1, etit[, c(1, 3, 4, 5, 6)])), etit[, "survived"])) > linmod9a.xy <- linmod(data.matrix(etit[,c(1,3,4,5,6)]), etit[,"survived"]) > lm9.fit <- lm.fit(data.matrix(cbind("(Intercept)"=1, etit[,c(1,3,4,5,6)])), etit[,"survived"]) > stopifnot(coef(linmod9a.xy) == coef(lm9.fit)) > stopifnot(names(coef(linmod9a.xy)) == names(coef(lm9.fit))) > expect.err(try(predict(linmod9a.xy, newdata=etit.age.factor[,c(1,3,4,5,6)])), "non-numeric column in 'newdata'") Error in predict.linmod(linmod9a.xy, newdata = etit.age.factor[, c(1, : non-numeric column in 'newdata' (after processing) Got expected error from try(predict(linmod9a.xy, newdata = etit.age.factor[, c(1, 3, 4, 5, 6)])) > expect.err(try(predict(linmod9a.xy, newdata=etit[,c(1,3,4,5)])), "ncol(newdata) is 4 but should be 5") Error in predict.linmod(linmod9a.xy, newdata = etit[, c(1, 3, 4, 5)]) : ncol(newdata) is 4 but should be 5 Got expected error from try(predict(linmod9a.xy, newdata = etit[, c(1, 3, 4, 5)])) > expect.err(try(predict(linmod9a.xy, newdata=etit[,c(1,3,4,5,6,6)])), "ncol(newdata) is 6 but should be 5") Error in predict.linmod(linmod9a.xy, newdata = etit[, c(1, 3, 4, 5, 6, : ncol(newdata) is 6 but should be 5 Got expected error from try(predict(linmod9a.xy, newdata = etit[, c(1, 3, 4, 5, 6, 6)])) > > # linmod.formula, logical response > data.logical.response <- data.frame(etit[1:6,c("age","sibsp","parch")], response=c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE)) > linmod9b.form <- linmod(response~., data=data.logical.response) > print(linmod9b.form) Call: linmod.formula(formula = response ~ ., data = data.logical.response) (Intercept) age sibsp parch 1.102508872 -0.007261985 -0.182883049 -0.569470942 > lm9b.form <- lm(response~., data=data.logical.response) > check.lm(linmod9b.form, lm9b.form, newdata=data.logical.response[2,,drop=FALSE]) check linmod9b.form vs lm9b.form > > # linmod.formula, factor response (not allowed) > data.fac.response <- data.frame(etit[1:6,c("age","sibsp","parch")], response=factor(c("a", "a", "b", "a", "b", "b"))) > expect.err(try(linmod(response~., data=data.fac.response)), "'y' is not numeric or logical") Error in check.linmod.y(x, y) : 'y' is not numeric or logical Got expected error from try(linmod(response ~ ., data = data.fac.response)) > # lm.formula > expect.err(try(lm(response~., data=data.fac.response)), + "(converted from warning) using type = \"numeric\" with a factor response will be ignored") Error in model.response(mf, "numeric") : (converted from warning) using type = "numeric" with a factor response will be ignored Got expected error from try(lm(response ~ ., data = data.fac.response)) > > # linmod.formula, string response (not allowed) > data.string.response <- data.frame(etit[1:6,c("age","sibsp","parch")], response=c("a", "a", "b", "a", "b", "b")) > expect.err(try(linmod(response~., data=data.string.response)), "'y' is not numeric or logical") Error in check.linmod.y(x, y) : 'y' is not numeric or logical Got expected error from try(linmod(response ~ ., data = data.string.response)) > # lm.formula > expect.err(try(lm(response~., data=data.string.response)), + "(converted from warning) NAs introduced by coercion") Error in storage.mode(v) <- "double" : (converted from warning) NAs introduced by coercion Got expected error from try(lm(response ~ ., data = data.string.response)) > > # linmod.default, logical response > linmod9b.xy <- linmod(etit[1:6,c("age","sibsp","parch")], c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE)) > print(linmod9b.xy) Call: linmod.default(x = etit[1:6, c("age", "sibsp", "parch")], y = c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE)) (Intercept) age sibsp parch 1.102508872 -0.007261985 -0.182883049 -0.569470942 > # lm.fit, logical response (lousy error message from lm.fit) > expect.err(try(lm.fit(etit[1:6,c("age","sibsp","parch")], c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE))), + "INTEGER() can only be applied to a 'integer', not a 'NULL'") Error in lm.fit(etit[1:6, c("age", "sibsp", "parch")], c(TRUE, TRUE, FALSE, : INTEGER() can only be applied to a 'integer', not a 'NULL' Got expected error from try(lm.fit(etit[1:6, c("age", "sibsp", "parch")], c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE))) > # linmod.default, factor response > expect.err(try(linmod(etit[1:6,c("age","sibsp","parch")], factor(c("a", + "a", "b", "a", "b", "b")))), "'y' is not numeric or logical") Error in check.linmod.y(x, y) : 'y' is not numeric or logical Got expected error from try(linmod(etit[1:6, c("age", "sibsp", "parch")], factor(c("a", "a", "b", "a", "b", "b")))) > # linmod.default, string response > expect.err(try(linmod(etit[1:6,c("age","sibsp","parch")], c("a", + "a", "b", "a", "b", "b"))), "'y' is not numeric or logical") Error in check.linmod.y(x, y) : 'y' is not numeric or logical Got expected error from try(linmod(etit[1:6, c("age", "sibsp", "parch")], c("a", "a", "b", "a", "b", "b"))) > # lm.fit, string and factor responses (lousy error messages from lm.fit) > expect.err(try(lm.fit(etit[1:6,c("age","sibsp","parch")], factor(c("a", + "a", "b", "a", "b", "b")))), "INTEGER() can only be applied to a 'integer', not a 'NULL'") Error in lm.fit(etit[1:6, c("age", "sibsp", "parch")], factor(c("a", "a", : INTEGER() can only be applied to a 'integer', not a 'NULL' Got expected error from try(lm.fit(etit[1:6, c("age", "sibsp", "parch")], factor(c("a", "a", "b", "a", "b", "b")))) > expect.err(try(lm.fit(etit[1:6,c("age","sibsp","parch")], c("a", + "a", "b", "a", "b", "b"))), "INTEGER() can only be applied to a 'integer', not a 'NULL'") Error in lm.fit(etit[1:6, c("age", "sibsp", "parch")], c("a", "a", "b", : INTEGER() can only be applied to a 'integer', not a 'NULL' Got expected error from try(lm.fit(etit[1:6, c("age", "sibsp", "parch")], c("a", "a", "b", "a", "b", "b"))) > > options(warn=2) # treat warnings as errors > expect.err(try(lm(pclass~., data=etit)), "using type = \"numeric\" with a factor response will be ignored") Error in model.response(mf, "numeric") : (converted from warning) using type = "numeric" with a factor response will be ignored Got expected error from try(lm(pclass ~ ., data = etit)) > expect.err(try(linmod(pclass~., data=etit)), "'y' is not numeric or logical") Error in check.linmod.y(x, y) : 'y' is not numeric or logical Got expected error from try(linmod(pclass ~ ., data = etit)) > > options(warn=1) # print warnings as they occur > lm10 <- lm(pclass~., data=etit) # will give warnings Warning in model.response(mf, "numeric") : using type = "numeric" with a factor response will be ignored Warning in Ops.factor(y, z$residuals) : '-' not meaningful for factors > options(warn=2) # treat warnings as errors > linmod10.form <- linmod(as.numeric(pclass)~., data=etit) > stopifnot(coef(linmod10.form) == coef(lm10)) > stopifnot(names(coef(linmod10.form)) == names(coef(lm10))) > # check.lm(linmod10.form, lm10) # fails because lm10 fitted is all NA > > expect.err(try(linmod(pclass~., data=etit)), "'y' is not numeric or logical") Error in check.linmod.y(x, y) : 'y' is not numeric or logical Got expected error from try(linmod(pclass ~ ., data = etit)) > expect.err(try(linmod(etit[,-1], etit[,1])), "non-numeric column in 'x'") Error in check.linmod.x(x) : non-numeric column in 'x' Got expected error from try(linmod(etit[, -1], etit[, 1])) > expect.err(try(linmod(1:10, paste(1:10))), "'y' is not numeric or logical") Error in check.linmod.y(x, y) : 'y' is not numeric or logical Got expected error from try(linmod(1:10, paste(1:10))) > > linmod10a.form <- linmod(survived~pclass, data=etit) > lm10a <- lm(survived~pclass, data=etit) > check.lm(linmod10a.form, lm10a, newdata=etit[3:5,]) check linmod10a.form vs lm10a > > expect.err(try(linmod(etit[,"pclass"], etit[,"age"])), "non-numeric column in 'x'") Error in check.linmod.x(x) : non-numeric column in 'x' Got expected error from try(linmod(etit[, "pclass"], etit[, "age"])) > > expect.err(try(linmod(paste(1:10), 1:10)), "non-numeric column in 'x'") Error in check.linmod.x(x) : non-numeric column in 'x' Got expected error from try(linmod(paste(1:10), 1:10)) > > lm11 <- lm(as.numeric(pclass)~., data=etit) > linmod11.form <- linmod(as.numeric(pclass)~., data=etit) > check.lm(linmod11.form, lm11, newdata=etit[3:5,]) check linmod11.form vs lm11 > > # logical data (not numeric) > bool.data <- data.frame(x=rep(c(TRUE, FALSE, TRUE), length.out=10), + y=rep(c(TRUE, FALSE, FALSE), length.out=10)) > lm12 <- lm(y~x, data=bool.data) > linmod12.form <- linmod(y~x, data=bool.data) > check.lm(linmod12.form, lm12, newdata=bool.data[3:5,1], + check.newdata=FALSE) # needed because predict.lm gives invalid type (list) for variable 'x' check linmod12.form vs lm12 > linmod12.xy <- linmod(bool.data$x, bool.data$y) > # hack: delete mismatching names so check.lm() doesn't fail > names(lm12$coefficients) <- NULL # were "(Intercept)" "xTRUE" > names(linmod12.xy$coefficients) <- NULL # were "(Intercept)" "V1" > check.lm(linmod12.xy, lm12, newdata=bool.data[3:5,1], + check.newdata=FALSE, # needed because predict.lm gives invalid 'envir' argument of type 'logical' + check.casenames=FALSE) check linmod12.xy vs lm12 > > cat0("==check use of functions in arguments to linmod\n") ==check use of functions in arguments to linmod > > identfunc <- function(x) x > lm10 <- lm( sqrt(survived) ~ I(age^2) + as.numeric(sex), data=identfunc(etit)) > linmod10 <- linmod(sqrt(survived) ~ I(age^2) + as.numeric(sex), data=identfunc(etit)) > print(summary(lm10)) Call: lm(formula = sqrt(survived) ~ I(age^2) + as.numeric(sex), data = identfunc(etit)) Residuals: Min 1Q Median 3Q Max -0.6959 -0.2665 -0.2302 0.3427 0.8261 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 1.101e+00 4.223e-01 2.608 0.0198 * I(age^2) -5.389e-05 1.190e-04 -0.453 0.6571 as.numeric(sex) -3.881e-01 2.508e-01 -1.547 0.1426 --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 0.4855 on 15 degrees of freedom Multiple R-squared: 0.1736, Adjusted R-squared: 0.06346 F-statistic: 1.576 on 2 and 15 DF, p-value: 0.2392 > print(summary(linmod10)) Call: linmod.formula(formula = sqrt(survived) ~ I(age^2) + as.numeric(sex), data = identfunc(etit)) Estimate StdErr t.value p.value (Intercept) 1.101499e+00 0.4223245953 2.6081808 0.01977424 I(age^2) -5.389047e-05 0.0001189838 -0.4529226 0.65708686 as.numeric(sex) -3.880912e-01 0.2507927081 -1.5474582 0.14258876 > check.lm(linmod10, lm10, newdata=etit[3:5,]) check linmod10 vs lm10 > set.seed(2020) > plotmo(lm10, pt.col="green", do.par=2) plotmo grid: age sex 32.5 male > set.seed(2020) > plotmo(linmod10, pt.col="green", do.par=0) plotmo grid: age sex 32.5 male > par(org.par) > > cat0("==data.frame with strings\n") ==data.frame with strings > > df.with.string <- + data.frame(1:5, + c(1,2,-1,4,5), + c("a", "b", "a", "a", "b"), + stringsAsFactors=FALSE) > colnames(df.with.string) <- c("num1", "num2", "string") > > linmod30.form <- linmod(num1~num2, df.with.string) > lm30 <- lm(num1~num2, df.with.string) > check.lm(linmod30.form, lm30, check.newdata=FALSE) check linmod30.form vs lm30 > > linmod31.form <- linmod(num1~., df.with.string) > lm31 <- lm(num1~., df.with.string) > check.lm(linmod31.form, lm31, check.newdata=FALSE) check linmod31.form vs lm31 > > expect.err(try(linmod(string~., df.with.string)), "'y' is not numeric or logical") Error in check.linmod.y(x, y) : 'y' is not numeric or logical Got expected error from try(linmod(string ~ ., df.with.string)) > > vec <- c(1,2,3,4,3) > expect.err(try(linmod(df.with.string, vec)), "non-numeric column in 'x'") Error in check.linmod.x(x) : non-numeric column in 'x' Got expected error from try(linmod(df.with.string, vec)) > expect.err(try(linmod(etit$pclass, etit$survived)), "non-numeric column in 'x'") Error in check.linmod.x(x) : non-numeric column in 'x' Got expected error from try(linmod(etit$pclass, etit$survived)) > > cat0("==x is singular\n") ==x is singular > > set.seed(1) > x2 <- matrix(rnorm(6), nrow=2) > y2 <- c(1,2) > expect.err(try(linmod(y2~x2)), "'x' is singular (it has 4 columns but its rank is 2)") Error in do.linmod.fit(x, y) : 'x' is singular (it has 4 columns but its rank is 2) colnames(x): (Intercept) x21 x22 x23 Got expected error from try(linmod(y2 ~ x2)) > > x3 <- matrix(1:10, ncol=2) > y3 <- c(1,2,9,4,5) > expect.err(try(linmod(y3~x3)), "'x' is singular (it has 3 columns but its rank is 2)") Error in do.linmod.fit(x, y) : 'x' is singular (it has 3 columns but its rank is 2) colnames(x): (Intercept) x31 x32 Got expected error from try(linmod(y3 ~ x3)) > > expect.err(try(linmod(trees[1,1:2], trees[1,3])), "'x' is singular (it has 3 columns but its rank is 1)") Error in do.linmod.fit(x, y) : 'x' is singular (it has 3 columns but its rank is 1) colnames(x): (Intercept) Girth Height Got expected error from try(linmod(trees[1, 1:2], trees[1, 3])) > > x2a <- matrix(1:6, nrow=3) > y2a <- c(1,2,3) > expect.err(try(linmod(y2a~x2a)), "'x' is singular (it has 3 columns but its rank is 2)") Error in do.linmod.fit(x, y) : 'x' is singular (it has 3 columns but its rank is 2) colnames(x): (Intercept) x2a1 x2a2 Got expected error from try(linmod(y2a ~ x2a)) > > cat0("==perfect fit (residuals are zero)\n") ==perfect fit (residuals are zero) > > set.seed(1) > x2b <- matrix(rnorm(6), nrow=3) > y2b <- c(1,2,3) > data.x2b <- data.frame(x2b, y2b) > colnames(data.x2b) <- c("x1", "x2", "y") > linmod.x2b <- linmod(y~., data=data.x2b) > print(summary(linmod.x2b)) # will have "Residual degrees-of-freedom is zero" comment Call: linmod.formula(formula = y ~ ., data = data.x2b) Estimate StdErr t.value p.value (Intercept) 2.28088400 Inf 0 0 x1 -0.05211945 Inf 0 0 x2 -0.82338760 Inf 0 0 > lm.x2b <- lm(y~., data=data.x2b) > print(summary(lm.x2b)) # will have "ALL 3 residuals are 0" comment Call: lm(formula = y ~ ., data = data.x2b) Residuals: ALL 3 residuals are 0: no residual degrees of freedom! Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 2.28088 NaN NaN NaN x1 -0.05212 NaN NaN NaN x2 -0.82339 NaN NaN NaN Residual standard error: NaN on 0 degrees of freedom Multiple R-squared: 1, Adjusted R-squared: NaN F-statistic: NaN on 2 and 0 DF, p-value: NA > check.lm(linmod.x2b, lm.x2b, newdata=data.x2b[1:2,]+1, check.sigma=FALSE) check linmod.x2b vs lm.x2b > > x2c <- 1:10 > y2c <- 11:20 > data.x2c <- data.frame(x2c, y2c) > colnames(data.x2c) <- c("x", "y") > linmod.x2c <- linmod(y~., data=data.x2c) > print(summary(linmod.x2c)) Call: linmod.formula(formula = y ~ ., data = data.x2c) Estimate StdErr t.value p.value (Intercept) 10 0 Inf 0 x 1 0 Inf 0 > lm.x2c <- lm(y~., data=data.x2c) > options(warn=1) # print warnings as they occur > print(summary(lm.x2c)) # will have "essentially perfect fit: summary may be unreliable" comment Warning in summary.lm(lm.x2c) : essentially perfect fit: summary may be unreliable Call: lm(formula = y ~ ., data = data.x2c) Residuals: Min 1Q Median 3Q Max -3.635e-15 -3.541e-16 3.225e-16 9.411e-16 1.721e-15 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 1.000e+01 1.100e-15 9.088e+15 <2e-16 *** x 1.000e+00 1.773e-16 5.639e+15 <2e-16 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 1.611e-15 on 8 degrees of freedom Multiple R-squared: 1, Adjusted R-squared: 1 F-statistic: 3.18e+31 on 1 and 8 DF, p-value: < 2.2e-16 > options(warn=2) # treat warnings as errors > check.lm(linmod.x2c, lm.x2c, newdata=data.x2c[1:2,]+1, check.sigma=FALSE) check linmod.x2c vs lm.x2c > > par(mfrow=c(2,2)) # all plots on same page so can compare > plot(linmod.x2b, main="linmod.x2b\nall residuals are zero") > plot(lm.x2b, which=1, main="lm.x2b") > plot(linmod.x2c, main="linmod.x2c") > plot(lm.x2c, which=1, main="lm.x2c") > par(org.par) > > cat0("==nrow(x) does not match length(y)\n") ==nrow(x) does not match length(y) > > x4 <- matrix(1:10, ncol=2) > y4 <- c(1,2,9,4) > expect.err(try(linmod(x4, y4)), "nrow(x) is 5 but length(y) is 4") Error in check.linmod.y(x, y) : nrow(x) is 5 but length(y) is 4 Got expected error from try(linmod(x4, y4)) > > x5 <- matrix(1:10, ncol=2) > y5 <- c(1,2,9,4,5,9) > expect.err(try(linmod(x5, y5)), "nrow(x) is 5 but length(y) is 6") Error in check.linmod.y(x, y) : nrow(x) is 5 but length(y) is 6 Got expected error from try(linmod(x5, y5)) > > cat0("==y has multiple columns\n") ==y has multiple columns > > vec <- c(1,2,3,4,3) > y2 <- cbind(c(1,2,3,4,9), vec^2) > expect.err(try(linmod(vec, y2)), "nrow(x) is 5 but length(y) is 10") Error in check.linmod.y(x, y) : nrow(x) is 5 but length(y) is 10 Got expected error from try(linmod(vec, y2)) > expect.err(try(linmod(y2~vec)), "nrow(x) is 5 but length(y) is 10") Error in check.linmod.y(x, y) : nrow(x) is 5 but length(y) is 10 Got expected error from try(linmod(y2 ~ vec)) > > cat0("==NA in x\n") ==NA in x > > x <- tr[,1:2] > y <- tr[,3] > x[2,2] <- NA > expect.err(try(linmod(x, y)), "NA in 'x'") Error in check.linmod.x(x) : NA in 'x' Got expected error from try(linmod(x, y)) > > x <- tr[,1:2] > y <- tr[,3] > y[9] <- NA > expect.err(try(linmod(x, y)), "NA in 'y'") Error in check.linmod.y(x, y) : NA in 'y' Got expected error from try(linmod(x, y)) > > # Following added Sep 2020 (prior to this, predict.linmod gave an incorrect error message) > cat0("==test formulas that use functions on rhs variables, like Volume~sqrt(Girth)\n") ==test formulas that use functions on rhs variables, like Volume~sqrt(Girth) > > linmod.sqrt1 <- linmod(Volume~sqrt(as.numeric(Girth)), data=tr) > cat0("==print(summary(linmod.sqrt1))\n") ==print(summary(linmod.sqrt1)) > print(summary(linmod.sqrt1)) Call: linmod.formula(formula = Volume ~ sqrt(as.numeric(Girth)), data = tr) Estimate StdErr t.value p.value (Intercept) -103.40058 7.706018 -13.41816 5.733634e-14 sqrt(as.numeric(Girth)) 36.94188 2.117135 17.44900 6.396229e-17 > lm.sqrt1 <- lm(Volume~sqrt(as.numeric(Girth)), data=tr) > check.lm(linmod.sqrt1, lm.sqrt1) check linmod.sqrt1 vs lm.sqrt1 > stopifnot(almost.equal(predict(linmod.sqrt1, newdata=data.frame(Girth=10, Height=80)), + predict(lm.sqrt1, newdata=data.frame(Girth=10, Height=80)))) > stopifnot(almost.equal(predict(linmod.sqrt1, newdata=as.matrix(tr[1:3,])), + predict(lm.sqrt1, newdata=tr[1:3,]))) > par(mfrow=c(2,2)) # all plots on same page so can compare > plotmo(linmod.sqrt1, do.par=FALSE) > plotmo(lm.sqrt1, do.par=FALSE) > par(org.par) > > linmod.sqrt2 <- linmod(Volume~sqrt(Girth)+Height+Girth, data=tr) > cat0("==print(summary(linmod.sqrt2))\n") ==print(summary(linmod.sqrt2)) > print(summary(linmod.sqrt2)) Call: linmod.formula(formula = Volume ~ sqrt(Girth) + Height + Girth, data = tr) Estimate StdErr t.value p.value (Intercept) 132.4266671 33.03008713 4.009274 4.318421e-04 sqrt(Girth) -106.5505058 18.19173301 -5.857084 3.085730e-06 Height 0.4030722 0.08863082 4.547765 1.026574e-04 Girth 19.0489443 2.45495604 7.759383 2.410443e-08 > lm.sqrt2 <- lm(Volume~sqrt(Girth)+Height+Girth, data=tr) > check.lm(linmod.sqrt2, lm.sqrt2) check linmod.sqrt2 vs lm.sqrt2 > stopifnot(almost.equal(predict(linmod.sqrt2, newdata=data.frame(Girth=10, Height=80)), + predict(lm.sqrt2, newdata=data.frame(Girth=10, Height=80)))) > stopifnot(almost.equal(predict(linmod.sqrt2, newdata=as.matrix(tr[1:3,])), + predict(lm.sqrt2, newdata=tr[1:3,]))) > par(mfrow=c(2,2)) # all plots on same page so can compare > plotmo(linmod.sqrt2, do.par=FALSE) plotmo grid: Girth Height 12.9 76 > plotmo(lm.sqrt2, do.par=FALSE) plotmo grid: Girth Height 12.9 76 > par(org.par) > > lm.sqrt.as.numeric <- lm(survived~sqrt(age)+as.numeric(pclass), data=etit) > linmod.sqrt.as.numeric <- linmod(survived~sqrt(age)+as.numeric(pclass), data=etit) > check.lm(linmod.sqrt.as.numeric, lm.sqrt.as.numeric, newdata=etit[3:5,]) check linmod.sqrt.as.numeric vs lm.sqrt.as.numeric > expect.err(try(predict(linmod.sqrt.as.numeric, newdata=data.frame(age=30))), # pclass missing + "object 'pclass' not found") Error in eval(predvars, data, env) : object 'pclass' not found Got expected error from try(predict(linmod.sqrt.as.numeric, newdata = data.frame(age = 30))) > par(mfrow=c(2,2)) # all plots on same page so can compare > plotmo(linmod.sqrt.as.numeric, do.par=FALSE) plotmo grid: age pclass 32.5 3rd > plotmo(lm.sqrt.as.numeric, do.par=FALSE) plotmo grid: age pclass 32.5 3rd > par(org.par) > > y.age <- etit[,"age"] > x.pclass <- etit[,"pclass"] > x.sex <- etit[,"sex"] > linmod.y.age.sex.pclass <- linmod(y.age ~ as.numeric(x.pclass) + x.sex) > lm.y.age.sex.pclass <- lm( y.age ~ as.numeric(x.pclass) + x.sex) > stopifnot(identical(linmod.y.age.sex.pclass$coef, lm.y.age.sex.pclass$coef)) > options(warn=1) # print warnings as they occur to test stop() in linmod.R::process.newdata.formula > # TODO following says variable 'as.numeric(x.pclass)' may be missing > # it should say variable 'x.pclass' may be missing > expect.err(try(predict(linmod.y.age.sex.pclass, newdata=etit[3:5,1,drop=FALSE])), + "newdata has 3 rows but model.frame returned 18 rows (variable 'as.numeric(x.pclass)' may be missing from newdata)") Warning: 'newdata' had 3 rows but variables found have 18 rows Error in process.newdata.formula(object, newdata) : newdata has 3 rows but model.frame returned 18 rows (variable 'as.numeric(x.pclass)' may be missing from newdata) Got expected error from try(predict(linmod.y.age.sex.pclass, newdata = etit[3:5, 1, drop = FALSE])) > options(warn=2) # back to treating warnings as errors > > cat0("==misc tests with different kinds of data\n") ==misc tests with different kinds of data > > data3 <- data.frame(s=c("a", "b", "a", "c", "a"), num=c(1,5,1,9,2), y=c(1,3,2,5,3), stringsAsFactors=F) > stopifnot(sapply(data3, class) == c("character", "numeric", "numeric")) > a40 <- linmod(y~., data=data3) > print(summary(a40)) Call: linmod.formula(formula = y ~ ., data = data3) Estimate StdErr t.value p.value (Intercept) -1.390219e-15 1.2247449 -1.135109e-15 1.0000000 sb -4.500000e+00 3.2787193 -1.372487e+00 0.4008582 sc -8.500000e+00 6.6895441 -1.270640e+00 0.4244770 num 1.500000e+00 0.8660254 1.732051e+00 0.3333333 > stopifnot(almost.equal(a40$coefficients, c(0, -4.5, -8.5, 1.5), max=0.001)) > stopifnot(almost.equal(predict(a40, newdata=data3[2:3,]), + c(3.0, 1.5), max=0.001)) > > data4 <- data.frame(s=c("a", "b", "a", "c", "a"), num=c(1,5,1,9,2), y=c(1,3,2,5,3), stringsAsFactors=T) > stopifnot(sapply(data4, class) == c("factor", "numeric", "numeric")) > expect.err(try(linmod(data4[,1:2], data4[,3])), "non-numeric column in 'x'") Error in check.linmod.x(x) : non-numeric column in 'x' Got expected error from try(linmod(data4[, 1:2], data4[, 3])) > > # following gives no error (and matches lm) even though col 1 of data3 is character not factor > a41 <- linmod(y~., data=data4) > print(summary(a41)) Call: linmod.formula(formula = y ~ ., data = data4) Estimate StdErr t.value p.value (Intercept) -1.390219e-15 1.2247449 -1.135109e-15 1.0000000 sb -4.500000e+00 3.2787193 -1.372487e+00 0.4008582 sc -8.500000e+00 6.6895441 -1.270640e+00 0.4244770 num 1.500000e+00 0.8660254 1.732051e+00 0.3333333 > stopifnot(almost.equal(predict(a41, newdata=data3[2:3,]), + c(3.0, 1.5), max=0.001)) > > data5 <- data.frame(s=c("a", "b", "c", "a", "a"), num=c(1,9,4,2,6), y=c(1,2,3,5,3), stringsAsFactors=F) > stopifnot(almost.equal(predict(a41, newdata=data5[1:3,1:2]), + c(1.5, 9.0, -2.5), max=0.001)) > > data6 <- data.frame(s=c("a", "b", "c", "a9", "a"), + num=c(1,9,4,2,6), + num2=c(1,9,4,2,7), + y=c(1,2,3,5,3), stringsAsFactors=T) > expect.err(try(predict(a41, newdata=data6[1:3,1])), "object 's' not found") Error in eval(predvars, data, env) : object 's' not found Got expected error from try(predict(a41, newdata = data6[1:3, 1])) > expect.err(try(predict(a41, newdata=data6[1:3,c(1,1)])), "object 'num' not found") Error in eval(predvars, data, env) : object 'num' not found Got expected error from try(predict(a41, newdata = data6[1:3, c(1, 1)])) > > expect.err(try(predict(a41, newdata=data.frame(s=1, num=2, y=3))), "variable 's' is not a factor") Error in model.frame.default(terms, newdata, na.action = na.pass, xlev = object$xlevels) : (converted from warning) variable 's' is not a factor Got expected error from try(predict(a41, newdata = data.frame(s = 1, num = 2, y = 3))) > > expect.err(try(predict(a41, newdata=1:9)), + "object 's' not found") Error in eval(predvars, data, env) : object 's' not found Got expected error from try(predict(a41, newdata = 1:9)) > > expect.err(try(predict(a41, newdata=data.frame())), "'newdata' is empty") Error in predict.linmod(a41, newdata = data.frame()) : 'newdata' is empty Got expected error from try(predict(a41, newdata = data.frame())) > > # perfect fit (residuals are all zero) > linmod.data6 <- linmod(y~s+num, data=data6) > print(summary(linmod.data6)) Call: linmod.formula(formula = y ~ s + num, data = data6) Estimate StdErr t.value p.value (Intercept) 0.6 Inf 0 0 sa9 3.6 Inf 0 0 sb -2.2 Inf 0 0 sc 0.8 Inf 0 0 num 0.4 Inf 0 0 > lm.data6 <- lm(y~s+num, data=data6) > print(summary(lm.data6)) Call: lm(formula = y ~ s + num, data = data6) Residuals: ALL 5 residuals are 0: no residual degrees of freedom! Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 0.6 NaN NaN NaN sa9 3.6 NaN NaN NaN sb -2.2 NaN NaN NaN sc 0.8 NaN NaN NaN num 0.4 NaN NaN NaN Residual standard error: NaN on 0 degrees of freedom Multiple R-squared: 1, Adjusted R-squared: NaN F-statistic: NaN on 4 and 0 DF, p-value: NA > check.lm(linmod.data6, lm.data6, newdata=data6[2,,drop=FALSE], check.sigma=FALSE) check linmod.data6 vs lm.data6 > > expect.err(try(linmod(y~., data=data6)), "'x' is singular (it has 6 columns but its rank is 5)") Error in do.linmod.fit(x, y) : 'x' is singular (it has 6 columns but its rank is 5) colnames(x): (Intercept) sa9 sb sc num num2 Got expected error from try(linmod(y ~ ., data = data6)) > > tr.na <- trees > tr.na[9,3] <- NA > expect.err(try(linmod(Volume~.,data=tr.na)), "NA in 'y'") Error in check.linmod.y(x, y) : NA in 'y' Got expected error from try(linmod(Volume ~ ., data = tr.na)) > expect.err(try(linmod(tr.na[,1:2], tr.na[,3])), "NA in 'y'") Error in check.linmod.y(x, y) : NA in 'y' Got expected error from try(linmod(tr.na[, 1:2], tr.na[, 3])) > > tr.na <- trees > tr.na[10,1] <- NA > expect.err(try(linmod(Volume~.,data=tr.na)), "NA in 'x'") Error in check.linmod.x(x) : NA in 'x' Got expected error from try(linmod(Volume ~ ., data = tr.na)) > expect.err(try(linmod(tr.na[,1:2], tr.na[,3])), "NA in 'x'") Error in check.linmod.x(x) : NA in 'x' Got expected error from try(linmod(tr.na[, 1:2], tr.na[, 3])) > > a42 <- linmod(trees[,1:2], trees[, 3]) > newdata1 <- data.frame(Girth=20) > expect.err(try(predict(a42, newdata=newdata1)), "ncol(newdata) is 1 but should be 2") Error in predict.linmod(a42, newdata = newdata1) : ncol(newdata) is 1 but should be 2 Got expected error from try(predict(a42, newdata = newdata1)) > newdata3 <- data.frame(Girth=20, extra1=21, extra2=22) > expect.err(try(predict(a42, newdata=newdata3)), "ncol(newdata) is 3 but should be 2") Error in predict.linmod(a42, newdata = newdata3) : ncol(newdata) is 3 but should be 2 Got expected error from try(predict(a42, newdata = newdata3)) > expect.err(try(predict(a42, newdata=data.frame())), "'newdata' is empty") Error in predict.linmod(a42, newdata = data.frame()) : 'newdata' is empty Got expected error from try(predict(a42, newdata = data.frame())) > newdata.with.NA <- data.frame(Girth=20, Height=NA) > expect.err(try(predict(a42, newdata=newdata.with.NA)), "NA in 'newdata'") Error in predict.linmod(a42, newdata = newdata.with.NA) : NA in 'newdata' Got expected error from try(predict(a42, newdata = newdata.with.NA)) > > a43 <- linmod(Volume~.,data=trees) > expect.err(try(predict(a43, newdata=newdata.with.NA)), "NA in 'newdata'") Error in process.newdata.formula(object, newdata) : NA in 'newdata' Got expected error from try(predict(a43, newdata = newdata.with.NA)) > lm43 <- lm(Volume~.,data=trees) > # message from predict.lm could be better > expect.err(try(predict(lm43, newdata=newdata.with.NA)), + "variable 'Height' was fitted with type \"numeric\" but type \"logical\" was supplied") Error : variable 'Height' was fitted with type "numeric" but type "logical" was supplied Got expected error from try(predict(lm43, newdata = newdata.with.NA)) > > y6 <- 1:5 > x6 <- data.frame() > options(warn=1) # print warnings as they occur > expect.err(try(linmod(x6, y6)), "'x' is empty") Warning in cbind(`(Intercept)` = 1, xmat) : number of rows of result is not a multiple of vector length (arg 1) Error in check.linmod.x(x) : 'x' is empty Got expected error from try(linmod(x6, y6)) > options(warn=2) # treat warnings as errors > > y7 <- data.frame() > x7 <- 1:5 > expect.err(try(linmod(x7, y7)), "'y' is empty") Error in check.linmod.y(x, y) : 'y' is empty Got expected error from try(linmod(x7, y7)) > > # duplicated column names > data7 <- matrix(1:25, ncol=5) > colnames(data7) <- c("y", "x1", "x1", "x3", "x4") > expect.err(try(linmod(data7[,-1], data7[,1])), "column name \"x1\" in 'x' is duplicated") Error in check.linmod.x(x) : column name "x1" in 'x' is duplicated Got expected error from try(linmod(data7[, -1], data7[, 1])) > > colnames(data7) <- c("y", "x1", "x2", "x2", "x4") > expect.err(try(linmod(data7[,-1], data7[,1])), "column name \"x2\" in 'x' is duplicated") Error in check.linmod.x(x) : column name "x2" in 'x' is duplicated Got expected error from try(linmod(data7[, -1], data7[, 1])) > > colnames(data7) <- c("y", "x1", "x2", "x2", "x2") > expect.err(try(linmod(data7[,-1], data7[,1])), "column name \"x2\" in 'x' is duplicated") Error in check.linmod.x(x) : column name "x2" in 'x' is duplicated Got expected error from try(linmod(data7[, -1], data7[, 1])) > > # column name V2 will be created but it clashes with the existing column name > colnames(data7) <- c("y", "V2", "", "V3", "V4") > expect.err(try(linmod(data7[,-1], data7[,1])), "column name \"V2\" in 'x' is duplicated") Error in check.linmod.x(x) : column name "V2" in 'x' is duplicated Got expected error from try(linmod(data7[, -1], data7[, 1])) > > # missing column names > trees1 <- trees > colnames(trees1) <- NULL > cat0("a52\n") a52 > a52 <- linmod(trees1[,1:2], trees1[,3]) > print(summary(a52)) Call: linmod.default(x = trees1[, 1:2], y = trees1[, 3]) Estimate StdErr t.value p.value (Intercept) -57.9876589 8.6382259 -6.712913 2.749507e-07 V1 4.7081605 0.2642646 17.816084 8.223304e-17 V2 0.3392512 0.1301512 2.606594 1.449097e-02 > > trees1 <- trees > colnames(trees1) <- c("", "Height", "Volume") # was Girth Height Volume > cat0("linmod.form.Volume.trees1\n") linmod.form.Volume.trees1 > linmod.form.Volume.trees1 <- linmod(trees1[,1:2], trees1[,3]) > print(summary(linmod.form.Volume.trees1)) Call: linmod.default(x = trees1[, 1:2], y = trees1[, 3]) Estimate StdErr t.value p.value (Intercept) -57.9876589 8.6382259 -6.712913 2.749507e-07 V1 4.7081605 0.2642646 17.816084 8.223304e-17 Height 0.3392512 0.1301512 2.606594 1.449097e-02 > cat0("linmod.form.Volume.trees1.formula\n") linmod.form.Volume.trees1.formula > expect.err(try(linmod(Volume~., data=trees1)), "attempt to use zero-length variable name") Error in terms.formula(formula, data = data) : attempt to use zero-length variable name Got expected error from try(linmod(Volume ~ ., data = trees1)) > > # very long names to test formatting in summary.linmod > trees1 <- trees > colnames(trees1) <- c("Girth.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name", + "Height.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name", + "Volume.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name") > cat0("a55\n") a55 > a55 <- linmod(Volume.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name~ + Girth.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name+ + Height.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name, + data=trees1) > print(summary(a55)) Call: linmod.formula(formula = Volume.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name ~ Girth.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name + Height.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name, data = trees1) Estimate (Intercept) -57.9876589 Girth.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name 4.7081605 Height.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name 0.3392512 StdErr (Intercept) 8.6382259 Girth.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name 0.2642646 Height.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name 0.1301512 t.value (Intercept) -6.712913 Girth.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name 17.816084 Height.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name 2.606594 p.value (Intercept) 2.749507e-07 Girth.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name 8.223304e-17 Height.a.very.long.name.in.fact.an.exceptionally.exceptionally.exceptionally.long.name 1.449097e-02 > > # intercept-only model > intonly.form <- linmod(Volume~1, data=trees) > print(summary(intonly.form)) Call: linmod.formula(formula = Volume ~ 1, data = trees) Estimate StdErr t.value p.value (Intercept) 30.17097 2.952324 10.21939 2.753323e-11 > stopifnot(length(coef(intonly.form)) == 1) > try(plotmo(intonly.form)) # Error in plotmo(intonly.form) : x is empty Error in plotmo(intonly.form) : x is empty > plotres(intonly.form) > expect.err(try(plotmo(intonly.form)), "x is empty") Error in plotmo(intonly.form) : x is empty Got expected error from try(plotmo(intonly.form)) > expect.err(try(linmod(rep(1, length.out=nrow(trees)), trees$Volume)), + "'x' is singular (it has 2 columns but its rank is 1)") Error in do.linmod.fit(x, y) : 'x' is singular (it has 2 columns but its rank is 1) colnames(x): (Intercept) V1 Got expected error from try(linmod(rep(1, length.out = nrow(trees)), trees$Volume)) > > # various tests for bad args > expect.err(try(linmod(trees[,1:2])), "no 'y' argument") Error in as.matrix(y) : no 'y' argument Got expected error from try(linmod(trees[, 1:2])) > > # test stop.if.dot.arg.used > expect.err(try(linmod(Volume~., data=trees, nonesuch=99)), + "unused argument (nonesuch = 99)") Error in stop.if.dot.arg.used(...) : unused argument (nonesuch = 99) Got expected error from try(linmod(Volume ~ ., data = trees, nonesuch = 99)) > expect.err(try(linmod(trees[,1:2], trees[,3], nonesuch=linmod)), + "unused argument (nonesuch = function (...)") Error in stop.if.dot.arg.used(...) : unused argument (nonesuch = function (...) UseMethod("linmod")) Got expected error from try(linmod(trees[, 1:2], trees[, 3], nonesuch = linmod)) > expect.err(try(summary(linmod(trees[,1:2], trees[,3]), nonesuch=linmod)), + "unused argument (nonesuch = function (...)") Error in stop.if.dot.arg.used(...) : unused argument (nonesuch = function (...) UseMethod("linmod")) Got expected error from try(summary(linmod(trees[, 1:2], trees[, 3]), nonesuch = linmod)) > expect.err(try(print(linmod(trees[,1:2], trees[,3]), nonesuch=linmod)), + "unused argument (nonesuch = function (...)") Error in stop.if.dot.arg.used(...) : unused argument (nonesuch = function (...) UseMethod("linmod")) Got expected error from try(print(linmod(trees[, 1:2], trees[, 3]), nonesuch = linmod)) > expect.err(try(predict(linmod.form.Volume.tr, nonesuch=99)), + "unused argument (nonesuch = 99)") Error in stop.if.dot.arg.used(...) : unused argument (nonesuch = 99) Got expected error from try(predict(linmod.form.Volume.tr, nonesuch = 99)) > > # check partial matching on type argument > stopifnot(identical(predict(linmod.form.Volume.tr, type="r"), predict(linmod.form.Volume.tr))) > stopifnot(identical(predict(linmod.form.Volume.tr, type="resp"), predict(linmod.form.Volume.tr))) > expect.err(try(predict(linmod.form.Volume.tr, type="nonesuch")), "'arg' should be \"response\"") Error in match.arg(type, "response") : 'arg' should be "response" Got expected error from try(predict(linmod.form.Volume.tr, type = "nonesuch")) > > # test additional method functions (see linmod.methods.R) > > check.lm(linmod.form.Volume.tr, lm.Volume.tr, newdata=trees[3,1:2]) check linmod.form.Volume.tr vs lm.Volume.tr > stopifnot(almost.equal(coef(linmod.form.Volume.tr), coef(lm.Volume.tr))) > stopifnot(identical(names(coef(linmod.form.Volume.tr)), names(coef(lm.Volume.tr)))) > stopifnot(almost.equal(fitted(linmod.form.Volume.tr), fitted(lm.Volume.tr))) > stopifnot(identical(names(fitted(linmod.form.Volume.tr)), names(fitted(lm.Volume.tr)))) > stopifnot(identical(na.action(linmod.form.Volume.tr), na.action(lm.Volume.tr))) > stopifnot(almost.equal(residuals(linmod.form.Volume.tr), residuals(lm.Volume.tr))) > stopifnot(identical(names(residuals(linmod.form.Volume.tr)), names(residuals(lm.Volume.tr)))) > stopifnot(identical(names(case.names(linmod.form.Volume.tr)), names(case.names(lm.Volume.tr)))) > stopifnot(identical(variable.names(linmod.form.Volume.tr), variable.names(lm.Volume.tr))) > stopifnot(identical(nobs(linmod.form.Volume.tr), nobs(lm.Volume.tr))) > stopifnot(identical(weights(linmod.form.Volume.tr), weights(lm.Volume.tr))) > stopifnot(almost.equal(df.residual(linmod.form.Volume.tr), df.residual(lm.Volume.tr))) > stopifnot(identical(names(df.residual(linmod.form.Volume.tr)), names(df.residual(lm.Volume.tr)))) > stopifnot(almost.equal(deviance(linmod.form.Volume.tr), deviance(lm.Volume.tr))) > stopifnot(identical(names(deviance(linmod.form.Volume.tr)), names(deviance(lm.Volume.tr)))) > stopifnot(identical(weights(linmod.form.Volume.tr), weights(lm.Volume.tr))) > stopifnot(identical(model.frame(linmod.form.Volume.tr), model.frame(lm.Volume.tr))) > stopifnot(identical(model.matrix(linmod.form.Volume.tr), model.matrix(lm.Volume.tr))) > stopifnot(identical(model.matrix(linmod.form.Volume.tr, data=tr[1:2,]), + model.matrix(lm.Volume.tr, data=tr[1:2,]))) > stopifnot(almost.equal(logLik(linmod.form.Volume.tr), logLik(lm.Volume.tr))) > expect.err(try(logLik(linmod.form.Volume.tr, REML=TRUE)), "!REML is not TRUE") Error in logLik.linmod(linmod.form.Volume.tr, REML = TRUE) : !REML is not TRUE Got expected error from try(logLik(linmod.form.Volume.tr, REML = TRUE)) > library(sandwich) # for estfun.lm > stopifnot(almost.equal(estfun(linmod.form.Volume.tr), estfun(lm.Volume.tr))) > > linmod.form.Volume.tr.update <- update(linmod.form.Volume.tr, formula.=Volume~Height) > lm.Volume.tr.update <- update(lm.Volume.tr, formula.=Volume~Height) > check.lm(linmod.form.Volume.tr.update, lm.Volume.tr.update) check linmod.form.Volume.tr.update vs lm.Volume.tr.update > > check.lm(linmod.xy.Volume.tr, lm.Volume.tr, newdata=trees[3,1:2]) check linmod.xy.Volume.tr vs lm.Volume.tr > stopifnot(almost.equal(coef(linmod.xy.Volume.tr), coef(lm.Volume.tr))) > stopifnot(identical(names(coef(linmod.xy.Volume.tr)), names(coef(lm.Volume.tr)))) > stopifnot(almost.equal(fitted(linmod.xy.Volume.tr), fitted(lm.Volume.tr))) > stopifnot(identical(names(fitted(linmod.xy.Volume.tr)), names(fitted(lm.Volume.tr)))) > stopifnot(identical(na.action(linmod.xy.Volume.tr), na.action(lm.Volume.tr))) > stopifnot(almost.equal(residuals(linmod.xy.Volume.tr), residuals(lm.Volume.tr))) > stopifnot(identical(names(residuals(linmod.xy.Volume.tr)), names(residuals(lm.Volume.tr)))) > stopifnot(identical(case.names(linmod.xy.Volume.tr), case.names(lm.Volume.tr))) > stopifnot(identical(variable.names(linmod.xy.Volume.tr), variable.names(lm.Volume.tr))) > stopifnot(identical(nobs(linmod.xy.Volume.tr), nobs(lm.Volume.tr))) > stopifnot(identical(weights(linmod.xy.Volume.tr), weights(lm.Volume.tr))) > stopifnot(almost.equal(df.residual(linmod.xy.Volume.tr), df.residual(lm.Volume.tr))) > stopifnot(identical(names(df.residual(linmod.xy.Volume.tr)), names(df.residual(lm.Volume.tr)))) > stopifnot(almost.equal(deviance(linmod.xy.Volume.tr), deviance(lm.Volume.tr))) > stopifnot(identical(names(deviance(linmod.xy.Volume.tr)), names(deviance(lm.Volume.tr)))) > stopifnot(identical(weights(linmod.xy.Volume.tr), weights(lm.Volume.tr))) > expect.err(try(model.frame(linmod.xy.Volume.tr)), "model.frame cannot be used on linmod models built without a formula") Error in model.frame.linmod(linmod.xy.Volume.tr) : model.frame cannot be used on linmod models built without a formula Got expected error from try(model.frame(linmod.xy.Volume.tr)) > expect.err(try(model.matrix(linmod.xy.Volume.tr)), + "model.frame cannot be used on linmod models built without a formula") Error in model.frame.linmod(object) : model.frame cannot be used on linmod models built without a formula Got expected error from try(model.matrix(linmod.xy.Volume.tr)) > stopifnot(almost.equal(logLik(linmod.xy.Volume.tr), logLik(lm.Volume.tr))) > > par(mfrow=c(2,2)) > plot(linmod.form.Volume.tr) > plot(lm.Volume.tr, which=1, main="lm.Volume.tr") > plot(linmod.xy.Volume.tr) > plot(linmod.form.Volume.tr, xlim=c(0,80), ylim=c(-10,10), pch=20, main="linmod.form.Volume.tr: test plot args") > par(org.par) > > cat0("==test one predictor model\n") ==test one predictor model > > linmod.onepred.form <- linmod(Volume~Girth, data=tr) # one predictor > lm.onepred.form <- lm(Volume~Girth, data=tr) > check.lm(linmod.onepred.form, lm.onepred.form, newdata=trees[3,1:2]) check linmod.onepred.form vs lm.onepred.form > linmod.onepred.xy <- linmod(tr[,1,drop=FALSE], tr[,3]) # one predictor > print(summary(linmod.onepred.xy)) Call: linmod.default(x = tr[, 1, drop = FALSE], y = tr[, 3]) Estimate StdErr t.value p.value (Intercept) -36.943459 3.365145 -10.97827 7.621449e-12 Girth 5.065856 0.247377 20.47829 8.644334e-19 > check.lm(linmod.onepred.xy, lm.onepred.form, newdata=trees[3,1,drop=FALSE]) check linmod.onepred.xy vs lm.onepred.form > > par(mfrow=c(2,2)) > plot(linmod.onepred.form) > plot(lm.onepred.form, which=1, main="lm.onepred.form") > plot(linmod.onepred.xy) > par(org.par) > plotres(linmod.onepred.form) > plotmo(linmod.onepred.form, pt.col=2) > > cat0("==test no intercept model\n") ==test no intercept model > # no intercept models are only supported with the formula interface (not x,y interface) > > linmod.noint <- linmod(Volume~.-1, data=trees) # no intercept > print(summary(linmod.noint)) Call: linmod.formula(formula = Volume ~ . - 1, data = trees) Estimate StdErr t.value p.value Girth 5.0440083 0.4118733 12.246506 5.519859e-13 Height -0.4773192 0.0734721 -6.496605 4.118004e-07 > lm.noint <- lm(Volume~.-1, data=trees) # no intercept > check.lm(linmod.noint, lm.noint) check linmod.noint vs lm.noint > linmod.noint.keep <- linmod(Volume~.-1, data=trees, keep=TRUE) > print(summary(linmod.noint.keep)) Call: linmod.formula(formula = Volume ~ . - 1, data = trees, keep = TRUE) Estimate StdErr t.value p.value Girth 5.0440083 0.4118733 12.246506 5.519859e-13 Height -0.4773192 0.0734721 -6.496605 4.118004e-07 > > check.lm(linmod.noint, lm.noint) check linmod.noint vs lm.noint > stopifnot(class(linmod.noint.keep$data) == class(linmod.form.Volume.trees.keep$data)) > stopifnot(all(dim(linmod.noint.keep$data) == dim(linmod.form.Volume.trees.keep$data))) > stopifnot(all(linmod.noint.keep$data == linmod.form.Volume.trees.keep$data)) > stopifnot(class(linmod.noint.keep$y) == class(linmod.form.Volume.trees.keep$y)) > stopifnot(all(dim(linmod.noint.keep$data) == dim(linmod.form.Volume.trees.keep$data))) > stopifnot(all(linmod.noint.keep$data == linmod.form.Volume.trees.keep$data)) > > # check method functions in no-intercept model > stopifnot(almost.equal(coef(linmod.noint), coef(lm.noint))) > stopifnot(identical(names(coef(linmod.noint)), names(coef(lm.noint)))) > stopifnot(almost.equal(fitted(linmod.noint), fitted(lm.noint))) > stopifnot(identical(names(fitted(linmod.noint)), names(fitted(lm.noint)))) > stopifnot(identical(na.action(linmod.noint), na.action(lm.noint))) > stopifnot(almost.equal(residuals(linmod.noint), residuals(lm.noint))) > stopifnot(identical(names(residuals(linmod.noint)), names(residuals(lm.noint)))) > stopifnot(identical(case.names(linmod.noint), case.names(lm.noint))) > stopifnot(identical(variable.names(linmod.noint), variable.names(lm.noint))) > stopifnot(identical(nobs(linmod.noint), nobs(lm.noint))) > stopifnot(identical(weights(linmod.noint), weights(lm.noint))) > stopifnot(almost.equal(df.residual(linmod.noint), df.residual(lm.noint))) > stopifnot(identical(names(df.residual(linmod.noint)), names(df.residual(lm.noint)))) > stopifnot(almost.equal(deviance(linmod.noint), deviance(lm.noint))) > stopifnot(identical(names(deviance(linmod.noint)), names(deviance(lm.noint)))) > stopifnot(identical(weights(linmod.noint), weights(lm.noint))) > stopifnot(identical(model.frame(linmod.noint), model.frame(lm.noint))) > stopifnot(identical(model.matrix(linmod.noint), model.matrix(lm.noint))) > stopifnot(identical(model.matrix(linmod.noint, data=tr[1:2,]), + model.matrix(lm.noint, data=tr[1:2,]))) > stopifnot(almost.equal(logLik(linmod.noint), logLik(lm.noint))) > stopifnot(almost.equal(estfun(linmod.noint), estfun(lm.noint))) > > # check error messages with bad newdata in no-intercept model > expect.err(try(predict(linmod.noint, newdata=NA)), + "object 'Girth' not found") Error in eval(predvars, data, env) : object 'Girth' not found Got expected error from try(predict(linmod.noint, newdata = NA)) > expect.err(try(predict(linmod.noint, newdata=data.frame(Height=c(1,NA), Girth=c(3,4)))), + "NA in 'newdata'") Error in process.newdata.formula(object, newdata) : NA in 'newdata' Got expected error from try(predict(linmod.noint, newdata = data.frame(Height = c(1, NA), Girth = c(3, 4)))) > expect.err(try(predict(linmod.noint, newdata=trees[0,])), "'newdata' is empty") Error in predict.linmod(linmod.noint, newdata = trees[0, ]) : 'newdata' is empty Got expected error from try(predict(linmod.noint, newdata = trees[0, ])) > expect.err(try(predict(linmod.noint, newdata=trees[3:5,"Height"])), "object 'Girth' not found") Error in eval(predvars, data, env) : object 'Girth' not found Got expected error from try(predict(linmod.noint, newdata = trees[3:5, "Height"])) > # check that extra fields in predict newdata are ok with (formula) models without intercept > stopifnot(almost.equal(predict(linmod.noint, newdata=data.frame(Girth=10, Height=80, extra=99)), + predict(lm.noint, newdata=data.frame(Girth=10, Height=80, extra=99)))) > > par(mfrow=c(2,2)) > plot(linmod.noint) > plot(lm.noint, which=1, main="lm.noint") > par(org.par) > > plotres(linmod.noint) > plotmo(linmod.noint) plotmo grid: Girth Height 12.9 76 > > cat0("==test one predictor no intercept model\n") ==test one predictor no intercept model > # no intercept models are only supported with the formula interface (not x,y interface) > > linmod.onepred.noint <- linmod(Volume~Girth-1, data=trees) # one predictor, no intercept > print(summary(linmod.onepred.noint)) Call: linmod.formula(formula = Volume ~ Girth - 1, data = trees) Estimate StdErr t.value p.value Girth 2.420943 0.1253311 19.31637 1.7813e-18 > lm.onepred.noint <- lm(Volume~Girth-1, data=trees) # one predictor, no intercept > check.lm(linmod.onepred.noint, lm.onepred.noint) check linmod.onepred.noint vs lm.onepred.noint > linmod.onepred.noint.keep <- linmod(Volume~.-1, data=trees, keep=TRUE) > print(summary(linmod.onepred.noint.keep)) Call: linmod.formula(formula = Volume ~ . - 1, data = trees, keep = TRUE) Estimate StdErr t.value p.value Girth 5.0440083 0.4118733 12.246506 5.519859e-13 Height -0.4773192 0.0734721 -6.496605 4.118004e-07 > > check.lm(linmod.onepred.noint, lm.onepred.noint) check linmod.onepred.noint vs lm.onepred.noint > stopifnot(class(linmod.onepred.noint.keep$data) == class(linmod.form.Volume.trees.keep$data)) > stopifnot(all(dim(linmod.onepred.noint.keep$data) == dim(linmod.form.Volume.trees.keep$data))) > stopifnot(all(linmod.onepred.noint.keep$data == linmod.form.Volume.trees.keep$data)) > stopifnot(class(linmod.onepred.noint.keep$y) == class(linmod.form.Volume.trees.keep$y)) > stopifnot(all(dim(linmod.onepred.noint.keep$data) == dim(linmod.form.Volume.trees.keep$data))) > stopifnot(all(linmod.onepred.noint.keep$data == linmod.form.Volume.trees.keep$data)) > > # check method functions in one predictor no-intercept model > stopifnot(almost.equal(coef(linmod.onepred.noint), coef(lm.onepred.noint))) > stopifnot(identical(names(coef(linmod.onepred.noint)), names(coef(lm.onepred.noint)))) > stopifnot(almost.equal(fitted(linmod.onepred.noint), fitted(lm.onepred.noint))) > stopifnot(identical(names(fitted(linmod.onepred.noint)), names(fitted(lm.onepred.noint)))) > stopifnot(identical(na.action(linmod.onepred.noint), na.action(lm.onepred.noint))) > stopifnot(almost.equal(residuals(linmod.onepred.noint), residuals(lm.onepred.noint))) > stopifnot(identical(names(residuals(linmod.onepred.noint)), names(residuals(lm.onepred.noint)))) > stopifnot(identical(case.names(linmod.onepred.noint), case.names(lm.onepred.noint))) > stopifnot(identical(variable.names(linmod.onepred.noint), variable.names(lm.onepred.noint))) > stopifnot(identical(nobs(linmod.onepred.noint), nobs(lm.onepred.noint))) > stopifnot(identical(weights(linmod.onepred.noint), weights(lm.onepred.noint))) > stopifnot(almost.equal(df.residual(linmod.onepred.noint), df.residual(lm.onepred.noint))) > stopifnot(identical(names(df.residual(linmod.onepred.noint)), names(df.residual(lm.onepred.noint)))) > stopifnot(almost.equal(deviance(linmod.onepred.noint), deviance(lm.onepred.noint))) > stopifnot(identical(names(deviance(linmod.onepred.noint)), names(deviance(lm.onepred.noint)))) > stopifnot(identical(weights(linmod.onepred.noint), weights(lm.onepred.noint))) > stopifnot(identical(model.frame(linmod.onepred.noint), model.frame(lm.onepred.noint))) > stopifnot(identical(model.matrix(linmod.onepred.noint), model.matrix(lm.onepred.noint))) > stopifnot(identical(model.matrix(linmod.onepred.noint, data=tr[1:2,]), + model.matrix(lm.onepred.noint, data=tr[1:2,]))) > stopifnot(almost.equal(logLik(linmod.onepred.noint), logLik(lm.onepred.noint))) > stopifnot(almost.equal(estfun(linmod.onepred.noint), estfun(lm.onepred.noint))) > > # check error messages with bad newdata in one predictor no-intercept model > expect.err(try(predict(linmod.onepred.noint, newdata=99)), "object 'Girth' not found") Error in eval(predvars, data, env) : object 'Girth' not found Got expected error from try(predict(linmod.onepred.noint, newdata = 99)) > expect.err(try(predict(linmod.onepred.noint, newdata=data.frame(Girth=NA))), "NA in 'newdata'") Error in process.newdata.formula(object, newdata) : NA in 'newdata' Got expected error from try(predict(linmod.onepred.noint, newdata = data.frame(Girth = NA))) > expect.err(try(predict(linmod.onepred.noint, newdata=trees[0,1])), "'newdata' is empty") Error in predict.linmod(linmod.onepred.noint, newdata = trees[0, 1]) : 'newdata' is empty Got expected error from try(predict(linmod.onepred.noint, newdata = trees[0, 1])) > expect.err(try(predict(linmod.onepred.noint, newdata=trees[3:5,"Height"])), "object 'Girth' not found") Error in eval(predvars, data, env) : object 'Girth' not found Got expected error from try(predict(linmod.onepred.noint, newdata = trees[3:5, "Height"])) > # check that extra fields in predict newdata are ok with (formula) models without intercept > stopifnot(almost.equal(predict(linmod.onepred.noint, newdata=data.frame(Girth=10, extra=99)), + predict(lm.onepred.noint, newdata=data.frame(Girth=10, extra=99)))) > > par(mfrow=c(2,2)) > plot(linmod.onepred.noint) > plot(lm.onepred.noint, which=1, main="lm.onepred.noint") > par(org.par) > > plotres(linmod.onepred.noint) > plotmo(linmod.onepred.noint) > > expect.err(try(linmod(Volume~nonesuch, data=trees)), "object 'nonesuch' not found") Error in eval(predvars, data, env) : object 'nonesuch' not found Got expected error from try(linmod(Volume ~ nonesuch, data = trees)) > expect.err(try(linmod(Volume~0, data=trees)), "'x' is empty") # no predictor Error in check.linmod.x(x) : 'x' is empty Got expected error from try(linmod(Volume ~ 0, data = trees)) > expect.err(try(linmod(Volume~-1, data=trees)), "'x' is empty") # no predictor, no intercept Error in check.linmod.x(x) : 'x' is empty Got expected error from try(linmod(Volume ~ -1, data = trees)) > > cat0("==check model with many variables\n") ==check model with many variables > > set.seed(2018) > p <- 300 # number of variables > n <- floor(1.1 * p) > bigdat <- as.data.frame(matrix(rnorm(n * (p+1)), ncol=p+1)) > colnames(bigdat) <- c("y", paste0("var", 1:p)) > lm.bigdat <- lm(y~., data=bigdat) > linmod.bigdat <- linmod(y~., data=bigdat) > check.lm(linmod.form.Volume.tr, lm.Volume.tr) check linmod.form.Volume.tr vs lm.Volume.tr > print(linmod.bigdat) Call: linmod.formula(formula = y ~ ., data = bigdat) (Intercept) var1 var2 var3 var4 -0.0074874141 -0.0156168166 -0.0323375299 -0.0680410620 -0.1784176655 var5 var6 var7 var8 var9 0.0970839766 -0.2420079781 0.0068052116 0.0605142551 0.1563114625 var10 var11 var12 var13 var14 -0.0705547201 0.0661388031 0.0753290388 -0.0595687675 -0.1972523829 var15 var16 var17 var18 var19 -0.0928371617 0.1400015667 0.0349750202 0.0990295749 -0.0806465990 var20 var21 var22 var23 var24 -0.0005353688 -0.1384821496 -0.0405121324 -0.0181462061 -0.2133498970 var25 var26 var27 var28 var29 -0.0186244683 -0.2593737746 -0.0589964475 -0.0537252842 -0.0594401821 var30 var31 var32 var33 var34 0.0934989343 0.0244371962 0.1403544230 0.2619465745 0.0159354057 var35 var36 var37 var38 var39 -0.0210109954 -0.0328618036 -0.1371912460 -0.0649163643 0.0595217563 var40 var41 var42 var43 var44 -0.0682175594 -0.1103821881 -0.0508841621 -0.1392364303 -0.0103981103 var45 var46 var47 var48 var49 -0.1196682294 -0.1534327142 -0.0754141872 0.1426175022 0.0011406008 var50 var51 var52 var53 var54 0.0379811394 0.0320275730 -0.0532598495 -0.1410085314 0.1519143039 var55 var56 var57 var58 var59 -0.0228233810 0.3170130760 -0.1044797851 -0.0035954154 0.1479556565 var60 var61 var62 var63 var64 0.0122428193 -0.0253431378 -0.0180440355 -0.1794590898 0.0131447015 var65 var66 var67 var68 var69 -0.1720319639 0.1526605311 0.0771868987 -0.2418787630 0.0447156252 var70 var71 var72 var73 var74 -0.1105368627 0.0567936200 0.0424605198 -0.0881098654 0.0092876782 var75 var76 var77 var78 var79 -0.0716540798 -0.1255361536 -0.0071680571 -0.1208344391 -0.0735928839 var80 var81 var82 var83 var84 0.2324224976 -0.1849522151 0.0694052039 0.1390729406 -0.0617270270 var85 var86 var87 var88 var89 0.0850926211 0.1221016487 0.0233354163 0.0075718550 -0.0032554103 var90 var91 var92 var93 var94 0.1209443561 0.2292860177 0.1347583831 0.0781827877 -0.1541547464 var95 var96 var97 var98 var99 0.1337171223 -0.1163422961 -0.0966724692 -0.2182129213 -0.1204830968 var100 var101 var102 var103 var104 -0.0619465323 -0.1113710701 0.0594579753 0.0955361014 -0.0519687498 var105 var106 var107 var108 var109 -0.0346599073 0.2181197633 0.0332996851 -0.0969131172 0.1736014017 var110 var111 var112 var113 var114 -0.1714974837 -0.0056002152 0.1393566962 -0.0972988693 0.0475762687 var115 var116 var117 var118 var119 0.2364360899 -0.0985131354 -0.0894394214 -0.2355018204 0.0025381197 var120 var121 var122 var123 var124 -0.1427340796 -0.0565016310 -0.0455466677 0.1579742783 0.1290270638 var125 var126 var127 var128 var129 0.0735269010 -0.0074354274 -0.0202350963 0.0921409434 0.0578351619 var130 var131 var132 var133 var134 0.0457446540 -0.0497481279 -0.0716169797 -0.0834890066 0.0078486400 var135 var136 var137 var138 var139 0.0569885547 -0.0880888941 0.0931535379 0.0029921816 0.0215558011 var140 var141 var142 var143 var144 0.0379439385 0.1288009147 -0.0627699322 0.1471235930 0.0418985129 var145 var146 var147 var148 var149 0.1581333558 0.2109672906 -0.1305882685 0.1715603371 -0.0674028658 var150 var151 var152 var153 var154 -0.1809329622 -0.0618254790 -0.0644645613 -0.0185217288 0.0963509748 var155 var156 var157 var158 var159 0.0669555139 0.1341679917 0.0014091507 0.1912096659 0.1049270995 var160 var161 var162 var163 var164 0.1407325985 -0.0149350788 -0.1567496204 0.0881458138 -0.0429862791 var165 var166 var167 var168 var169 0.0080105136 -0.0374778798 0.1385838635 -0.0734288141 -0.1266495195 var170 var171 var172 var173 var174 0.0071467393 -0.0255859731 0.1516581037 -0.2106472762 -0.0308347530 var175 var176 var177 var178 var179 0.0076295054 0.1793572809 0.1064141211 0.0906223259 0.0435110825 var180 var181 var182 var183 var184 -0.1264325305 -0.0968032660 0.1430811907 0.0307419406 -0.0319429988 var185 var186 var187 var188 var189 0.0461719964 -0.2385322379 0.0850810205 0.3949689631 0.1245166753 var190 var191 var192 var193 var194 0.1720563316 0.2144640136 0.0501975420 0.1174708714 -0.1943912402 var195 var196 var197 var198 var199 0.0202300723 0.0210580247 0.0726236855 0.1064539412 -0.0767767634 var200 var201 var202 var203 var204 -0.0624521254 0.0028300645 -0.1715330103 0.2115665862 0.0338181429 var205 var206 var207 var208 var209 0.0167958834 -0.0590878112 -0.1653100651 -0.0740487318 -0.0043391023 var210 var211 var212 var213 var214 0.3393487726 0.2223498489 0.0213281741 0.2230110595 -0.1228075434 var215 var216 var217 var218 var219 -0.0104634410 0.0326754989 -0.4439139348 -0.1087432871 -0.0107897918 var220 var221 var222 var223 var224 -0.0296175151 0.1091241015 0.0909297736 -0.3485310127 0.0832890933 var225 var226 var227 var228 var229 -0.0042697108 0.0593458113 -0.0182956931 0.0572344159 -0.1231669279 var230 var231 var232 var233 var234 0.0492497234 -0.2862525037 0.1834105207 0.2081280243 0.1641204059 var235 var236 var237 var238 var239 0.2472694582 0.0683823801 0.1891842675 -0.0489319878 0.1490499844 var240 var241 var242 var243 var244 -0.0095798604 0.0721964545 -0.0126839937 -0.2221525719 -0.0829084901 var245 var246 var247 var248 var249 -0.0318090335 -0.0425994225 0.0033944363 0.0984076551 -0.2148911884 var250 var251 var252 var253 var254 -0.1875432344 -0.1735721485 0.2886948591 0.1467087046 -0.0834815473 var255 var256 var257 var258 var259 -0.0635576566 -0.0346030600 -0.1224921370 -0.2423169128 -0.0021922047 var260 var261 var262 var263 var264 -0.0818789537 -0.0707600938 -0.3301726263 -0.2602526557 -0.1427837485 var265 var266 var267 var268 var269 -0.1315034492 0.1292166855 0.0265412839 0.1111883441 0.1302021867 var270 var271 var272 var273 var274 -0.0923837589 -0.0680064479 -0.1776069310 -0.0374118346 0.0877037245 var275 var276 var277 var278 var279 -0.0016240717 0.1670149940 0.1542172653 -0.0108006893 0.1334885400 var280 var281 var282 var283 var284 0.1637485211 0.0649039066 -0.0277897733 0.1978208690 0.0984930229 var285 var286 var287 var288 var289 -0.1113854013 0.0770616839 -0.0634971052 0.1652137421 -0.0984475187 var290 var291 var292 var293 var294 0.1166070472 -0.0682754836 0.1016526112 -0.2976518291 -0.1119627963 var295 var296 var297 var298 var299 0.2734232937 -0.1054927068 -0.2151298321 0.0208265210 0.0882009038 var300 0.1604547308 > print(summary(linmod.bigdat)) Call: linmod.formula(formula = y ~ ., data = bigdat) Estimate StdErr t.value p.value (Intercept) -0.0074874141 0.1800205 -0.041592015 0.9671090 var1 -0.0156168166 0.2371393 -0.065855031 0.9479451 var2 -0.0323375299 0.2074053 -0.155914683 0.8771805 var3 -0.0680410620 0.2135121 -0.318675467 0.7522565 var4 -0.1784176655 0.2765676 -0.645114193 0.5239245 var5 0.0970839766 0.2705479 0.358842112 0.7223126 var6 -0.2420079781 0.2227204 -1.086599878 0.2861632 var7 0.0068052116 0.2638035 0.025796522 0.9795963 var8 0.0605142551 0.2672763 0.226410883 0.8224702 var9 0.1563114625 0.2173700 0.719103064 0.4778324 var10 -0.0705547201 0.2298045 -0.307020683 0.7610215 var11 0.0661388031 0.2511706 0.263322181 0.7941642 var12 0.0753290388 0.2012531 0.374300073 0.7109041 var13 -0.0595687675 0.3550150 -0.167792238 0.8679114 var14 -0.1972523829 0.2246975 -0.877857612 0.3872362 var15 -0.0928371617 0.2113127 -0.439335409 0.6636749 var16 0.1400015667 0.2435983 0.574723062 0.5699107 var17 0.0349750202 0.1917603 0.182389223 0.8565463 var18 0.0990295749 0.2216047 0.446874974 0.6582850 var19 -0.0806465990 0.1909595 -0.422323087 0.6759040 var20 -0.0005353688 0.2338494 -0.002289374 0.9981890 var21 -0.1384821496 0.2015467 -0.687097048 0.4974799 var22 -0.0405121324 0.2477545 -0.163517220 0.8712455 var23 -0.0181462061 0.2375000 -0.076405072 0.9396215 var24 -0.2133498970 0.2363631 -0.902636318 0.3741555 var25 -0.0186244683 0.2254941 -0.082594047 0.9347418 var26 -0.2593737746 0.2564927 -1.011232508 0.3202685 var27 -0.0589964475 0.2340174 -0.252102832 0.8027398 var28 -0.0537252842 0.2245610 -0.239245826 0.8125978 var29 -0.0594401821 0.2027951 -0.293104596 0.7715294 var30 0.0934989343 0.2367895 0.394860933 0.6958348 var31 0.0244371962 0.3424643 0.071356924 0.9436035 var32 0.1403544230 0.2135245 0.657322481 0.5161571 var33 0.2619465745 0.2640503 0.992032890 0.3293872 var34 0.0159354057 0.2044152 0.077956052 0.9383984 var35 -0.0210109954 0.2844938 -0.073853956 0.9416337 var36 -0.0328618036 0.2399793 -0.136936018 0.8920276 var37 -0.1371912460 0.2537454 -0.540664966 0.5928674 var38 -0.0649163643 0.1799295 -0.360787712 0.7208731 var39 0.0595217563 0.2022310 0.294325542 0.7706057 var40 -0.0682175594 0.2554638 -0.267034184 0.7913327 var41 -0.1103821881 0.2331126 -0.473514393 0.6393915 var42 -0.0508841621 0.2752612 -0.184857767 0.8546273 var43 -0.1392364303 0.2495550 -0.557938843 0.5811682 var44 -0.0103981103 0.2209398 -0.047063086 0.9627856 var45 -0.1196682294 0.3048932 -0.392492323 0.6975645 var46 -0.1534327142 0.2572114 -0.596523861 0.5554538 var47 -0.0754141872 0.2600154 -0.290037393 0.7738514 var48 0.1426175022 0.2254117 0.632697751 0.5318886 var49 0.0011406008 0.2120596 0.005378679 0.9957453 var50 0.0379811394 0.2310918 0.164355174 0.8705918 var51 0.0320275730 0.2767792 0.115715247 0.9086758 var52 -0.0532598495 0.2458433 -0.216641439 0.8300046 var53 -0.1410085314 0.1977205 -0.713171114 0.4814399 var54 0.1519143039 0.2314816 0.656269545 0.5168246 var55 -0.0228233810 0.2350910 -0.097083173 0.9233282 var56 0.3170130760 0.3614265 0.877116184 0.3876321 var57 -0.1044797851 0.2183847 -0.478420881 0.6359379 var58 -0.0035954154 0.2751337 -0.013067882 0.9896631 var59 0.1479556565 0.2123298 0.696820184 0.4914637 var60 0.0122428193 0.2293630 0.053377487 0.9577972 var61 -0.0253431378 0.2313604 -0.109539665 0.9135290 var62 -0.0180440355 0.1981508 -0.091062144 0.9280693 var63 -0.1794590898 0.1901054 -0.943998047 0.3529695 var64 0.0131447015 0.2083418 0.063092011 0.9501261 var65 -0.1720319639 0.2428857 -0.708283494 0.4844239 var66 0.1526605311 0.2147799 0.710776774 0.4829003 var67 0.0771868987 0.3130362 0.246575008 0.8069742 var68 -0.2418787630 0.2493599 -0.969998540 0.3400684 var69 0.0447156252 0.2115566 0.211364798 0.8340810 var70 -0.1105368627 0.1705161 -0.648248782 0.5219242 var71 0.0567936200 0.2117084 0.268263375 0.7903957 var72 0.0424605198 0.2223151 0.190992539 0.8498623 var73 -0.0881098654 0.2502169 -0.352133982 0.7272839 var74 0.0092876782 0.1725946 0.053812095 0.9574539 var75 -0.0716540798 0.2042502 -0.350815262 0.7282627 var76 -0.1255361536 0.2032681 -0.617588945 0.5416660 var77 -0.0071680571 0.2245031 -0.031928539 0.9747478 var78 -0.1208344391 0.2171811 -0.556376521 0.5822217 var79 -0.0735928839 0.2758883 -0.266748816 0.7915503 var80 0.2324224976 0.2178554 1.066865690 0.2948340 var81 -0.1849522151 0.2494518 -0.741434562 0.4643923 var82 0.0694052039 0.2244402 0.309236945 0.7593522 var83 0.1390729406 0.2408728 0.577370810 0.5681449 var84 -0.0617270270 0.2172721 -0.284100080 0.7783524 var85 0.0850926211 0.2263187 0.375985799 0.7096640 var86 0.1221016487 0.2563207 0.476362843 0.6373855 var87 0.0233354163 0.1872097 0.124648512 0.9016619 var88 0.0075718550 0.1673231 0.045252884 0.9642159 var89 -0.0032554103 0.1788632 -0.018200555 0.9856035 var90 0.1209443561 0.2560722 0.472305640 0.6402436 var91 0.2292860177 0.1858306 1.233844321 0.2271674 var92 0.1347583831 0.2565987 0.525171749 0.6034562 var93 0.0781827877 0.2780298 0.281202951 0.7805515 var94 -0.1541547464 0.2788393 -0.552844434 0.5846067 var95 0.1337171223 0.2598042 0.514684249 0.6106743 var96 -0.1163422961 0.2154543 -0.539986000 0.5933295 var97 -0.0966724692 0.1949970 -0.495763812 0.6237974 var98 -0.2182129213 0.2123535 -1.027592541 0.3126367 var99 -0.1204830968 0.2005145 -0.600869627 0.5525946 var100 -0.0619465323 0.1976115 -0.313476390 0.7561624 var101 -0.1113710701 0.2468408 -0.451185779 0.6552116 var102 0.0594579753 0.2864292 0.207583470 0.8370051 var103 0.0955361014 0.2438856 0.391725115 0.6981251 var104 -0.0519687498 0.1991270 -0.260982906 0.7959502 var105 -0.0346599073 0.2657151 -0.130440121 0.8971189 var106 0.2181197633 0.2335975 0.933741705 0.3581471 var107 0.0332996851 0.2262542 0.147178175 0.8840098 var108 -0.0969131172 0.2404953 -0.402973070 0.6899235 var109 0.1736014017 0.2382727 0.728582793 0.4720999 var110 -0.1714974837 0.2789115 -0.614881303 0.5434281 var111 -0.0056002152 0.2405138 -0.023284378 0.9815829 var112 0.1393566962 0.2713318 0.513602510 0.6114211 var113 -0.0972988693 0.2237430 -0.434868813 0.6668767 var114 0.0475762687 0.2010286 0.236664132 0.8145811 var115 0.2364360899 0.1812356 1.304578743 0.2022950 var116 -0.0985131354 0.1918563 -0.513473612 0.6115102 var117 -0.0894394214 0.2173996 -0.411405563 0.6837999 var118 -0.2355018204 0.2043250 -1.152584287 0.2584937 var119 0.0025381197 0.2468950 0.010280159 0.9918682 var120 -0.1427340796 0.2098195 -0.680270750 0.5017283 var121 -0.0565016310 0.2247369 -0.251412320 0.8032684 var122 -0.0455466677 0.2003293 -0.227358982 0.8217399 var123 0.1579742783 0.2883202 0.547912675 0.5879449 var124 0.1290270638 0.2496442 0.516843926 0.6091846 var125 0.0735269010 0.2161412 0.340180001 0.7361728 var126 -0.0074354274 0.2214263 -0.033579687 0.9734424 var127 -0.0202350963 0.2301697 -0.087913801 0.9305495 var128 0.0921409434 0.1946116 0.473460579 0.6394294 var129 0.0578351619 0.1972534 0.293202402 0.7714554 var130 0.0457446540 0.1811477 0.252526816 0.8024152 var131 -0.0497481279 0.2395549 -0.207669049 0.8369389 var132 -0.0716169797 0.2264069 -0.316319726 0.7540255 var133 -0.0834890066 0.2330487 -0.358247063 0.7227531 var134 0.0078486400 0.2177636 0.036042020 0.9714958 var135 0.0569885547 0.2341690 0.243365105 0.8094359 var136 -0.0880888941 0.2153686 -0.409014568 0.6855340 var137 0.0931535379 0.2469843 0.377163735 0.7087980 var138 0.0029921816 0.2751486 0.010874785 0.9913978 var139 0.0215558011 0.2147867 0.100359093 0.9207499 var140 0.0379439385 0.2406773 0.157654833 0.8758214 var141 0.1288009147 0.2085225 0.617683396 0.5416046 var142 -0.0627699322 0.2098144 -0.299168892 0.7669448 var143 0.1471235930 0.2412491 0.609841087 0.5467163 var144 0.0418985129 0.2434882 0.172076181 0.8645729 var145 0.1581333558 0.2214480 0.714088092 0.4808812 var146 0.2109672906 0.2233900 0.944389874 0.3527727 var147 -0.1305882685 0.2529765 -0.516207076 0.6096237 var148 0.1715603371 0.2701917 0.634957851 0.5304342 var149 -0.0674028658 0.2036219 -0.331019746 0.7430096 var150 -0.1809329622 0.2498705 -0.724106996 0.4748015 var151 -0.0618254790 0.2176185 -0.284100247 0.7783522 var152 -0.0644645613 0.2754214 -0.234057917 0.8165845 var153 -0.0185217288 0.2208211 -0.083876614 0.9337309 var154 0.0963509748 0.2313142 0.416537290 0.6800839 var155 0.0669555139 0.1933443 0.346302031 0.7316158 var156 0.1341679917 0.2524602 0.531442178 0.5991599 var157 0.0014091507 0.2640273 0.005337141 0.9957781 var158 0.1912096659 0.1695380 1.127827842 0.2686376 var159 0.1049270995 0.2414864 0.434505156 0.6671377 var160 0.1407325985 0.2455352 0.573166587 0.5709501 var161 -0.0149350788 0.2301044 -0.064905660 0.9486945 var162 -0.1567496204 0.2009329 -0.780109241 0.4416476 var163 0.0881458138 0.1865732 0.472446196 0.6401445 var164 -0.0429862791 0.1842946 -0.233247688 0.8172076 var165 0.0080105136 0.2145006 0.037344952 0.9704659 var166 -0.0374778798 0.2318411 -0.161653296 0.8726999 var167 0.1385838635 0.2867304 0.483324640 0.6324945 var168 -0.0734288141 0.3050426 -0.240716561 0.8114685 var169 -0.1266495195 0.2501795 -0.506234633 0.6165190 var170 0.0071467393 0.2711878 0.026353468 0.9791559 var171 -0.0255859731 0.1960230 -0.130525331 0.8970520 var172 0.1516581037 0.2794876 0.542629017 0.5915315 var173 -0.2106472762 0.2586949 -0.814269164 0.4221271 var174 -0.0308347530 0.1917615 -0.160797399 0.8733679 var175 0.0076295054 0.3046328 0.025044924 0.9801907 var176 0.1793572809 0.2037214 0.880404570 0.3858783 var177 0.1064141211 0.2557243 0.416128313 0.6803797 var178 0.0906223259 0.1983712 0.456832105 0.6511953 var179 0.0435110825 0.2579405 0.168686498 0.8672143 var180 -0.1264325305 0.2161180 -0.585016152 0.5630615 var181 -0.0968032660 0.2302398 -0.420445421 0.6772593 var182 0.1430811907 0.2453891 0.583078722 0.5643475 var183 0.0307419406 0.2604510 0.118033506 0.9068549 var184 -0.0319429988 0.2463878 -0.129645214 0.8977422 var185 0.0461719964 0.2008406 0.229893732 0.8197882 var186 -0.2385322379 0.2385500 -0.999925395 0.3256175 var187 0.0850810205 0.2238337 0.380108258 0.7066348 var188 0.3949689631 0.2554732 1.546028733 0.1329419 var189 0.1245166753 0.2747638 0.453177206 0.6537938 var190 0.1720563316 0.1879732 0.915323611 0.3675705 var191 0.2144640136 0.2413709 0.888524686 0.3815695 var192 0.0501975420 0.2506340 0.200282260 0.8426578 var193 0.1174708714 0.1746616 0.672562616 0.5065496 var194 -0.1943912402 0.3087673 -0.629571991 0.5339036 var195 0.0202300723 0.1915222 0.105627803 0.9166049 var196 0.0210580247 0.2176811 0.096737972 0.9235999 var197 0.0726236855 0.2177147 0.333572658 0.7411020 var198 0.1064539412 0.2261034 0.470819639 0.6412918 var199 -0.0767767634 0.2594113 -0.295965345 0.7693656 var200 -0.0624521254 0.2431441 -0.256852333 0.7991064 var201 0.0028300645 0.2063768 0.013713095 0.9891528 var202 -0.1715330103 0.2434880 -0.704482359 0.4867518 var203 0.2115665862 0.2486851 0.850740856 0.4018833 var204 0.0338181429 0.2280774 0.148274859 0.8831521 var205 0.0167958834 0.2489778 0.067459374 0.9466790 var206 -0.0590878112 0.1959422 -0.301557386 0.7651414 var207 -0.1653100651 0.2678547 -0.617163149 0.5419429 var208 -0.0740487318 0.2976417 -0.248784829 0.8052807 var209 -0.0043391023 0.2286282 -0.018978862 0.9849879 var210 0.3393487726 0.2358674 1.438726974 0.1609341 var211 0.2223498489 0.2661974 0.835281675 0.4103882 var212 0.0213281741 0.2315918 0.092093805 0.9272568 var213 0.2230110595 0.2581936 0.863735666 0.3948210 var214 -0.1228075434 0.2065047 -0.594696099 0.5566586 var215 -0.0104634410 0.2454306 -0.042632989 0.9662863 var216 0.0326754989 0.1978876 0.165121515 0.8699940 var217 -0.4439139348 0.3244134 -1.368358977 0.1817084 var218 -0.1087432871 0.2499652 -0.435033655 0.6667585 var219 -0.0107897918 0.2111081 -0.051110265 0.9595881 var220 -0.0296175151 0.2005449 -0.147685200 0.8836133 var221 0.1091241015 0.2479581 0.440090806 0.6631341 var222 0.0909297736 0.2382558 0.381647734 0.7055049 var223 -0.3485310127 0.2994113 -1.164054343 0.2538897 var224 0.0832890933 0.2243884 0.371182680 0.7131995 var225 -0.0042697108 0.3003295 -0.014216755 0.9887544 var226 0.0593458113 0.2310813 0.256817880 0.7991327 var227 -0.0182956931 0.1938017 -0.094404189 0.9254374 var228 0.0572344159 0.2343684 0.244207074 0.8087900 var229 -0.1231669279 0.2605563 -0.472707582 0.6399602 var230 0.0492497234 0.2111087 0.233290802 0.8171745 var231 -0.2862525037 0.1914503 -1.495179287 0.1456712 var232 0.1834105207 0.1939787 0.945519089 0.3522060 var233 0.2081280243 0.1632040 1.275263095 0.2123381 var234 0.1641204059 0.2272942 0.722061495 0.4760391 var235 0.2472694582 0.1902445 1.299745561 0.2039253 var236 0.0683823801 0.2231440 0.306449594 0.7614518 var237 0.1891842675 0.2214505 0.854295987 0.3999433 var238 -0.0489319878 0.2340164 -0.209096383 0.8358349 var239 0.1490499844 0.2429465 0.613509393 0.5443221 var240 -0.0095798604 0.2533123 -0.037818383 0.9700916 var241 0.0721964545 0.1969929 0.366492592 0.7166580 var242 -0.0126839937 0.2087745 -0.060754522 0.9519715 var243 -0.2221525719 0.1983111 -1.120222514 0.2718109 var244 -0.0829084901 0.2055738 -0.403302790 0.6896837 var245 -0.0318090335 0.2292748 -0.138737596 0.8906165 var246 -0.0425994225 0.2283779 -0.186530377 0.8533276 var247 0.0033944363 0.2129927 0.015936864 0.9873939 var248 0.0984076551 0.2343675 0.419886173 0.6776632 var249 -0.2148911884 0.2120962 -1.013177766 0.3193544 var250 -0.1875432344 0.2503294 -0.749185930 0.4597794 var251 -0.1735721485 0.2906428 -0.597200849 0.5550079 var252 0.2886948591 0.2512542 1.149015262 0.2599386 var253 0.1467087046 0.2485217 0.590325564 0.5595449 var254 -0.0834815473 0.2384597 -0.350086644 0.7288036 var255 -0.0635576566 0.2733631 -0.232502667 0.8177807 var256 -0.0346030600 0.3391339 -0.102033634 0.9194322 var257 -0.1224921370 0.1991311 -0.615133252 0.5432640 var258 -0.2423169128 0.2163175 -1.120191176 0.2718240 var259 -0.0021922047 0.2169919 -0.010102701 0.9920085 var260 -0.0818789537 0.2213754 -0.369864799 0.7141707 var261 -0.0707600938 0.2111357 -0.335140308 0.7399315 var262 -0.3301726263 0.2521985 -1.309177801 0.2007530 var263 -0.2602526557 0.2351244 -1.106872336 0.2774464 var264 -0.1427837485 0.2547866 -0.560405290 0.5795071 var265 -0.1315034492 0.2038109 -0.645222811 0.5238552 var266 0.1292166855 0.1857550 0.695629819 0.4921980 var267 0.0265412839 0.2291648 0.115817440 0.9085955 var268 0.1111883441 0.2630197 0.422737718 0.6756049 var269 0.1302021867 0.2400981 0.542287436 0.5917637 var270 -0.0923837589 0.2552903 -0.361877334 0.7200673 var271 -0.0680064479 0.2072222 -0.328181232 0.7451325 var272 -0.1776069310 0.2287416 -0.776452095 0.4437692 var273 -0.0374118346 0.2277425 -0.164272515 0.8706562 var274 0.0877037245 0.2180473 0.402223481 0.6904689 var275 -0.0016240717 0.2913139 -0.005574988 0.9955900 var276 0.1670149940 0.2327284 0.717639018 0.4787213 var277 0.1542172653 0.2293724 0.672344500 0.5066864 var278 -0.0108006893 0.2634879 -0.040991220 0.9675838 var279 0.1334885400 0.2086489 0.639775940 0.5273407 var280 0.1637485211 0.2134740 0.767065523 0.4492427 var281 0.0649039066 0.1972117 0.329107849 0.7444393 var282 -0.0277897733 0.2630854 -0.105630223 0.9166030 var283 0.1978208690 0.1913322 1.033913324 0.3097222 var284 0.0984930229 0.2972660 0.331329592 0.7427780 var285 -0.1113854013 0.2238975 -0.497483952 0.6225990 var286 0.0770616839 0.2067096 0.372801690 0.7120070 var287 -0.0634971052 0.2337652 -0.271627762 0.7878326 var288 0.1652137421 0.2168261 0.761964380 0.4522341 var289 -0.0984475187 0.2827889 -0.348130788 0.7302565 var290 0.1166070472 0.1940659 0.600863259 0.5525988 var291 -0.0682754836 0.2270118 -0.300757444 0.7657452 var292 0.1016526112 0.2081493 0.488363972 0.6289646 var293 -0.2976518291 0.2175924 -1.367932916 0.1818403 var294 -0.1119627963 0.2411543 -0.464278710 0.6459147 var295 0.2734232937 0.2291048 1.193442092 0.2423685 var296 -0.1054927068 0.2409970 -0.437734561 0.6648217 var297 -0.2151298321 0.3031934 -0.709546479 0.4836518 var298 0.0208265210 0.2160796 0.096383564 0.9238789 var299 0.0882009038 0.2477594 0.355994206 0.7244217 var300 0.1604547308 0.2218983 0.723100206 0.4754104 > expect.err(try(predict(linmod.bigdat, newdata=bigdat[,1:(p-3)])), "object 'var297' not found") Error in eval(predvars, data, env) : object 'var297' not found Got expected error from try(predict(linmod.bigdat, newdata = bigdat[, 1:(p - 3)])) > plot(linmod.bigdat) > # plotmo(linmod.bigdat) # works, but commented out because slow(ish) > # plotres(linmod.bigdat) # ditto > > cat0("==check use of matrix as data in linmod.form\n") ==check use of matrix as data in linmod.form > # linmod.form allows a matrix, lm doesn't TODO is this inconsistency what we want? > tr.mat <- as.matrix(tr) > cat0("class(tr.mat)=", class(tr.mat), "\n") # class(tr.mat)=matrix class(tr.mat)=matrixarray > expect.err(try(lm(Volume~., data=tr.mat)), "'data' must be a data.frame, not a matrix or an array") Error in model.frame.default(formula = Volume ~ ., data = tr.mat, drop.unused.levels = TRUE) : 'data' must be a data.frame, not a matrix or an array Got expected error from try(lm(Volume ~ ., data = tr.mat)) > linmod.form.Volume.mat.tr <- linmod(Volume~., data=tr.mat) > check.lm(linmod.form.Volume.mat.tr, linmod.form.Volume.tr) check linmod.form.Volume.mat.tr vs linmod.form.Volume.tr > cat0("==print(summary(linmod.form.Volume.mat.tr))\n") ==print(summary(linmod.form.Volume.mat.tr)) > print(summary(linmod.form.Volume.mat.tr)) Call: linmod.formula(formula = Volume ~ ., data = tr.mat) Estimate StdErr t.value p.value (Intercept) -57.9876589 8.6382259 -6.712913 2.749507e-07 Girth 4.7081605 0.2642646 17.816084 8.223304e-17 Height 0.3392512 0.1301512 2.606594 1.449097e-02 > plotres(linmod.form.Volume.mat.tr) > > tr.mat.no.colnames <- as.matrix(tr) > colnames(tr.mat.no.colnames) <- NULL > expect.err(try(linmod(Volume~., data=tr.mat.no.colnames)), "object 'Volume' not found") Error in eval(predvars, data, env) : object 'Volume' not found Got expected error from try(linmod(Volume ~ ., data = tr.mat.no.colnames)) > linmod.form.Volume.mat.tr.no.colnames <- linmod(V3~., data=tr.mat.no.colnames) > check.lm(linmod.form.Volume.mat.tr.no.colnames, linmod.form.Volume.tr, + check.coef.names=FALSE, check.newdata=FALSE) # no check.newdata else object 'V1' not found check linmod.form.Volume.mat.tr.no.colnames vs linmod.form.Volume.tr > > # Check what happens when we change the original data used to build the model. > # Use plotres as an example function that must figure out residuals from predict(). > > pr <- function(model, main=deparse(substitute(model))) + { + plotres(model, which=3, main=main) # which=3 for just the residuals plot + } > cat0("==linmod.formula: change data used to build the model\n") ==linmod.formula: change data used to build the model > > trees1 <- trees > linmod.trees1 <- linmod(Volume~., data=trees1) > # delete the saved residuals and fitted.values so plotres has to use the saved > # call etc. to get the x and y used to build the model, and rely on predict() > linmod.trees1$residuals <- NULL > linmod.trees1$fitted.values <- NULL > par(mfrow=c(3,3)) > pr(linmod.trees1) > trees1 <- trees[, 3:1] # change column order in original data > pr(linmod.trees1, "change col order") > trees1 <- trees[1:3, ] # change number of rows in original data > pr(linmod.trees1, "change nbr rows") # TODO wrong residuals! (lm has the same issue) > cat("call$data now refers to the changed data:\n") # lm has the same problem if called with model=FALSE call$data now refers to the changed data: > print(eval(linmod.trees1$call$data)) Girth Height Volume 1 8.3 70 10.3 2 8.6 65 10.3 3 8.8 63 10.2 > cat("model.frame now returns the changed data:\n") model.frame now returns the changed data: > print(model.frame(linmod.trees1)) Volume Girth Height 1 10.3 8.3 70 2 10.3 8.6 65 3 10.2 8.8 63 > trees1 <- trees[nrow(tr):1, ] # change row order (but keep same nbr of rows) > pr(linmod.trees1, "change row order") > colnames(trees1) <- c("x1", "x2", "x3") # change column names in original data > expect.err(try(pr(linmod.trees1, + "change colnames")), "cannot get the original model predictors") Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: object 'Volume' not found (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(pr(linmod.trees1, "change colnames")) > trees1 <- "garbage" > expect.err(try(pr(linmod.trees1, + "trees1=\"garbage\"")), "cannot get the original model predictors") Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: object 'Volume' not found (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(pr(linmod.trees1, "trees1=\"garbage\"")) > trees1 <- 1:1000 > expect.err(try(pr(linmod.trees1, + "trees1=1:1000")), "cannot get the original model predictors") Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: object 'Volume' not found (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(pr(linmod.trees1, "trees1=1:1000")) > trees1 <- NULL # original data no longer available > expect.err(try(pr(linmod.trees1, + "trees1=NULL")), "cannot get the original model predictors") Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: object 'Volume' not found (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(pr(linmod.trees1, "trees1=NULL")) > remove(trees1) > expect.err(try(pr(linmod.trees1, + "remove(trees1)")), "cannot get the original model predictors") Error in eval(expr, envir, enclos) : object 'trees1' not found Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: object 'Volume' not found (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(pr(linmod.trees1, "remove(trees1)")) > > # similar to above, but don't delete the saved residuals and fitted.values > trees1 <- trees > linmod2.trees1 <- linmod(Volume~., data=trees1) > trees1 <- trees[1:3, ] # change number of rows in original data > expect.err(try(plotmo(linmod2.trees1)), "plotmo_y returned the wrong length (got 3 but expected 31)") Error : plotmo_y returned the wrong length (got 3 but expected 31) Got expected error from try(plotmo(linmod2.trees1)) > > par(org.par) > > cat0("==linmod.formula(keep=TRUE): change data used to build the model\n") ==linmod.formula(keep=TRUE): change data used to build the model > par(mfrow=c(3,3)) > trees1 <- trees > linmod.trees1.keep <- linmod(Volume~., data=trees1, keep=TRUE) > # delete the saved residuals and fitted.values so plotres has to use the saved > # call etc. to get the x and y used to build the model, and rely on predict() > linmod.trees1.keep$residuals <- NULL > linmod.trees1.keep$fitted.values <- NULL > pr(linmod.trees1.keep) > trees1 <- trees[, 3:1] # change column order in original data > pr(linmod.trees1.keep, "change col order") > trees1 <- trees[1:3, ] # change number of rows in original data > pr(linmod.trees1.keep, "change nbr rows") > trees1 <- trees[nrow(tr):1, ] # change row order (but keep same nbr of rows) > pr(linmod.trees1.keep, "change row order") > colnames(trees1) <- c("x1", "x2", "x3") # change column names in original data > pr(linmod.trees1.keep, "change colnames") > trees1 <- NULL # original data no longer available > pr(linmod.trees1.keep, "trees1=NULL") > remove(trees1) > pr(linmod.trees1.keep, "remove(trees1)") > par(org.par) > > cat0("==linmod.default: change data used to build the model\n") ==linmod.default: change data used to build the model > trees1 <- trees > x1 <- trees1[,1:2] > y1 <- trees1[,3] > linmod.xy <- linmod(x1, y1) > # delete the saved residuals and fitted.values so plotres has to use the saved > # call etc. to get the x1 and y1 used to build the model, and rely on predict() > linmod.xy$residuals <- NULL > linmod.xy$fitted.values <- NULL > par(mfrow=c(3,3)) > pr(linmod.xy) > x1 <- trees1[,2:1] # change column order in original x1 > pr(linmod.xy, "change col order") > x1 <- trees1[1:3, 1:2] # change number of rows in original x1 > expect.err(try(pr(linmod.xy, "change nbr rows")), + "plotmo_y returned the wrong length (got 31 but expected 3)") # TODO different behaviour to linmod.trees1 Error : plotmo_y returned the wrong length (got 31 but expected 3) Got expected error from try(pr(linmod.xy, "change nbr rows")) > cat("call$x1 now refers to the changed x1:\n") # lm has the same problem if called with model=FALSE call$x1 now refers to the changed x1: > print(eval(linmod.xy$call$x1)) NULL > x1 <- trees1[nrow(tr):1, 1:2] # change row order (but keep same nbr of rows) > pr(linmod.xy, "change row order") > x1 <- trees1[,1:2] > colnames(x1) <- c("x1", "x2") # change column names in original x1 > pr(linmod.xy, "change colnames") > x1 <- "garbage" > expect.err(try(pr(linmod.xy, "x1=\"garbage\"")), "cannot get the original model predictors") Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: no formula in getCall(object) (3) getCall(object)$x: garbage Error : cannot get the original model predictors Got expected error from try(pr(linmod.xy, "x1=\"garbage\"")) > x1 <- 1:1000 > expect.err(try(pr(linmod.xy, "x1=1:1000")), "ncol(newdata) is 1 but should be 2") stats::predict(linmod.object, data.frame[3,1], type="response") Error in predict.linmod(structure(list(coefficients = c(`(Intercept)` = -57.987658918381, : ncol(newdata) is 1 but should be 2 Got expected error from try(pr(linmod.xy, "x1=1:1000")) > x1 <- NULL # original x1 no longer available > expect.err(try(pr(linmod.xy, "x1=NULL")), "cannot get the original model predictors") Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: no formula in getCall(object) (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(pr(linmod.xy, "x1=NULL")) > remove(x1) > expect.err(try(pr(linmod.xy, "remove(x1)")), "cannot get the original model predictors") Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: no formula in getCall(object) (3) getCall(object)$x: object 'x1' not found Error : cannot get the original model predictors Got expected error from try(pr(linmod.xy, "remove(x1)")) > > # similar to above, but don't delete the saved residuals and fitted.values > trees1 <- trees > x1 <- trees1[,1:2] > y1 <- trees1[,3] > linmod.xy <- linmod(x1, y1) > x1 <- trees1[1:3, 1:2] # change number of rows in original x1 > expect.err(try(plotmo(linmod2.x1)), "object 'linmod2.x1' not found") # TODO error message misleading? Error : object 'linmod2.x1' not found Got expected error from try(plotmo(linmod2.x1)) > > par(org.par) > > cat0("==linmod.default(keep=TRUE): change data used to build the model\n") ==linmod.default(keep=TRUE): change data used to build the model > par(mfrow=c(3,3)) > trees1 <- trees > x1 <- trees1[,1:2] > linmod.xy <- linmod(x1, y1, keep=TRUE) > # delete the saved residuals and fitted.values so plotres has to use the saved > # call etc. to get the x1 and y1 used to build the model, and rely on predict() > linmod.xy$residuals <- NULL > linmod.xy$fitted.values <- NULL > pr(linmod.xy.keep) > x1 <- trees1[, 2:1] # change column order in original x1 > pr(linmod.xy.keep, "change col order") > x1 <- trees1[1:3, 1:2] # change number of rows in original x1 > pr(linmod.xy.keep, "change nbr rows") > x1 <- trees1[nrow(tr):1, 1:2] # change row order (but keep same nbr of rows) > pr(linmod.xy.keep, "change row order") > x1 <- trees1[,1:2] > colnames(x1) <- c("x1", "x2") # change column names in original x1 > pr(linmod.xy.keep, "change colnames") > x1 <- NULL # original x1 no longer available > pr(linmod.xy.keep, "x1=NULL") > remove(x1) > pr(linmod.xy.keep, "remove(x1)") > par(org.par) > > cat("==test processing a model created in a function with local data\n") ==test processing a model created in a function with local data > > # pr <- function(model, main=deparse(substitute(model))) > # { > # plotmo(model, degree1=1, degree2=0, pt.col=2, do.par=FALSE, main=main) > # } > pr <- function(model, main=deparse(substitute(model))) + { + plotres(model, which=3, main=main) # which=3 for just the residuals plot + } > lm.form.func <- function(keep=FALSE) + { + local.tr <- trees[1:20,] + lm(Volume~., data=local.tr, model=keep) + } > linmod.form.func <- function(keep=FALSE) + { + local.tr <- trees[1:20,] + model <- linmod(Volume~., data=local.tr, keep=keep) + # delete the saved residuals and fitted.values so plotres has to use the saved + # call etc. to get the x and y used to build the model, and rely on predict() + model$residuals <- NULL + model$fitted.values <- NULL + model + } > linmod.xy.func <- function(keep) + { + xx <- trees[1:20,1:2] + yy <- trees[1:20,3] + model <- linmod(xx, yy, keep=keep) + # delete the saved residuals and fitted.values so plotres has to use the saved + # call etc. to get the x and y used to build the model, and rely on predict() + model$residuals <- NULL + model$fitted.values <- NULL + model + } > par(mfrow=c(3,2)) > > lm.form <- lm.form.func(keep=FALSE) > pr(lm.form) > > lm.form.keep <- lm.form.func(keep=TRUE) > pr(lm.form.keep) > > linmod.form <- linmod.form.func(keep=FALSE) > pr(linmod.form) > > linmod.form.keep <- linmod.form.func(keep=TRUE) > pr(linmod.form.keep) > > linmod.xy <- linmod.xy.func(keep=FALSE) > expect.err(try(pr(linmod.xy)), "cannot get the original model predictors") Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: no formula in getCall(object) (3) getCall(object)$x: object 'xx' not found Error : cannot get the original model predictors Got expected error from try(pr(linmod.xy)) > > linmod.xy.keep <- linmod.xy.func(keep=TRUE) > pr(linmod.xy.keep) > > par(org.par) > > # test xlevels (predict with newdata using a string to represent a factor) > data(iris) > linmod.Sepal.Length <- linmod(Sepal.Length~Species,data=iris) > lm.Sepal.Length <- lm(Sepal.Length~Species,data=iris) > predict.linmod <- predict(linmod.Sepal.Length, newdata=data.frame(Species="setosa")) > predict.lm <- predict(lm.Sepal.Length, newdata=data.frame(Species="setosa")) > stopifnot(all.equal(predict.linmod, predict.lm)) > > source("test.epilog.R") plotmo/inst/slowtests/test.center.bat0000755000176200001440000000154514655214117017554 0ustar liggesusers@rem test.center.bat: test plotmo's center and ndiscrete args @rem Stephen Milborrow, Berea Apr 2011 @echo test.center.bat @"C:\PROGRA~1\R\R-4.4.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.plotmo.x.bat0000755000176200001440000000152214655214117020047 0ustar liggesusers@rem test.plotmo.x.bat: test plotmo_x and related functions @echo test.plotmo.x.bat @"C:\PROGRA~1\R\R-4.4.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.plotmo.x.Rout.save0000644000176200001440000007232614563614021021172 0ustar liggesusers> # test.plotmo.x.R: test plotmo_x and related functions > > source("test.prolog.R") > library(plotmo) Loading required package: Formula Loading required package: plotrix > library(earth) > options(warn=1) # print warnings as they occur > data(ozone1) > data(etitanic) > get.tit <- function() + { + tit <- etitanic + pclass <- as.character(tit$pclass) + # change the order of the factors so not alphabetical + pclass[pclass == "1st"] <- "first" + pclass[pclass == "2nd"] <- "class2" + pclass[pclass == "3rd"] <- "classthird" + tit$pclass <- factor(pclass, levels=c("class2", "classthird", "first")) + # log age is so we have a continuous predictor even when model is age~. + set.seed(2015) + tit$logage <- log(tit$age) + rnorm(nrow(tit)) + tit$parch <- NULL + # by=12 gives us a small fast model with an additive and a interaction term + tit <- tit[seq(1, nrow(etitanic), by=12), ] + } > X <- X1 <- X2 <- Y <- DF <- NULL > get.data <- function() + { + X <<- matrix(c(1,2,3,4,5,6,7,8,9, + 2,3,3,5,6,7,8,9,9), ncol=2) + colnames(X) <- c("xx1", "xx2") + X1 <<- X[,1] + X2 <<- X[,2] + Y <<- c(1,2,7,4,5,6,6,6,6) + DF <<- data.frame(Y=Y, X1=X1, X2=X2) + } > stopifnot1 <- function(x, y){ + xname <- deparse(substitute(x)) + yname <- deparse(substitute(y)) + if(!all(x == y)) + stop(sprint("%s == %s failed\n", xname, yname, call.=FALSE)) + printf("%s == %s passed\n", xname, yname) + } > printf("====== standard earth.formula model with a data frame\n") ====== standard earth.formula model with a data frame > > get.data() > earth.form.df.dot <- earth(Y~., data=DF) > plotmo(earth.form.df.dot, caption="test basic use of DF") plotmo grid: X1 X2 5 6 > printf("-- test basic use of DF\n") -- test basic use of DF > rv <- plotmo(earth.form.df.dot, trace=100) plotmo trace 100: plotmo(object=earth.form.df.dot, trace=100) --get.model.env for object with class earth object call is earth(formula=Y~., data=DF) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.form.df.dot' > stopifnot1(rv, X) rv == X passed > > printf("-- test use same DF even when other variables change\n") -- test use same DF even when other variables change > get.data() > earth.form.df.dot <- earth(Y~., data=DF) > X1 <- "rubbish" > rv <- plotmo(earth.form.df.dot, trace=100) plotmo trace 100: plotmo(object=earth.form.df.dot, trace=100) --get.model.env for object with class earth object call is earth(formula=Y~., data=DF) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.form.df.dot' > stopifnot1(rv, X) rv == X passed > > printf("-- test detect that DF is now trashed\n") -- test detect that DF is now trashed > get.data() > earth.form.df.dot <- earth(Y~., data=DF) > DF <- "rubbish" > X1 <- "rubbish" # DF is corrupt and will treated as NULL by plotmo, so make sure plotmo doesn't find the global X1 > # invalid 'envir' argument of type 'character' > expect.err(try(plotmo(earth.form.df.dot, trace=100)), "cannot get the original model predictors") plotmo trace 100: plotmo(object=earth.form.df.dot, trace=100) --get.model.env for object with class earth object call is earth(formula=Y~., data=DF) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.form.df.dot' Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: variable lengths differ (found for 'X1') (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(plotmo(earth.form.df.dot, trace = 100)) > > # Removed this test because this no longer fails, because we get the formula using formula(object) > # printf("-- DF is NULL so will get '.' in formula and no 'data' argument\n") > # get.data() > # earth.form.df.dot <- earth(Y~., data=DF) > # DF <- NULL > # # '.' in formula and no 'data' argument > # expect.err(try(plotmo(earth.form.df.dot, trace=100)), "cannot get the original model predictors") > > printf("-- DF is NULL so will pick up X1 with same values from global environment\n") -- DF is NULL so will pick up X1 with same values from global environment > get.data() > earth.form.df <- earth(Y~X1+X2, data=DF) > DF <- NULL > rv <- plotmo(earth.form.df, trace=100) plotmo trace 100: plotmo(object=earth.form.df, trace=100) --get.model.env for object with class earth object call is earth(formula=Y~X1+X2, data=DF) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.form.df' > stopifnot1(rv, X) rv == X passed > > printf("-- DF is NULL so will will pick up trashed X1 from global environment\n") -- DF is NULL so will will pick up trashed X1 from global environment > earth.form.df <- earth(Y~X1+X2, data=DF) > DF <- NULL > X1 <- "rubbish" > # variable lengths differ (found for 'X1') > expect.err(try(plotmo(earth.form.df, trace=100)), "cannot get the original model predictors") plotmo trace 100: plotmo(object=earth.form.df, trace=100) --get.model.env for object with class earth object call is earth(formula=Y~X1+X2, data=DF) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.form.df' Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: variable lengths differ (found for 'X1') (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(plotmo(earth.form.df, trace = 100)) > > printf("-- DF has only one column, so will pick up X1 from it and X2 from global environment\n") -- DF has only one column, so will pick up X1 from it and X2 from global environment > get.data() > earth.form.df <- earth(Y~X1+X2, data=DF) > DF <- data.frame(Y=Y, X1=X1) > DF[1,2] <- 99 > X2[1] <- 98 > rv <- plotmo(earth.form.df, trace=100) plotmo trace 100: plotmo(object=earth.form.df, trace=100) --get.model.env for object with class earth object call is earth(formula=Y~X1+X2, data=DF) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.form.df' > stopifnot1(rv[1,1], 99) rv[1, 1] == 99 passed > stopifnot1(rv[1,2], 98) rv[1, 2] == 98 passed > > printf("-- sanity check, make sure we are back to normal\n") -- sanity check, make sure we are back to normal > get.data() > earth.form.df <- earth(Y~X1+X2, data=DF) > rv <- plotmo(earth.form.df, trace=100) plotmo trace 100: plotmo(object=earth.form.df, trace=100) --get.model.env for object with class earth object call is earth(formula=Y~X1+X2, data=DF) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.form.df' > stopifnot1(rv, X) rv == X passed > > printf("-- change the data frame, make sure we pick up the changed value\n") -- change the data frame, make sure we pick up the changed value > get.data() > earth.form.df <- earth(Y~X1+X2, data=DF) > DF[1,2] <- 99 > rv <- plotmo(earth.form.df, trace=100) plotmo trace 100: plotmo(object=earth.form.df, trace=100) --get.model.env for object with class earth object call is earth(formula=Y~X1+X2, data=DF) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.form.df' > stopifnot1(rv[1,1], 99) rv[1, 1] == 99 passed > > printf("-- change order of columns in the data frame, should be ok\n") -- change order of columns in the data frame, should be ok > get.data() > earth.form.df <- earth(Y~X1+X2, data=DF) > DF <- data.frame(X2=X2, X1=X1) > rv <- plotmo(earth.form.df, trace=100) plotmo trace 100: plotmo(object=earth.form.df, trace=100) --get.model.env for object with class earth object call is earth(formula=Y~X1+X2, data=DF) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.form.df' > stopifnot1(rv, X) rv == X passed > > printf("======= standard earth.formula model with a data frame and keepxy\n") ======= standard earth.formula model with a data frame and keepxy > > get.data() > earth.form.df.keepxy <- earth(Y~., data=DF, keepxy=TRUE) > printf("-- test basic use of DF\n") -- test basic use of DF > rv <- plotmo(earth.form.df.keepxy, trace=100) plotmo trace 100: plotmo(object=earth.form.df.keepxy, trace=100) --get.model.env for object with class earth object call is earth(formula=Y~., data=DF, keepxy=TRUE) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.form.df.keepxy' > stopifnot1(rv, X) rv == X passed > > printf("-- test use same DF even when other variables change\n") -- test use same DF even when other variables change > earth.form.df.keepxy <- earth(Y~., data=DF, keepxy=TRUE) > X1 <- "rubbish" > rv <- plotmo(earth.form.df.keepxy, trace=100) plotmo trace 100: plotmo(object=earth.form.df.keepxy, trace=100) --get.model.env for object with class earth object call is earth(formula=Y~., data=DF, keepxy=TRUE) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.form.df.keepxy' > stopifnot1(rv, X) rv == X passed > > printf("-- DF is now trashed but it doesn't matter because keepxy=T\n") -- DF is now trashed but it doesn't matter because keepxy=T > DF <- "rubbish" > rv <- plotmo(earth.form.df.keepxy, trace=100) plotmo trace 100: plotmo(object=earth.form.df.keepxy, trace=100) --get.model.env for object with class earth object call is earth(formula=Y~., data=DF, keepxy=TRUE) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.form.df.keepxy' > stopifnot1(rv, X) rv == X passed > > printf("-- DF is NULL but it doesn't matter because keepxy=T\n") -- DF is NULL but it doesn't matter because keepxy=T > get.data() > earth.form.df.keepxy <- earth(Y~., data=DF, keepxy=TRUE) > DF <- NULL > rv <- plotmo(earth.form.df.keepxy, trace=100) plotmo trace 100: plotmo(object=earth.form.df.keepxy, trace=100) --get.model.env for object with class earth object call is earth(formula=Y~., data=DF, keepxy=TRUE) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.form.df.keepxy' > stopifnot1(rv, X) rv == X passed > > printf("-- DF and X1 are NULL but it doesn't matter because keepxy=T\n") -- DF and X1 are NULL but it doesn't matter because keepxy=T > DF <- NULL > X1 <- "rubbish" > rv <- plotmo(earth.form.df.keepxy, trace=100) plotmo trace 100: plotmo(object=earth.form.df.keepxy, trace=100) --get.model.env for object with class earth object call is earth(formula=Y~., data=DF, keepxy=TRUE) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.form.df.keepxy' > stopifnot1(rv, X) rv == X passed > > printf("-- sanity check, make sure we are back to normal\n") -- sanity check, make sure we are back to normal > get.data() > earth.form.df.keepxy <- earth(Y~., data=DF, keepxy=TRUE) > rv <- plotmo(earth.form.df.keepxy, trace=100) plotmo trace 100: plotmo(object=earth.form.df.keepxy, trace=100) --get.model.env for object with class earth object call is earth(formula=Y~., data=DF, keepxy=TRUE) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.form.df.keepxy' > stopifnot1(rv, X) rv == X passed > > printf("-- change the data frame, but it doesn't matter because keepxy=T\n") -- change the data frame, but it doesn't matter because keepxy=T > get.data() > earth.form.df.keepxy <- earth(Y~., data=DF, keepxy=TRUE) > DF[1,2] <- 99 > rv <- plotmo(earth.form.df.keepxy, trace=100) plotmo trace 100: plotmo(object=earth.form.df.keepxy, trace=100) --get.model.env for object with class earth object call is earth(formula=Y~., data=DF, keepxy=TRUE) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.form.df.keepxy' > stopifnot1(rv, X) rv == X passed > > printf("-- change order of columns in the data frame, should be ok\n") -- change order of columns in the data frame, should be ok > get.data() > earth.form.df.keepxy <- earth(Y~., data=DF, keepxy=TRUE) > DF <- data.frame(X2=X2, X1=X1) > rv <- plotmo(earth.form.df.keepxy, trace=100) plotmo trace 100: plotmo(object=earth.form.df.keepxy, trace=100) --get.model.env for object with class earth object call is earth(formula=Y~., data=DF, keepxy=TRUE) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.form.df.keepxy' > stopifnot1(rv, X) rv == X passed > > printf("======= standard lm model with a data frame but with model=FALSE\n") ======= standard lm model with a data frame but with model=FALSE > > get.data() > lm.form.df.model.false.with.dot <- lm(Y~., data=DF, model=FALSE) > printf("-- test basic use of DF\n") -- test basic use of DF > rv <- plotmo(lm.form.df.model.false.with.dot, trace=100) plotmo trace 100: plotmo(object=lm.form.df.model.false.with.dot, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~., data=DF, model=FALSE) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.model.false.with.dot' > stopifnot1(rv, X) rv == X passed > > printf("-- test use same DF even when other variables change\n") -- test use same DF even when other variables change > get.data() > lm.form.df.model.false.with.dot <- lm(Y~., data=DF, model=FALSE) > X1 <- "rubbish" > rv <- plotmo(lm.form.df.model.false.with.dot, trace=100) plotmo trace 100: plotmo(object=lm.form.df.model.false.with.dot, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~., data=DF, model=FALSE) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.model.false.with.dot' > stopifnot1(rv, X) rv == X passed > > printf("-- test detect that DF is now trashed\n") -- test detect that DF is now trashed > DF <- "rubbish" > # invalid 'envir' argument of type 'character' > expect.err(try(plotmo(lm.form.df.model.false.with.dot, trace=100)), "cannot get the original model predictors") plotmo trace 100: plotmo(object=lm.form.df.model.false.with.dot, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~., data=DF, model=FALSE) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.model.false.with.dot' Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: variable lengths differ (found for 'X1') (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(plotmo(lm.form.df.model.false.with.dot, trace = 100)) > > printf("-- DF is NULL so will pick up X1 with same values from global environment\n") -- DF is NULL so will pick up X1 with same values from global environment > get.data() > lm.form.df.model.false <- lm(Y~X1+X2, data=DF, model=FALSE) > DF <- NULL > rv <- plotmo(earth.form.df, trace=100) plotmo trace 100: plotmo(object=earth.form.df, trace=100) --get.model.env for object with class earth object call is earth(formula=Y~X1+X2, data=DF) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.form.df' > stopifnot1(rv, X) rv == X passed > > printf("-- DF is NULL so will will pick up trashed X1 from global environment\n") -- DF is NULL so will will pick up trashed X1 from global environment > get.data() > lm.form.df.model.false <- lm(Y~X1+X2, data=DF, model=FALSE) > DF <- NULL > X1 <- "rubbish" > # variable lengths differ (found for 'X1') > expect.err(try(plotmo(lm.form.df.model.false, trace=100)), "cannot get the original model predictors") plotmo trace 100: plotmo(object=lm.form.df.model.false, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~X1+X2, data=DF, model=FALSE) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.model.false' Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: variable lengths differ (found for 'X1') (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(plotmo(lm.form.df.model.false, trace = 100)) > > printf("-- sanity check, make sure we are back to normal\n") -- sanity check, make sure we are back to normal > get.data() > lm.form.df.model.false <- lm(Y~X1+X2, data=DF, model=FALSE) > rv <- plotmo(lm.form.df.model.false, trace=100) plotmo trace 100: plotmo(object=lm.form.df.model.false, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~X1+X2, data=DF, model=FALSE) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.model.false' > stopifnot1(rv, X) rv == X passed > > printf("-- change the data frame, make sure we pick up the changed value\n") -- change the data frame, make sure we pick up the changed value > get.data() > lm.form.df.model.false <- lm(Y~X1+X2, data=DF, model=FALSE) > DF[1,2] <- 99 > rv <- plotmo(lm.form.df.model.false, trace=100) plotmo trace 100: plotmo(object=lm.form.df.model.false, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~X1+X2, data=DF, model=FALSE) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.model.false' > stopifnot1(rv[1,1], 99) rv[1, 1] == 99 passed > > printf("-- change order of columns in the data frame, should be ok\n") -- change order of columns in the data frame, should be ok > get.data() > lm.form.df.model.false <- lm(Y~X1+X2, data=DF, model=FALSE) > DF <- data.frame(X2=X2, X1=X1) > rv <- plotmo(lm.form.df.model.false, trace=100) plotmo trace 100: plotmo(object=lm.form.df.model.false, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~X1+X2, data=DF, model=FALSE) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.model.false' > stopifnot1(rv, X) rv == X passed > > printf("======= standard lm with a data frame and model=TRUE (the default)\n") ======= standard lm with a data frame and model=TRUE (the default) > > get.data() > lm.form.df.with.dot <- lm(Y~., data=DF) > printf("-- test basic use of DF\n") -- test basic use of DF > rv <- plotmo(lm.form.df.with.dot, trace=100) plotmo trace 100: plotmo(object=lm.form.df.with.dot, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~., data=DF) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.with.dot' > stopifnot1(rv, X) rv == X passed > > printf("-- test use same DF even when other variables change\n") -- test use same DF even when other variables change > get.data() > lm.form.df.with.dot <- lm(Y~., data=DF) > X1 <- "rubbish" > rv <- plotmo(lm.form.df.with.dot, trace=100) plotmo trace 100: plotmo(object=lm.form.df.with.dot, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~., data=DF) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.with.dot' > stopifnot1(rv, X) rv == X passed > > printf("-- DF is now trashed but it doesn't matter because keepxy=T\n") -- DF is now trashed but it doesn't matter because keepxy=T > DF <- "rubbish" > rv <- plotmo(lm.form.df.with.dot, trace=100) plotmo trace 100: plotmo(object=lm.form.df.with.dot, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~., data=DF) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.with.dot' > stopifnot1(rv, X) rv == X passed > > printf("-- DF is NULL but it doesn't matter because keepxy=T\n") -- DF is NULL but it doesn't matter because keepxy=T > get.data() > lm.form.df.with.dot <- lm(Y~., data=DF) > DF <- NULL > rv <- plotmo(lm.form.df.with.dot, trace=100) plotmo trace 100: plotmo(object=lm.form.df.with.dot, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~., data=DF) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.with.dot' > stopifnot1(rv, X) rv == X passed > > printf("-- DF and X1 are NULL but it doesn't matter because keepxy=T\n") -- DF and X1 are NULL but it doesn't matter because keepxy=T > DF <- NULL > X1 <- "rubbish" > rv <- plotmo(lm.form.df.with.dot, trace=100) plotmo trace 100: plotmo(object=lm.form.df.with.dot, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~., data=DF) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.with.dot' > stopifnot1(rv, X) rv == X passed > > printf("-- sanity check, make sure we are back to normal\n") -- sanity check, make sure we are back to normal > get.data() > lm.form.df.with.dot <- lm(Y~., data=DF) > rv <- plotmo(lm.form.df.with.dot, trace=100) plotmo trace 100: plotmo(object=lm.form.df.with.dot, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~., data=DF) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.with.dot' > stopifnot1(rv, X) rv == X passed > > printf("-- change the data frame, but it doesn't matter because keepxy=T\n") -- change the data frame, but it doesn't matter because keepxy=T > get.data() > lm.form.df.with.dot <- lm(Y~., data=DF) > DF[1,2] <- 99 > rv <- plotmo(lm.form.df.with.dot, trace=100) plotmo trace 100: plotmo(object=lm.form.df.with.dot, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~., data=DF) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.with.dot' > stopifnot1(rv, X) rv == X passed > > printf("-- change order of columns in the data frame, should be ok\n") -- change order of columns in the data frame, should be ok > get.data() > lm.form.df.with.dot <- lm(Y~., data=DF) > DF <- data.frame(X2=X2, X1=X1) > rv <- plotmo(lm.form.df.with.dot, trace=100) plotmo trace 100: plotmo(object=lm.form.df.with.dot, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~., data=DF) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.with.dot' > stopifnot1(rv, X) rv == X passed > > printf("======= standard lm with a data frame and model=FALSE but x=TRUE\n") ======= standard lm with a data frame and model=FALSE but x=TRUE > > get.data() > lm.form.df.model.false.x.true <- lm(Y~., data=DF, model=FALSE, x=TRUE) > printf("-- test basic use of DF\n") -- test basic use of DF > rv <- plotmo(lm.form.df.model.false.x.true, trace=100) plotmo trace 100: plotmo(object=lm.form.df.model.false.x.true, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~., data=DF, model=FALSE, x=TRUE) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.model.false.x.true' > stopifnot1(rv, X) rv == X passed > > printf("-- test DF not available (shouldn't matter)\n") -- test DF not available (shouldn't matter) > DF <- "rubbish" > rv <- plotmo(lm.form.df.model.false.x.true, trace=100) plotmo trace 100: plotmo(object=lm.form.df.model.false.x.true, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~., data=DF, model=FALSE, x=TRUE) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.model.false.x.true' > stopifnot1(rv, X) rv == X passed > > printf("-- test $x trashed causes failure\n") -- test $x trashed causes failure > get.data() > lm.form.df.model.false.x.true <- lm(Y~., data=DF, model=FALSE, x=TRUE) > DF <- "rubbish" > X2 <- "rubbish1" > lm.form.df.model.false.x.true[["x"]] <- "nonesuch" > expect.err(try(plotmo(lm.form.df.model.false.x.true, trace=100)), "cannot get the original model predictors") plotmo trace 100: plotmo(object=lm.form.df.model.false.x.true, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~., data=DF, model=FALSE, x=TRUE) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.model.false.x.true' Warning: object$x may be corrupt Looked unsuccessfully for the original predictors in the following places: (1) object$x: nonesuch (2) model.frame: variable lengths differ (found for 'X2') (3) getCall(object)$x: less than three rows Error : cannot get the original model predictors Got expected error from try(plotmo(lm.form.df.model.false.x.true, trace = 100)) > > printf("-- test ok with $x trashed but DF ok\n") # although with trace!=100 will get downstream failures in predict.lm, that's ok -- test ok with $x trashed but DF ok > get.data() > lm.form.df.model.false.x.true[["x"]] <- "nonesuch" > # Warning: object$x may be corrupt > rv <- plotmo(lm.form.df.model.false.x.true, trace=100) plotmo trace 100: plotmo(object=lm.form.df.model.false.x.true, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~., data=DF, model=FALSE, x=TRUE) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.model.false.x.true' Warning: object$x may be corrupt > stopifnot1(rv, X) rv == X passed > > printf("-- test \"warning: object$x may be corrupt\", same as above but set options(warn=2)\n") -- test "warning: object$x may be corrupt", same as above but set options(warn=2) > options(warn=2) > get.data() > lm.form.df.model.false.x.true[["x"]] <- "nonesuch" > # Warning: object$x may be corrupt > expect.err(try(plotmo(lm.form.df.model.false.x.true, trace=100)), "x may be corrupt") plotmo trace 100: plotmo(object=lm.form.df.model.false.x.true, trace=100) --get.model.env for object with class lm object call is lm(formula=Y~., data=DF, model=FALSE, x=TRUE) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'lm.form.df.model.false.x.true' Error : (converted from warning) object$x may be corrupt Got expected error from try(plotmo(lm.form.df.model.false.x.true, trace = 100)) > options(warn=1) > stopifnot1(rv, X) rv == X passed > > printf("====== strings in the data.frame\n") ====== strings in the data.frame > > tit1 <- get.tit() > > tit1$char.pclass <- as.character(tit1$pclass) > > earth.survived.vs.pclass <- earth(survived~pclass, data=tit1, linpreds=TRUE) > x.earth.survived.vs.pclass <- plotmo(earth.survived.vs.pclass, trace=100, linpreds=TRUE) plotmo trace 100: plotmo(object=earth.survived.vs.pclass, trace=100, linpreds=TRUE) --get.model.env for object with class earth object call is earth(formula=survived~pclass, data=tit1, linpreds=TRUE) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.survived.vs.pclass' > stopifnot(is.factor(x.earth.survived.vs.pclass[[1]])) > > earth.survived.vs.char.pclass <- earth(survived~char.pclass, data=tit1) > x.earth.survived.vs.char.pclass <- plotmo(earth.survived.vs.char.pclass, trace=100) plotmo trace 100: plotmo(object=earth.survived.vs.char.pclass, trace=100) --get.model.env for object with class earth object call is earth(formula=survived~char.pclass, data=tit1) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'earth.survived.vs.char.pclass' > stopifnot(is.factor(x.earth.survived.vs.char.pclass[[1]])) > > stopifnot(x.earth.survived.vs.pclass == x.earth.survived.vs.char.pclass) > > lm.survived.vs.pclass <- earth(survived~pclass, data=tit1, linpreds=TRUE) > x.lm.survived.vs.pclass <- plotmo(lm.survived.vs.pclass, trace=100, linpreds=TRUE) plotmo trace 100: plotmo(object=lm.survived.vs.pclass, trace=100, linpreds=TRUE) --get.model.env for object with class earth object call is earth(formula=survived~pclass, data=tit1, linpreds=TRUE) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'lm.survived.vs.pclass' > stopifnot(is.factor(x.lm.survived.vs.pclass[[1]])) > > lm.survived.vs.char.pclass <- earth(survived~char.pclass, data=tit1) > x.lm.survived.vs.char.pclass <- plotmo(lm.survived.vs.char.pclass, trace=100) plotmo trace 100: plotmo(object=lm.survived.vs.char.pclass, trace=100) --get.model.env for object with class earth object call is earth(formula=survived~char.pclass, data=tit1) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'lm.survived.vs.char.pclass' > stopifnot(is.factor(x.lm.survived.vs.char.pclass[[1]])) > > stopifnot(x.lm.survived.vs.pclass == x.lm.survived.vs.char.pclass) > > stopifnot(x.lm.survived.vs.pclass == x.earth.survived.vs.pclass) > > printf("-- test.plotmo.x done\n") -- test.plotmo.x done > > source("test.epilog.R") plotmo/inst/slowtests/test.plotmo.args.R0000644000176200001440000001131513737415772020177 0ustar liggesusers# test.plotmo.args..R: test dot and other argument handling in plotmo source("test.prolog.R") library(earth) data(ozone1) options(warn=1) # print warnings as they occur options(warn=2) # treat warnings as errors lm.mod <- lm(O3~wind, data=ozone1) expect.err(try(plotmo(lm.mod, se=2, leve=.95)), "plotmo's 'se' argument is deprecated, please use 'level' instead") expect.err(try(plotmo(lm.mod, se=T)), "plotmo's 'se' argument is deprecated, please use 'level=.95' instead") expect.err(try(plotmo(lm.mod, se=.8)), "plotmo's 'se' argument is deprecated, please use 'level=.95' instead") expect.err(try(plotmo(lm.mod, level=2)), "level=2 is out of range, try level=.95") oz2 <- ozone1[1:40,] set.seed(2015) a <- earth(O3~temp+wind, dat=oz2, deg=2, nk=21, ncr=3, nfo=3, varmod.me="lm") expect.err(try(plotmo(a, lw=2, trace=1, thresh=.9, SHOWCALL=TRUE)), "predict.earth ignored argument 'lw'") options(warn=1) # test col.response and friends plotmo(a, col.response=2, pch.response=c(1, 2, 20), type2="co", SHOWCALL=TRUE) # pch.response tests back compat plotmo(a, pt.col=c(1,2,3), pt.pch=c(1, 2, 20), type2="im", SHOWCALL=TRUE) plotmo(a, pt.col=c(1,2,3), pt.pch=paste(1:nrow(oz2)), pt.cex=.8, type2="im", do.par=2, SHOWCALL=TRUE) plotmo(a, pt.col=c(1,2,3), pt.pch=paste(1:nrow(oz2)), pt.cex=.8, type2="co", degree1=0, do.par=F) par(org.par) plotmo(a, col=2, SHOWCALL=TRUE) # will cause red response points plotmo(a, pt.col=4, col=3, persp.col="pink", SHOWCALL=TRUE) # col now goes to lines # test cex and nrug and smooth plotmo(a, cex=.8, SHOWCALL=TRUE, nrug=-1, rug.col=2, rug.lwd=1, smooth.col=3, bty="n", col.lab="darkorange", xlab="an x label", cex.lab=1.2) # esoteric, but they work plotmo(a, SHOWCALL=TRUE, density.col=2, density.lty=2, smooth.col=3, smooth.f=.3, col="lightblue") plotmo(a, cex=1.2, SHOWCALL=TRUE, nrug="density") # test caption, grid, interval options plotmo(a, caption.col=3, caption.font=2, grid.col="pink", level=.8, SHOWCALL=TRUE) plotmo(a, caption.col=2, caption.font=2, caption.cex=.8, grid.col=TRUE, bty="n", level=.8, level.shade="lightblue", level.shade2="red", grid.lty=3, grid.lwd=4, grid.nx=NA, SHOWCALL=TRUE) # test overall plot args handled by par() and graphics args outside do.par par(mfrow=c(2,2), mar = c(3,3,3,1), mgp = c(1.5,.5,0), oma=c(0,0,4,0)) par(col.main="#456789") old.mar <- par("mar") old.mfcol <- par("mfcol") cat("before par: cex=", par("cex"), " col.main=", par("col.main"), " col.axis=", par("col.axis"), " mar=", par("mar"), " mfcol=", par("mfcol"), "\n", sep="") plotmo(a, mfcol=c(2,3), cex.main=1.4, oma=c(5,5,5,5), SHOWCALL=TRUE) plotmo(a, caption="no cex") plotmo(a, cex=1, caption="cex=1, plot should be identical to previous page") plotmo(a, cex=1.2, caption="cex=1.2") plotmo(a, do.par=FALSE, degree2=0, degree1=1, main="do.par=FALSE no cex", caption="a test graphics args with do.par=FALSE") plotmo(a, do.par=FALSE, degree2=0, degree1=1, cex=1, main="do.par=FALSE cex=1") plotmo(a, do.par=FALSE, degree2=0, degree1=1, cex=.8, main="do.par=FALSE cex=.8") plotmo(a, do.par=FALSE, degree2=0, degree1=1, cex=1.1, xlab="xlab", col.main=2, col.axis="blue", col.lab=3, font.lab=2, main="do.par=FALSE cex=1.1, col.main=2\ncol.axis=\"blue\", col.lab=3, font.lab=2") plotmo(a, do.par=FALSE, degree1=1, degree2=1, persp.ticktype="d", main="do.par=FALSE persp.ticktype=\"d\"") # all of these should have been restored cat("after par: cex=", par("cex"), " col.main=", par("col.main"), " col.axis=", par("col.axis"), " mar=", par("mar"), " mfcol=", par("mfcol"), "\n", sep="") stopifnot(par("col.main") == "#456789") stopifnot(par("mar") == old.mar) stopifnot(par("mfcol") == old.mfcol) par(col.main=1) # test aliasing of col with other args, and back compat of col.degree1 vs degree1.col data(etitanic) a20 <- earth(pclass ~ ., data=etitanic, degree=2) plotmo(a20, nresponse=1, col=2, col.degree1=3, persp.col="pink", SHOWCALL=1, degree1=1:2, degree2=1:2) plotmo(a20, nresponse=1, lty=2, persp.lty=1, SHOWCALL=1, degree1=1:2, degree2=1:2) # test "prednames." with a long predictor name data(trees) trees.with.long.predname <- trees trees.with.long.predname$a_quite_long_variable_name <- trees.with.long.predname$Girth trees.with.long.predname$Girth <- NULL mod <- earth(Volume~.,data=trees.with.long.predname) par(mfrow=c(3,2), mar = c(3,3,3,1), mgp = c(1.5,.5,0), oma=c(0,0,4,0)) plotmo(mod, do.par=FALSE) plotmo(mod, do.par=FALSE, prednames.abbreviate=FALSE) expect.err(try(plotmo(mod, do.par=FALSE, prednames.abbreviate=c(1,2))), "the prednames.abbreviate argument is not FALSE, TRUE, 0, or 1") plotmo(mod, do.par=FALSE, prednames.minlength=3) source("test.epilog.R") plotmo/inst/slowtests/test.non.earth.Rout.save0000644000176200001440000021223014663413004021273 0ustar liggesusers> # test.non.earth.R: test plotmo on non-earth models > # Stephen Milborrow, Basley KwaZulu-Natal Mar 2011 > > source("test.prolog.R") > library(plotmo) Loading required package: Formula Loading required package: plotrix > library(earth) > data(ozone1) > data(etitanic) > dopar <- function(nrows, ncols, caption = "") + { + cat(" ", caption, "\n") + par(mfrow=c(nrows, ncols)) + par(oma = c(0, 0, 3, 0)) + par(mar = c(3, 3, 1.7, 0.5)) + par(mgp = c(1.6, 0.6, 0)) + par(cex = 0.7) + } > caption <- "test lm(log(doy) ~ vh+wind+humidity+temp+log(ibh), data=ozone1)" > dopar(4,5,caption) test lm(log(doy) ~ vh+wind+humidity+temp+log(ibh), data=ozone1) > a <- lm(log(doy) ~ vh + wind + humidity + temp + log(ibh), data=ozone1) > set.seed(2020) > plotmo(a, do.par=FALSE, caption=caption, ylim=NA, col.response=3, pt.pch=20, smooth.col="indianred", + trace=2) plotmo trace 2: plotmo(object=a, smooth.col="indianred", do.par=FALSE, ylim=NA, caption=caption, trace=2, col.response=3, pt.pch=20) --get.model.env for object with class lm object call is lm(formula=log(doy)~vh+wind+humidity+temp+log(ibh), data=ozone1) using the environment saved in $terms of the lm model: R_GlobalEnv --plotmo_prolog for lm object 'a' --plotmo_x for lm object get.object.x: object$x is NULL (and it has no colnames) object call is lm(formula=log(doy)~vh+wind+humidity+temp+log(ibh), data=ozone1) get.x.from.model.frame: formula(object) is log(doy) ~ vh + wind + humidity + temp + log(ibh) naked formula is log(doy) ~ vh + wind + humidity + temp + ibh formula is valid, now looking for data for the model.frame object$model is usable and has column names log(doy) vh wind humidity temp log(ibh) object$model cannot be used because it has non-naked column names "log(doy)" "log(ibh)" object$data is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names O3 vh wind humidity temp ibh dpg ibt vis doy na.action(object) is "na.fail" stats::model.frame(log(doy) ~ vh + wind + humidity + tem..., data=call$data, na.action="na.fail") x=model.frame[,-1] is usable and has column names vh wind humidity temp ibh plotmo_x returned[330,5]: vh wind humidity temp ibh 1 5710 4 28 40 2693 2 5700 3 37 45 590 3 5760 3 51 54 1450 ... 5720 4 69 35 1568 330 5550 4 85 39 5000 ----Metadata: plotmo_predict with nresponse=NULL and newdata=NULL calling predict.lm with NULL newdata stats::predict(lm.object, NULL, type="response") predict returned[330,1] with no column names: 1 4.869230 2 4.711557 3 5.135810 ... 4.906652 330 5.044131 predict after processing with nresponse=NULL is [330,1] with no column names: 1 4.869230 2 4.711557 3 5.135810 ... 4.906652 330 5.044131 ----Metadata: plotmo_fitted with nresponse=NULL stats::fitted(object=lm.object) fitted(object) returned[330,1] with no column names: 1 4.869230 2 4.711557 3 5.135810 ... 4.906652 330 5.044131 fitted(object) after processing with nresponse=NULL is [330,1] with no column names: 1 4.869230 2 4.711557 3 5.135810 ... 4.906652 330 5.044131 ----Metadata: plotmo_y with nresponse=NULL --plotmo_y with nresponse=NULL for lm object get.object.y: object$y is NULL (and it has no colnames) object call is lm(formula=log(doy)~vh+wind+humidity+temp+log(ibh), data=ozone1) get.y.from.model.frame: formula(object) is log(doy) ~ vh + wind + humidity + temp + log(ibh) formula is valid, now looking for data for the model.frame object$model is usable and has column names log(doy) vh wind humidity temp log(ibh) object$model cannot be used because it has non-naked column names "log(doy)" "log(ibh)" object$data is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names O3 vh wind humidity temp ibh dpg ibt vis doy na.action(object) is "na.fail" stats::model.frame(log(doy) ~ vh + wind + humidity + tem..., data=call$data, na.action="na.fail") y=model.frame[,1] is usable and has column name log(doy) plotmo_y returned[330,1]: log(doy) 1 3.496508 2 3.526361 3 3.555348 ... 3.583519 330 5.966147 plotmo_y after processing with nresponse=NULL is [330,1]: log(doy) 1 3.496508 2 3.526361 3 3.555348 ... 3.583519 330 5.966147 converted nresponse=NA to nresponse=1 nresponse=1 (was NA) ncol(fitted) 1 ncol(predict) 1 ncol(y) 1 ----Metadata: plotmo_y with nresponse=1 --plotmo_y with nresponse=1 for lm object get.object.y: object$y is NULL (and it has no colnames) object call is lm(formula=log(doy)~vh+wind+humidity+temp+log(ibh), data=ozone1) get.y.from.model.frame: formula(object) is log(doy) ~ vh + wind + humidity + temp + log(ibh) formula is valid, now looking for data for the model.frame object$model is usable and has column names log(doy) vh wind humidity temp log(ibh) object$model cannot be used because it has non-naked column names "log(doy)" "log(ibh)" object$data is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names O3 vh wind humidity temp ibh dpg ibt vis doy na.action(object) is "na.fail" stats::model.frame(log(doy) ~ vh + wind + humidity + tem..., data=call$data, na.action="na.fail") y=model.frame[,1] is usable and has column name log(doy) got model response from model.frame(log(doy) ~ vh + wind + humidity + tem..., data=call$data, na.action="na.fail") plotmo_y returned[330,1]: log(doy) 1 3.496508 2 3.526361 3 3.555348 ... 3.583519 330 5.966147 plotmo_y after processing with nresponse=1 is [330,1]: log(doy) 1 3.496508 2 3.526361 3 3.555348 ... 3.583519 330 5.966147 got response name "log(doy)" from yfull resp.levs is NULL ----Metadata: done number of x values: vh 53 wind 11 humidity 65 temp 63 ibh 196 ----plotmo_singles for lm object singles: 1 vh, 2 wind, 3 humidity, 4 temp, 5 ibh ----plotmo_pairs for lm object formula(object) returned log(doy) ~ vh + wind + humidity + temp + log(ibh) formula.vars "vh" "wind" "humidity" "temp" "log(ibh)" term.labels "vh" "wind" "humidity" "temp" "log(ibh)" plotmo_pairs_from_term_labels term.labels: "vh" "wind" "humidity" "temp" "log(ibh)" "vh" "wind" "humidity" "temp" "log(ibh)" pred.names: "vh" "wind" "humidity" "temp" "ibh" considering vh considering wind considering humidity considering temp considering log(ibh) considering vh considering wind considering humidity considering temp considering log(ibh) no pairs ----Figuring out ylim ylim c(NA, NA) clip TRUE --plot.degree1(draw.plot=TRUE) plotmo grid: vh wind humidity temp ibh 5760 5 64 62 2112.5 degree1 plot1 (pmethod "plotmo") variable vh newdata[50,5]: vh wind humidity temp ibh 1 5320.000 5 64 62 2112.5 2 5332.857 5 64 62 2112.5 3 5345.714 5 64 62 2112.5 ... 5358.571 5 64 62 2112.5 50 5950.000 5 64 62 2112.5 stats::predict(lm.object, data.frame[50,5], type="response") predict returned[50,1] with no column names: 1 4.684507 2 4.700786 3 4.717064 ... 4.733343 50 5.482156 predict after processing with nresponse=1 is [50,1]: predict 1 4.684507 2 4.700786 3 4.717064 ... 4.733343 50 5.482156 graphics::plot.default(x=c(5320,5333,534...), y=c(4.685,4.701,4...), type="n", main="1 vh", xlab="", ylab="", xaxt="s", yaxt="s", xlim=c(5320,5951), ylim=NULL) Reducing trace level for subsequent degree1 plots degree1 plot2 (pmethod "plotmo") variable wind degree1 plot3 (pmethod "plotmo") variable humidity degree1 plot4 (pmethod "plotmo") variable temp degree1 plot5 (pmethod "plotmo") variable ibh > termplot(a) > par(org.par) > > caption <- "test lm(log(doy) ~ vh+wind+humidity+I(wind*humidity)+temp+log(ibh), data=ozone1)" > dopar(4,5,caption) test lm(log(doy) ~ vh+wind+humidity+I(wind*humidity)+temp+log(ibh), data=ozone1) > a <- lm(log(doy) ~ vh + wind + humidity + temp + log(ibh), data=ozone1) > set.seed(2020) > plotmo(a, do.par=FALSE, caption=caption, ylim=NA, col.resp=3, pt.pch=20, clip=FALSE, smooth.col="indianred") plotmo grid: vh wind humidity temp ibh 5760 5 64 62 2112.5 > termplot(a) > par(org.par) > > caption <- "test lm(doy ~ (vh+wind+humidity)^2, data=ozone1)" > dopar(4,3,caption) test lm(doy ~ (vh+wind+humidity)^2, data=ozone1) > a <- lm(doy ~ (vh+wind+humidity)^2, data=ozone1) > plotmo(a, do.par=FALSE, caption=caption, ylim=NULL) plotmo grid: vh wind humidity 5760 5 64 > # termplot(a) # termplot fails with Error in `[.data.frame`(mf, , i): undefined columns selected > par(org.par) > > caption <- "test lm(doy^2 ~ vh+wind+humidity+I(wind*humidity)+temp+log(ibh), data=ozone1)" > dopar(4,3,caption) test lm(doy^2 ~ vh+wind+humidity+I(wind*humidity)+temp+log(ibh), data=ozone1) > a <- lm(doy^2 ~ vh+wind+humidity+I(wind*humidity)+temp+log(ibh), data=ozone1) > plotmo(a, do.par=FALSE, caption=caption, ylim=NULL) plotmo grid: vh wind humidity temp ibh 5760 5 64 62 2112.5 > termplot(a) # termplot draws a funky second wind plot > par(org.par) > > caption <- "test lm with data=ozone versus attach(ozone)" > dopar(4,3,caption) test lm with data=ozone versus attach(ozone) > a <- lm(log(doy) ~ I(vh*wind) + wind + I(humidity*temp) + log(ibh), data=ozone1) > plotmo(a, do.par=FALSE, caption=caption, degree1=c(1,2,4,5)) plotmo grid: vh wind humidity temp ibh 5760 5 64 62 2112.5 > attach(ozone1) > a <- lm(log(doy) ~ I(vh*wind) + wind + I(humidity*temp) + log(ibh)) > plotmo(a, do.par=FALSE, degree1=c(1,2,4,5)) plotmo grid: vh wind humidity temp ibh 5760 5 64 62 2112.5 > detach(ozone1) > par(org.par) > > # commented out because "$" in names is not yet supported > # a <- lm(log(ozone1$doy) ~ I(ozone1$vh*ozone1$wind) + log(ozone1$ibh)) > # plotmo(a) > > set.seed(1) > caption <- "test lm and glm a900..a902: damage~temp family=binomial data=orings" > dopar(2,3,caption) test lm and glm a900..a902: damage~temp family=binomial data=orings > library(faraway) > data(orings) > a900 <- lm(I(damage/6) ~ temp, data=orings) > plotmo(a900, do.par=FALSE, caption=caption, col.response=2, nrug=-1, + main="lm(damage/6~temp)", smooth.col="indianred", trace=0) > response <- cbind(orings$damage, 6-orings$damage) > a901 <- glm(response ~ temp, family="binomial", data=orings) > set.seed(2020) > plotmo(a901, do.par=FALSE, col.response=2, nrug=-1, + main="glm(response~temp)", smooth.col="indianred", trace=2) plotmo trace 2: plotmo(object=a901, smooth.col="indianred", nrug=-1, do.par=FALSE, trace=2, col.response=2, main="glm(response~temp)") --get.model.env for object with class glm object call is glm(formula=response~temp, family="binomial", data=orings) using the environment saved in $terms of the glm model: R_GlobalEnv --plotmo_prolog for glm object 'a901' --plotmo_x for glm object get.object.x: object$x is NULL (and it has no colnames) object call is glm(formula=response~temp, family="binomial", data=orings) get.x.from.model.frame: formula(object) is response ~ temp naked formula is the same formula is valid, now looking for data for the model.frame object$model is usable and has column names response temp x=model.frame[,-1] is usable and has column name temp plotmo_x returned[23,1]: temp 1 53 2 57 3 58 ... 63 23 81 ----Metadata: plotmo_predict with nresponse=NULL and newdata=NULL plotmo_predict with NULL newdata (nrows=3), using plotmo_x to get the data --plotmo_x for glm object get.object.x: object$x is NULL (and it has no colnames) object call is glm(formula=response~temp, family="binomial", data=orings) get.x.from.model.frame: formula(object) is response ~ temp naked formula is the same formula is valid, now looking for data for the model.frame object$model is usable and has column names response temp x=model.frame[,-1] is usable and has column name temp plotmo_x returned[23,1]: temp 1 53 2 57 3 58 ... 63 23 81 will use the above data instead of newdata=NULL for predict.glm stats::predict(glm.object, data.frame[3,1], type="response") predict returned[3,1] with no column names: 1 0.5504788 2 0.3402166 3 0.2934757 predict after processing with nresponse=NULL is [3,1] with no column names: 1 0.5504788 2 0.3402166 3 0.2934757 ----Metadata: plotmo_fitted with nresponse=NULL stats::fitted(object=glm.object) fitted(object) returned[23,1] with no column names: 1 0.550478817 2 0.340216592 3 0.293475686 ... 0.123496147 23 0.002866088 fitted(object) after processing with nresponse=NULL is [23,1] with no column names: 1 0.550478817 2 0.340216592 3 0.293475686 ... 0.123496147 23 0.002866088 ----Metadata: plotmo_y with nresponse=NULL --plotmo_y with nresponse=NULL for glm object get.object.y: object$y is usable but without colnames so we will keep on searching object call is glm(formula=response~temp, family="binomial", data=orings) get.y.from.model.frame: formula(object) is response ~ temp formula is valid, now looking for data for the model.frame object$model is usable and has column names response temp y=model.frame[,1] is usable and has column name response the variable on the left side of the formula is a matrix or data.frame plotmo often cannot process such variables the number of dimensions of each variable in y is 2 and y is [23,1] with colname response, and values c(5, 1, 1, 1, 0, 0, 0, 0, 0, ... replacing y with y[[1]] y colnames were "response" and now "response[,1]" "response[,2]" plotmo_y returned[23,2]: response[,1] response[,2] 1 5 1 2 1 5 3 1 5 ... 1 5 23 0 6 plotmo_y after processing with nresponse=NULL is [23,2]: response[,1] response[,2] 1 5 1 2 1 5 3 1 5 ... 1 5 23 0 6 converted nresponse=NA to nresponse=1 nresponse=1 (was NA) ncol(fitted) 1 ncol(predict) 1 ncol(y) 2 ----Metadata: plotmo_y with nresponse=1 --plotmo_y with nresponse=1 for glm object get.object.y: object$y is usable but without colnames so we will keep on searching object call is glm(formula=response~temp, family="binomial", data=orings) get.y.from.model.frame: formula(object) is response ~ temp formula is valid, now looking for data for the model.frame object$model is usable and has column names response temp y=model.frame[,1] is usable and has column name response the variable on the left side of the formula is a matrix or data.frame plotmo often cannot process such variables the number of dimensions of each variable in y is 2 and y is [23,1] with colname response, and values c(5, 1, 1, 1, 0, 0, 0, 0, 0, ... replacing y with y[[1]] y colnames were "response" and now "response[,1]" "response[,2]" got model response from object$model yfrac[23,1] with colname response[,1], and values 0.8333, 0.1667, 0.1667, 0.166... created column "response.yfrac" from two column binomial response plotmo_y returned[23,1]: response.yfrac 1 0.8333333 2 0.1666667 3 0.1666667 ... 0.1666667 23 0.0000000 plotmo_y after processing with nresponse=1 is [23,1]: response.yfrac 1 0.8333333 2 0.1666667 3 0.1666667 ... 0.1666667 23 0.0000000 got response name "response[,1]" from yfull resp.levs is NULL ----Metadata: done number of x values: temp 16 ----plotmo_singles for glm object singles: 1 temp ----plotmo_pairs for glm object formula(object) returned response ~ temp formula.vars "temp" term.labels "temp" plotmo_pairs_from_term_labels term.labels: "temp" "temp" pred.names: "temp" considering temp considering temp no pairs ----Figuring out ylim ylim c(-0.1, 1.1) clip TRUE --plot.degree1(draw.plot=TRUE) degree1 plot1 (pmethod "plotmo") variable temp newdata[50,1]: temp 1 53.00000 2 53.57143 3 54.14286 ... 54.71429 50 81.00000 stats::predict(glm.object, data.frame[50,1], type="response") predict returned[50,1] with no column names: 1 0.550478817 2 0.519750569 3 0.488872165 ... 0.458078452 50 0.002866088 predict after processing with nresponse=1 is [50,1]: predict 1 0.550478817 2 0.519750569 3 0.488872165 ... 0.458078452 50 0.002866088 graphics::plot.default(x=c(53,53.57,54.1...), y=c(0.5505,0.5198...), type="n", main="glm(response~temp)", xlab="", ylab="", xaxt="s", yaxt="s", xlim=c(53,81.01), ylim=c(-0.1,1.1)) > a902 <- glm(cbind(damage, 6-damage)~temp, family="binomial", data=orings) > set.seed(2020) > plotmo(a902, do.par=FALSE, col.response=2, nrug=TRUE, + main="glm(cbind(damage,6-damage)~temp)", trace=0) > termplot(a902, main="termplot") > plotmo(a902, type="link", main="type=\"link\"", do.par=F) > set.seed(2020) > plotmo(a902, type="response", main="type=\"response\"", col.response=2, do.par=F) > par(org.par) > > set.seed(1) > caption <- "test glm(lot2~log(u),data=clotting,family=Gamma)" > dopar(2,2,caption) test glm(lot2~log(u),data=clotting,family=Gamma) > u = c(5,10,15,20,30,40,60,80,100) > lota = c(118,58,42,35,27,25,21,19,18) > clotting <- data.frame(u = u, lota = lota) > a <- glm(lota ~ log(u), data=clotting, family=Gamma) > set.seed(2020) > plotmo(a, do.par=FALSE, caption=caption, col.response=3, clip=FALSE, nrug=-1) > termplot(a) > plotmo(a, type="link", caption=paste("type=\"link\"", caption)) > par(org.par) > > if(length(grep("package:gam", search()))) + detach("package:gam") > library(mgcv) Loading required package: nlme This is mgcv 1.9-1. For overview type 'help("mgcv-package")'. > set.seed(1) > caption <- "test plot.gam, with mgcv::gam(y ~ s(x) + s(x,z)) with response and func (and extra image plot)" > dopar(3,2,caption) test plot.gam, with mgcv::gam(y ~ s(x) + s(x,z)) with response and func (and extra image plot) > par(mar = c(3, 5, 1.7, 0.5)) # more space for left and bottom axis > test1 <- function(x,sx=0.3,sz=0.4) + (pi**sx*sz)*(1.2*exp(-(x[,1]-0.2)^2/sx^2-(x[,2]-0.3)^2/sz^2)+ + 0.8*exp(-(x[,1]-0.7)^2/sx^2-(x[,2]-0.8)^2/sz^2)) > n <- 100 > set.seed(1) > x <- runif(n); > z1 <- runif(n); > y <- test1(cbind(x,z1)) + rnorm(n) * 0.1 > a <- gam(y ~ s(x) + s(x,z1)) > set.seed(2020) > plotmo(a, do.par=FALSE, type2="contour", caption=caption, + col.response=3, smooth.col="indianred", + func=test1, func.col="indianred", func.lwd=5, func.lty=2, smooth.lwd=3) plotmo grid: x z1 0.4878107 0.5185988 > > plotmo(a, do.par=FALSE, degree1=F, degree2=1, type2="image", ylim=NA) > plot(a, select=1) > plot(a, select=2) > plot(a, select=3) > n<-400 > sig<-2 > set.seed(1) > x0 <- runif(n, 0, 1) > x1 <- runif(n, 0, 1) > x2 <- runif(n, 0, 1) > x3 <- runif(n, 0, 1) > f0 <- function(x) 2 * sin(pi * x) > f1 <- function(x) exp(2 * x) > f2 <- function(x) 0.2*x^11*(10*(1-x))^6+10*(10*x)^3*(1-x)^10 > f <- f0(x0) + f1(x1) + f2(x2) > e <- rnorm(n, 0, sig) > y <- f + e > test.func <- function(x) f0(x[,1]) + f1(x[,2]) + f2(x[,3]) > library(mgcv) > caption <- "test mgcv::gam(y~s(x0,x1,k=12)+s(x2)+s(x3,k=20,fx=20)) (and extra persp plot)" > dopar(3,3,caption) test mgcv::gam(y~s(x0,x1,k=12)+s(x2)+s(x3,k=20,fx=20)) (and extra persp plot) > a <- gam(y~s(x0,x1,k=12)+s(x2)+s(x3,k=20,fx=20)) > plot(a, select=2) > plot(a, select=3) > plot(a, select=1) > plotmo(a, do.par=FALSE, type2="contour", caption=caption, xlab=NULL, main="", func=test.func, ngrid2=10, contour.drawlabels=FALSE) plotmo grid: x0 x1 x2 x3 0.474141 0.5151294 0.4460308 0.479208 > plotmo(a, do.par=FALSE, degree1=F, degree2=1, persp.the=-35) > par(org.par) > > set.seed(1) > caption <- "test plot.gam, with mgcv::gam(doy~s(wind)+s(humidity,wind)+s(vh)+temp,data=ozone1)" > dopar(3,3,caption) test plot.gam, with mgcv::gam(doy~s(wind)+s(humidity,wind)+s(vh)+temp,data=ozone1) > a <- gam(doy ~ s(wind) + s(humidity,wind) + s(vh) + temp, data=ozone1) > plotmo(a, do.par=FALSE, caption=caption, type2="contour", degree1=c("wind","vh"), swapxy=T, xlab=NULL, main="", clip=FALSE) plotmo grid: temp wind humidity vh 62 5 64 5760 > plot(a, select=1) > plot(a, select=3) > plot(a, select=2) > plot(a, select=4) > par(org.par) > > detach("package:mgcv") > library(gam) Loading required package: splines Loading required package: foreach Loaded gam 1.22-4 > caption <- "test gam:gam(Ozone^(1/3)~lo(Solar.R)+lo(Wind, Temp),data=airquality)" > set.seed(1) > dopar(3,2,caption) test gam:gam(Ozone^(1/3)~lo(Solar.R)+lo(Wind, Temp),data=airquality) > data(airquality) > airquality <- na.omit(airquality) # plotmo doesn't know how to deal with NAs yet > a <- gam(Ozone^(1/3) ~ lo(Solar.R) + lo(Wind, Temp), data = airquality) > set.seed(2020) > plotmo(a, do.par=FALSE, caption=caption, ylim=NA, col.response=3) plotmo grid: Solar.R Wind Temp 207 9.7 79 > # termplot gives fishy looking wind plot, plotmo looks ok > # termplot(a) #TODO this fails with R2.5: dim(data) <- dim: attempt to set an attribute on NULL > detach("package:gam") > par(org.par) > > library(mda) Loading required package: class Loaded mda 0.5-4 > caption <- "test mars and earth (expect not a close match)" > dopar(6,3,caption) test mars and earth (expect not a close match) > a <- mars( ozone1[, -1], ozone1[,1], degree=2) > b <- earth(ozone1[, -1], ozone1[,1], degree=2) > # this also tests trace=2 on a non formula model > plotmo(a, do.par=FALSE, caption=caption, trace=2) plotmo trace 2: plotmo(object=a, do.par=FALSE, caption=caption, trace=2) --get.model.env for object with class mars object call is mars(x=ozone1[, -1], y=ozone1[, 1], degree=2) assuming the environment of the mars model is that of plotmo's caller: R_GlobalEnv --plotmo_prolog for mars object 'a' --plotmo_x for mars object get.object.x: ignoring object$x for this mars object object call is mars(x=ozone1[, -1], y=ozone1[, 1], degree=2) get.x.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$x, R_GlobalEnv) getCall(object)$x is usable and has column names vh wind humidity temp ibh dpg ibt vis doy plotmo_x returned[330,9]: vh wind humidity temp ibh dpg ibt vis doy 1 5710 4 28 40 2693 -25 87 250 33 2 5700 3 37 45 590 -24 128 100 34 3 5760 3 51 54 1450 25 139 60 35 ... 5720 4 69 35 1568 15 121 60 36 330 5550 4 85 39 5000 8 44 100 390 ----Metadata: plotmo_predict with nresponse=NULL and newdata=NULL plotmo_predict with NULL newdata (nrows=3), using plotmo_x to get the data --plotmo_x for mars object get.object.x: ignoring object$x for this mars object object call is mars(x=ozone1[, -1], y=ozone1[, 1], degree=2) get.x.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$x, R_GlobalEnv) getCall(object)$x is usable and has column names vh wind humidity temp ibh dpg ibt vis doy plotmo_x returned[330,9]: vh wind humidity temp ibh dpg ibt vis doy 1 5710 4 28 40 2693 -25 87 250 33 2 5700 3 37 45 590 -24 128 100 34 3 5760 3 51 54 1450 25 139 60 35 ... 5720 4 69 35 1568 15 121 60 36 330 5550 4 85 39 5000 8 44 100 390 will use the above data instead of newdata=NULL for predict.mars stats::predict(mars.object, data.frame[3,9], type="response") predict returned[3,1] with no column names: 1 3.333568 2 1.865073 3 7.044289 predict after processing with nresponse=NULL is [3,1] with no column names: 1 3.333568 2 1.865073 3 7.044289 ----Metadata: plotmo_fitted with nresponse=NULL stats::fitted(object=mars.object) fitted(object) returned[330,1] with no column names: 1 3.333568 2 1.865073 3 7.044289 ... 6.925382 330 1.885331 fitted(object) after processing with nresponse=NULL is [330,1] with no column names: 1 3.333568 2 1.865073 3 7.044289 ... 6.925382 330 1.885331 ----Metadata: plotmo_y with nresponse=NULL --plotmo_y with nresponse=NULL for mars object get.object.y: object$y is NULL (and it has no colnames) object call is mars(x=ozone1[, -1], y=ozone1[, 1], degree=2) get.y.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$y, R_GlobalEnv) getCall(object)$y is usable but without colnames so we will keep on searching names(call) is "" "x" "y" "degree" the name of argument 2 is "y" so we will not process it with argn object$y is NULL call$y is usable but without colnames but we will use it anyway plotmo_y returned[330,1] with no column names: 1 3 2 5 3 5 ... 6 330 1 plotmo_y after processing with nresponse=NULL is [330,1] with no column names: 1 3 2 5 3 5 ... 6 330 1 converted nresponse=NA to nresponse=1 nresponse=1 (was NA) ncol(fitted) 1 ncol(predict) 1 ncol(y) 1 ----Metadata: plotmo_y with nresponse=1 --plotmo_y with nresponse=1 for mars object get.object.y: object$y is NULL (and it has no colnames) object call is mars(x=ozone1[, -1], y=ozone1[, 1], degree=2) get.y.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$y, R_GlobalEnv) getCall(object)$y is usable but without colnames so we will keep on searching names(call) is "" "x" "y" "degree" the name of argument 2 is "y" so we will not process it with argn object$y is NULL call$y is usable but without colnames but we will use it anyway got model response from getCall(object)$y plotmo_y returned[330,1] with no column names: 1 3 2 5 3 5 ... 6 330 1 plotmo_y after processing with nresponse=1 is [330,1]: plotmo_y 1 3 2 5 3 5 ... 6 330 1 response name is NULL resp.levs is NULL ----Metadata: done number of x values: vh 53 wind 11 humidity 65 temp 63 ibh 196 dpg 128 ibt 193... ----plotmo_singles for mars object singles: 1 vh, 2 wind, 3 humidity, 4 temp, 5 ibh, 6 dpg, 7 ibt, 8 vis, 9 doy ----plotmo_pairs for mars object Error in attr(x, "formula") %||% { : invalid formula formula(object) failed for mars object in plotmo.pairs.default Error in x$terms %||% attr(x, "terms") %||% stop("no terms component nor attribute") : no terms component nor attribute terms(object) failed for mars object in plotmo.pairs.default no pairs ----Figuring out ylim --get.ylim.by.dummy.plots --plot.degree1(draw.plot=FALSE) degree1 plot1 (pmethod "plotmo") variable vh newdata[50,9]: vh wind humidity temp ibh dpg ibt vis doy 1 5320.000 5 64 62 2112.5 24 167.5 120 205.5 2 5332.857 5 64 62 2112.5 24 167.5 120 205.5 3 5345.714 5 64 62 2112.5 24 167.5 120 205.5 ... 5358.571 5 64 62 2112.5 24 167.5 120 205.5 50 5950.000 5 64 62 2112.5 24 167.5 120 205.5 stats::predict(mars.object, data.frame[50,9], type="response") predict returned[50,1] with no column names: 1 8.123619 2 8.303007 3 8.482395 ... 8.661783 50 16.216014 predict after processing with nresponse=1 is [50,1]: predict 1 8.123619 2 8.303007 3 8.482395 ... 8.661783 50 16.216014 Reducing trace level for subsequent degree1 plots degree1 plot2 (pmethod "plotmo") variable wind degree1 plot3 (pmethod "plotmo") variable humidity degree1 plot4 (pmethod "plotmo") variable temp degree1 plot5 (pmethod "plotmo") variable ibh degree1 plot6 (pmethod "plotmo") variable dpg degree1 plot7 (pmethod "plotmo") variable ibt degree1 plot8 (pmethod "plotmo") variable vis degree1 plot9 (pmethod "plotmo") variable doy --done get.ylim.by.dummy.plots ylim c(6.671, 20.41) clip TRUE --plot.degree1(draw.plot=TRUE) plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 graphics::plot.default(x=c(5320,5333,534...), y=c(8.124,8.303,8...), type="n", main="1 vh", xlab="", ylab="", xaxt="s", yaxt="s", xlim=c(5320,5950), ylim=c(6.671,20.42)) > plotmo(b, do.par=FALSE) plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > par(org.par) > > caption <- "test mars and mars.to.earth(mars) (expect no degree2 for mars)" > dopar(6,3,caption) test mars and mars.to.earth(mars) (expect no degree2 for mars) > a <- mars(ozone1[, -1], ozone1[,1], degree=2) > b <- mars.to.earth(a) Converted mars(x=ozone1[,-1], y=ozone1[,1], degree=2) to earth(x=ozone1[,-1], y=ozone1[,1], degree=2) > plotmo(a, do.par=FALSE, caption=caption, ylim=NA) plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > plotmo(b, do.par=FALSE, ylim=NA) plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > par(org.par) > > # check fix for bug reported by Martin Maechler: > # form <- Volume ~ .; a <- earth(form, data = trees); plotmo(a) fails > > dopar(4,4, "test f <- O3 ~ .; a <- earth(f, data=ozone1)") test f <- O3 ~ .; a <- earth(f, data=ozone1) > fa <- log(O3) ~ . > a <- earth(fa, data=ozone1, degree=2) > print(summary(a)) Call: earth(formula=fa, data=ozone1, degree=2) coefficients (Intercept) 2.79412331 h(47-humidity) -0.01328663 h(52-temp) -0.01753702 h(temp-52) 0.02311792 h(1105-ibh) -0.00030601 h(13-dpg) -0.00523433 h(dpg-13) -0.00788042 h(194-ibt) -0.00459263 h(200-vis) 0.00195292 h(96-doy) -0.01324138 h(doy-96) -0.00278616 h(wind-7) * h(200-vis) -0.00153720 h(43-humidity) * h(52-temp) 0.00187488 h(humidity-67) * h(ibh-1105) -0.00000914 Selected 14 of 21 terms, and 8 of 9 predictors Termination condition: Reached nk 21 Importance: temp, ibt, doy, humidity, ibh, dpg, vis, wind, vh-unused Number of terms at each degree of interaction: 1 10 3 GCV 0.1058972 RSS 28.2111 GRSq 0.8114829 RSq 0.8468883 > plot(a, do.par=FALSE) > set.seed(2020) > plotmo(a, do.par=FALSE, degree1=2:3, degree2=c(1,2), col.response = "pink", smooth.col="indianred") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > a <- lm(log(doy) ~ I(vh*wind) + I(humidity*temp) + log(ibh), data=ozone1) > plotmo(a, do.par=FALSE, degree1=1:2) plotmo grid: vh wind humidity temp ibh 5760 5 64 62 2112.5 > fa <- log(doy) ~ I(vh*wind) + I(humidity*temp) + log(ibh) > a <- lm(fa, data=ozone1) > plotmo(a, do.par=FALSE, degree1=1:2) plotmo grid: vh wind humidity temp ibh 5760 5 64 62 2112.5 > par(org.par) > > # test inverse.func and func > > caption <- "test inverse.func=exp" > a <- lm(log(Volume) ~ Girth + Height + I(Girth*Height), data=trees) > my.func <- function(x) -60 + 5 * x[,1] + x[,2] / 3 > set.seed(2020) > plotmo(a, caption=caption, inverse.func = exp, col.response = "pink", func=my.func, func.col="gray", ngrid1=1000, type2="p", smooth.col="indianred") plotmo grid: Girth Height 12.9 76 > par(org.par) > > # se testing > > caption = "level=.95, lm(doy~., data=ozone1) versus termplot" > dopar(6,3,caption) level=.95, lm(doy~., data=ozone1) versus termplot > a <- lm(doy~., data=ozone1) > plotmo(a, level=.95, do.par=FALSE, caption=caption) plotmo grid: O3 vh wind humidity temp ibh dpg ibt vis 10 5760 5 64 62 2112.5 24 167.5 120 > termplot(a, se=2) > par(org.par) > > caption <- "test different se options, level=.95, lm(log(doy)~vh+wind+log(humidity),data=ozone1)" > dopar(4,3,caption) test different se options, level=.95, lm(log(doy)~vh+wind+log(humidity),data=ozone1) > a <- lm(log(doy) ~ vh + wind + log(humidity), data=ozone1) > plotmo(a, do.par=FALSE, caption=caption, ylim=NA, level=.95) plotmo grid: vh wind humidity 5760 5 64 > plotmo(a, do.par=FALSE, caption=caption, ylim=NA, level=.95, level.shade="pink", level.shade2=3) plotmo grid: vh wind humidity 5760 5 64 > plotmo(a, do.par=FALSE, caption=caption, ylim=NA, level=.95, level.shade=3) plotmo grid: vh wind humidity 5760 5 64 > plotmo(a, do.par=FALSE, caption=caption, ylim=NULL, level=.95, level.shade=3) plotmo grid: vh wind humidity 5760 5 64 > par(org.par) > > caption <- "test level=.95, lm(log(doy)~vh+wind+log(humidity),data=ozone1)" > dopar(2,3,caption) test level=.95, lm(log(doy)~vh+wind+log(humidity),data=ozone1) > a <- lm(log(doy) ~ vh + wind + log(humidity), data=ozone1) > plotmo(a, do.par=FALSE, caption=caption, ylim=NA, level=.95) plotmo grid: vh wind humidity 5760 5 64 > termplot(a, se=2) > par(org.par) > > caption <- "test level=.95 and inverse.func, lm(log(doy)~vh+wind+log(humidity),data=ozone1)" > dopar(3,3,caption) test level=.95 and inverse.func, lm(log(doy)~vh+wind+log(humidity),data=ozone1) > a <- lm(log(doy) ~ vh + wind + log(humidity), data=ozone1) > plotmo(a, do.par=FALSE, caption=caption, ylim=NA, level=.95) plotmo grid: vh wind humidity 5760 5 64 > plotmo(a, do.par=FALSE, caption=caption, ylim=NULL, level=.95, inverse.func=exp) plotmo grid: vh wind humidity 5760 5 64 > termplot(a, se=2) > par(org.par) > > caption <- "test level=.95, glm(lot2~log(u),data=clotting,family=Gamma)" > set.seed(1) > dopar(2,2,caption) test level=.95, glm(lot2~log(u),data=clotting,family=Gamma) > u = c(5,10,15,20,30,40,60,80,100) > lota = c(118,58,42,35,27,25,21,19,18) > clotting <- data.frame(u = u, lota = lota) > a <- glm(lota ~ log(u), data=clotting, family=Gamma) > set.seed(2020) > plotmo(a, do.par=FALSE, caption=caption, col.response=4, pt.pch=7, clip=FALSE, nrug=-1, level=.95, smooth.col="indianred") Warning: the level argument may not work correctly on glm objects built with weights > termplot(a, se=2) > par(org.par) > > if(length(grep("package:gam", search()))) + detach("package:gam") > library(mgcv) This is mgcv 1.9-1. For overview type 'help("mgcv-package")'. > set.seed(1) > caption <- "test level=.95, plot.gam, with mgcv::gam(y ~ s(x) + s(x,z1)) with response and func (and extra image plot)" > dopar(3,2,caption) test level=.95, plot.gam, with mgcv::gam(y ~ s(x) + s(x,z1)) with response and func (and extra image plot) > par(mar = c(3, 5, 1.7, 0.5)) # more space for left and bottom axis > test1 <- function(x,sx=0.3,sz=0.4) + (pi**sx*sz)*(1.2*exp(-(x[,1]-0.2)^2/sx^2-(x[,2]-0.3)^2/sz^2)+ + 0.8*exp(-(x[,1]-0.7)^2/sx^2-(x[,2]-0.8)^2/sz^2)) > n <- 100 > set.seed(1) > x <- runif(n); > z1 <- runif(n); > y <- test1(cbind(x,z1)) + rnorm(n) * 0.1 > a <- gam(y ~ s(x) + s(x,z1)) > set.seed(2020) > plotmo(a, do.par=FALSE, type2="contour", caption=caption, col.response=3, func=test1, func.col="magenta", level=.95) plotmo grid: x z1 0.4878107 0.5185988 > plotmo(a, do.par=FALSE, degree1=F, degree2=1, type2="image", image.col=topo.colors(10), + ylim=NA, level=.95, main="topo.colors") > plot(a, select=1) > plot(a, select=2) > plot(a, select=3) > par(org.par) > > # TODO Following commented out because it causes: > # Error: gam objects in the "gam" package do not support confidence intervals on new data > # detach("package:mgcv") > # library(gam) > # set.seed(1) > # caption <- "test level=.95, gam:gam(Ozone^(1/3)~lo(Solar.R)+lo(Wind, Temp),data=airquality)" > # dopar(3,2,caption) > # data(airquality) > # airquality <- na.omit(airquality) # plotmo doesn't know how to deal with NAs yet > # a <- gam(Ozone^(1/3) ~ lo(Solar.R) + lo(Wind, Temp), data = airquality) > # set.seed(2020) > # plotmo(a, do.par=FALSE, caption=caption, ylim=NA, col.response=3, level=.95) > # # termplot(a) #TODO this fails with R2.5: dim(data) <- dim: attempt to set an attribute on NULL > # detach("package:gam") > # par(org.par) > > # test factors by changing wind to a factor > > ozone2 <- ozone1 > ozone2[,"wind"] <- factor(ozone2[,"wind"], labels=c( + "wind0", "wind2", "wind3", "wind4", "wind5", "wind6", + "wind7", "wind8", "wind9", "wind10", "wind11")) > > # commented out because factors are not yet supported by plotmo.earth > # caption <- "test wind=factor, earth(O3 ~ ., data=ozone2)" > # a <- earth(doy ~ ., data=ozone2) > # set.seed(1) > # dopar(4,3,caption) > # set.seed(2020) > # plotmo(a, col.response="gray", level=.95, nrug=-1, do.par=FALSE, caption=caption) > # termplot(a) > # par(org.par) > > caption <- "test wind=factor, lm(doy ~ vh + wind + I(humidity*temp) + log(ibh), data=ozone2)" > a <- lm(doy ~ vh + wind + I(humidity*temp) + log(ibh), data=ozone2) > set.seed(1) > dopar(4,3,caption) test wind=factor, lm(doy ~ vh + wind + I(humidity*temp) + log(ibh), data=ozone2) > plotmo(a, col.response="gray", level=.95, nrug=-1, do.par=FALSE, caption=caption, smooth.col="indianred") plotmo grid: vh wind humidity temp ibh 5760 wind5 64 62 2112.5 > termplot(a, se=2) > par(org.par) > > caption <- "test level options" > dopar(2,2,caption) test level options > plotmo(a, do.par=FALSE, degree1=2, degree2=FALSE, level=.95, level.shade=0, caption=caption) plotmo grid: vh wind humidity temp ibh 5760 wind5 64 62 2112.5 > plotmo(a, do.par=FALSE, degree1=2, degree2=FALSE, level=.95, level.shade="orange") plotmo grid: vh wind humidity temp ibh 5760 wind5 64 62 2112.5 > plotmo(a, do.par=FALSE, degree1=2, degree2=FALSE, level=.95, level.shade2=0) plotmo grid: vh wind humidity temp ibh 5760 wind5 64 62 2112.5 > par(org.par) > > caption <- "test wind=factor, glm(y ~ i + j, family=poisson())" > y <- c(18,17,15,20,10,20,25,13,12) > i <- gl(3,1,9) > j <- gl(3,3) > a <- glm(y ~ i + j, family=poisson()) > set.seed(1) > dopar(2,2,caption) test wind=factor, glm(y ~ i + j, family=poisson()) > plotmo(a, do.par=F, level=.95, nrug=1, caption=caption) Warning: the level argument may not work correctly on glm objects built with weights Warning: the level argument may not work correctly on glm objects built with weights plotmo grid: i j 1 1 > termplot(a, se=1, rug=T) > par(org.par) > > if(length(grep("package:gam", search()))) + detach("package:gam") > caption <- "test wind=factor, gam(doy ~ vh + wind + s(humidity) + s(vh) + temp, data=ozone2)" > library(mgcv) > a <- gam(doy ~ vh + wind + s(humidity) + s(vh) + temp, data=ozone2) > plotmo(a, level=.95, caption=caption) plotmo grid: vh wind temp humidity 5760 wind5 62 64 > caption <- "test wind=factor, clip=TRUE, gam(doy ~ vh + wind + s(humidity) + s(vh) + temp, data=ozone2)" > plotmo(a, level=.95, caption=caption, clip=FALSE) plotmo grid: vh wind temp humidity 5760 wind5 62 64 > # termplot doesn't work here so code commented out > # dopar(3,3,caption) > # plotmo(a, do.par=FALSE) > # termplot(a) > par(org.par) > > # test lda and qda, and also col.response, pt.pch, and jitter > library(MASS) > etitanic2 <- etitanic > etitanic2$pclass <- as.numeric(etitanic$pclass) > etitanic2$sex <- as.numeric(etitanic$sex) > etitanic2$sibsp <- NULL > etitanic2$parch <- NULL > lda.model <- lda(survived ~ ., data=etitanic2) > set.seed(7) > plotmo(lda.model, caption="lda", clip=F, + col.response=as.numeric(etitanic2$survived)+2, type="posterior", nresponse=1, smooth.col="indianred", + all2=TRUE, type2="image") plotmo grid: pclass sex age 2 2 28 > set.seed(8) > plotmo(lda.model, caption="lda with no jitter", clip=F, + col.response=as.numeric(etitanic2$survived)+2, type="posterior", nresponse=1, + all2=TRUE, type2="image", jitter=0) plotmo grid: pclass sex age 2 2 28 > qda.model <- qda(survived ~ ., data=etitanic2) > set.seed(9) > plotmo(qda.model, caption="qda", clip=F, + col.response=as.numeric(etitanic2$survived)+2, type="post", nresponse=2, smooth.col="indianred", + all2=TRUE, type2="image", jitter.resp=.6, pch.resp=20) plotmo grid: pclass sex age 2 2 28 > > # test plotmo.y from the 2nd argument of the model function (non-formula interface) > lcush <- data.frame(Type=as.numeric(Cushings$Type), log(Cushings[,1:2]))[1:21,] > a <- qda(lcush[,2:3], lcush[,1]) > set.seed(2020) > plotmo(a, type="class", all2=TRUE, + caption= "plotmo.y from 2nd argument of call (qda)", + type2="contour", ngrid2=100, contour.nlevels=2, contour.drawlabels=FALSE, + col.response=as.numeric(lcush$Type)+1, + pt.pch=as.character(lcush$Type)) plotmo grid: Tetrahydrocortisone Pregnanetriol 2.04122 0.1823216 > par(org.par) > > # # example from MASS (works, but removed because unnecessary test) > # predplot <- function(object, main="", len = 100, ...) > # { > # plot(Cushings[,1], Cushings[,2], log="xy", type="n", > # xlab = "Tetrahydrocortisone", ylab = "Pregnanetriol", main = main) > # for(il in 1:4) { > # set <- Cushings$Type==levels(Cushings$Type)[il] > # text(Cushings[set, 1], Cushings[set, 2], > # labels=as.character(Cushings$Type[set]), col = 2 + il) } > # xp <- seq(0.6, 4.0, length=len) > # yp <- seq(-3.25, 2.45, length=len) > # cushT <- expand.grid(Tetrahydrocortisone = xp, > # Pregnanetriol = yp) > # Z <- predict(object, cushT, ...); zp <- as.numeric(Z$class) > # zp <- Z$post[,3] - pmax(Z$post[,2], Z$post[,1]) > # contour(exp(xp), exp(yp), matrix(zp, len), > # add = TRUE, levels = 0, labex = 0) > # zp <- Z$post[,1] - pmax(Z$post[,2], Z$post[,3]) > # contour(exp(xp), exp(yp), matrix(zp, len), > # add = TRUE, levels = 0, labex = 0) > # invisible() > # } > # par(mfrow=c(2,2)) > # cush <- log(as.matrix(Cushings[, -3])) > # tp <- Cushings$Type[1:21, drop = TRUE] > # set.seed(203) > # cush.data <- data.frame(tp, cush[1:21,]) > # a <- qda(tp~., data=cush.data) > # predplot(a, "QDA example from MASS") > # set.seed(2020) > # plotmo(a, type="class", all2=TRUE, type2="contour", degree1=NA, do.par=FALSE, > # col.response=as.numeric(cush.data$tp)+1) > # set.seed(2020) > # plotmo(a, type="class", all2=TRUE, type2="contour", degree1=NA, do.par=FALSE, > # col.response=as.numeric(cush.data$tp)+1, drawlabels=F, nlevels=2) > # set.seed(2020) > # plotmo(a, type="class", all2=TRUE, type2="contour", degree1=NA, do.par=FALSE, > # col.response=as.numeric(cush.data$tp)+1, drawlabels=F, nlevels=2, ngrid2=100) > # par(org.par) > > library(rpart) Attaching package: 'rpart' The following object is masked from 'package:faraway': solder > data(kyphosis) > # kyphosis data, earth model > a <- earth(Kyphosis ~ ., data=kyphosis, degree=2, glm=list(family=binomial)) > cat("summary(a): (Kyphosis)\n") summary(a): (Kyphosis) > print(summary(a)) Call: earth(formula=Kyphosis~., data=kyphosis, glm=list(family=binomial), degree=2) GLM coefficients present (Intercept) 12.4739052 h(97-Age) -0.1563678 h(6-Number) -3.8334755 h(Start-6) -0.3798750 h(Age-42) * h(Number-3) -0.0197570 h(114-Age) * h(Start-6) 0.0089521 h(Number-3) * h(Start-6) -0.3545004 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 83.2345 80 36.4652 74 0.562 50.47 8 1 Earth selected 7 of 19 terms, and 3 of 3 predictors Termination condition: Reached nk 21 Importance: Start, Age, Number Number of terms at each degree of interaction: 1 3 3 Earth GCV 0.1359306 RSS 7.090206 GRSq 0.2004084 RSq 0.4721446 > par(mfrow=c(3, 3)) > par(mar=c(3, 3, 2, .5)) # small margins to pack figs in > set.seed(9) # for jitter > set.seed(2020) > plotmo(a, do.par=F, type2="image", + col.response=ifelse(kyphosis$Kyphosis=="present", "red", "lightblue"), + clip=F) plotmo grid: Age Number Start 87 4 13 > plotmo(a, do.par=F, clip=F, degree1=0) > par(org.par) > > # kyphosis data, rpart models (also test ngrid2) > fit1 <- rpart(Kyphosis ~ ., data=kyphosis) > plotres(fit1, SHOWCALL=TRUE) > par(mfrow=c(3, 3)) > par(mar=c(.5, 0.5, 2, .5), mgp = c(1.6, 0.6, 0)) # b l t r small margins to pack figs in > library(rpart.plot) > prp(fit1, main="rpart kyphosis\nno prior") > plotmo(fit1, degree1=NA, do.par=F, main="", persp.theta=220, nresponse=2) > par(mar=c(4, 4, 2, .5)) > set.seed(2020) > plotmo(fit1, nresp=2, degree1=FALSE, do.par=F, main="", type2="image", # test default type="prob" + col.response=ifelse(kyphosis$Kyphosis=="present", "red", "lightblue"), + pt.pch=ifelse(kyphosis$Kyphosis=="present", "p", "a"), + image.col=gray(10:4/10), ngrid2=30) > par(mar=c(.5, 0.5, 2, .5)) # b l t r small margins to pack figs in > plotmo(fit1, type="class", degree1=NA, do.par=F, main="type=\"class\"") > # with type="prob" and response has two columns, > # nresponse should automatically default to column 2 > plotmo(fit1, type="prob", degree1=0, do.par=F, main="type=\"prob\"", + clip=F, ngrid2=50, persp.border=NA, trace=1) stats::predict(rpart.object, data.frame[3,3], type="prob") stats::fitted(object=rpart.object) fitted() was unsuccessful, will use predict() instead set nresponse=2 nresponse=2 but for plotmo_y using nresponse=1 because ncol(y) == 1 got model response from model.frame(Kyphosis ~ Age + Number + Start, data=call$data, na.action="na.pass") > set.seed(2020) > plotmo(fit1, type="prob", nresp=2, degree1=NA, do.par=F, main="", type2="image", + col.response=ifelse(kyphosis$Kyphosis=="present", "red", "lightblue"), + pt.pch=20, image.col=gray(10:4/10), ngrid2=5) > # better rpart model with prior > fit2 <- rpart(Kyphosis ~ ., data=kyphosis, parms=list(prior=c(.65,.35))) > prp(fit2, main="rpart kyphosis\nwith prior, better model") > plotmo(fit2, type="v", degree1=NA, do.par=F, main="", persp.theta=220, ngrid2=10) > par(mar=c(4, 4, 2, .5)) > set.seed(2020) > plotmo(fit2, type="v", degree1=NA, do.par=F, main="", type2="image", + col.response=ifelse(kyphosis$Kyphosis=="present", "red", "lightblue"), + pt.pch=20, image.col=gray(10:4/10), ngrid2=100) > par(org.par) > > plotmo(fit1, type="prob", nresponse=1, persp.border=NA, persp.col="pink", all1=TRUE, all2=TRUE, + caption="plotmo rpart fit1, all1=TRUE, all2=TRUE") plotmo grid: Age Number Start 87 4 13 > expect.err(try(plotmo(fit1, type="none.such1"))) Error : predict.rpart does not support type="none.such1" Got expected error from try(plotmo(fit1, type = "none.such1")) > > # rpart model with ozone data > data(ozone1) > par(mfrow=c(4,4)) > par(mar=c(.5, 0.5, 2, .5), cex=.6, mgp = c(1.6, 0.6, 0)) # b l t r small margins to pack figs in > a1 <- rpart(O3~temp+humidity, data=ozone1) > prp(a1, main="rpart model with ozone data\n(temp and humidity only)\n") > plotmo(a1, do.par=F, degree1=0, main="rpart", persp.ticktype="detail", persp.nticks=2) > expect.err(try(plotmo(a1, type="class"))) Error : predict.rpart does not support type="class" (for "anova" rpart objects) Got expected error from try(plotmo(a1, type = "class")) > # compare to a linear and earth model > a3 <- lm(O3~temp+humidity, data=ozone1) > plotmo(a3, do.par=F, clip=F, main="lm", degree1=0, all2=TRUE, persp.ticktype="detail", persp.nticks=2) > expect.err(try(plotmo(a3, type="none.such2"))) stats::predict(lm.object, NULL, type="none.such2") Error in match.arg(type) : 'arg' should be one of "response", "terms" Got expected error from try(plotmo(a3, type = "none.such2")) > a <- earth(O3~temp+humidity, data=ozone1, degree=2) > plotmo(a, do.par=F, clip=F, main="earth", degree1=NA, persp.ticktype="detail", persp.nticks=2) > expect.err(try(plotmo(a, type="none.such3"))) stats::predict(earth.object, NULL, type="none.such3") Error : type="none.such3" is not allowed Choose one of: "link" "response" "earth" "class" "terms" Got expected error from try(plotmo(a, type = "none.such3")) > expect.err(try(plotmo(a, type=c("abc", "def")))) Error : 'type' has more than one element type = c("abc" "def") Got expected error from try(plotmo(a, type = c("abc", "def"))) > par(org.par) > > # detailed rpart model > par(mfrow=c(3,3)) > a1 <- rpart(O3~., data=ozone1) > prp(a1, cex=.9, main="rpart model with full ozone data") > plotmo(a1, type="vector", do.par=F, degree1=NA, persp.ticktype="detail", + persp.nticks=3, degree2=2:3) > par(org.par) > > plotmo(a1, persp.border=NA, all1=TRUE, all2=TRUE, + caption="plotmo rpart a1, all1=TRUE, all2=TRUE") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > > library(tree) > tree1 <- tree(O3~., data=ozone1) > plotmo(tree1) plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > plotres(tree1) > > # rpart data with NAs > > rpart.airquality <- rpart(Ozone~., data=airquality) # airquality has NAs in response and variables > plotmo <- plotmo(rpart.airquality, trace=0, SHOWCALL=TRUE) plotmo grid: Solar.R Wind Temp Month Day 207 9.7 79 7 16 > print(rpart.rules(rpart.airquality)) Ozone 12 when Temp < 83 & Wind >= 7.2 & Solar.R < 80 21 when Temp < 78 & Wind >= 7.2 & Solar.R >= 80 35 when Temp is 78 to 83 & Wind >= 7.2 & Solar.R >= 80 49 when Temp >= 83 & Wind >= 10.6 61 when Temp < 83 & Wind < 7.2 75 when Temp is 83 to 89 & Wind < 10.6 93 when Temp >= 89 & Wind < 10.6 > > airquality.nonaOzone <- subset(airquality, !is.na(Ozone)) # no NAs in response but NAs in variables > rpart.nonaOzone <- rpart(Ozone~., data=airquality.nonaOzone) > print(rpart.rules(rpart.nonaOzone)) Ozone 12 when Temp < 83 & Wind >= 7.2 & Solar.R < 80 21 when Temp < 78 & Wind >= 7.2 & Solar.R >= 80 35 when Temp is 78 to 83 & Wind >= 7.2 & Solar.R >= 80 49 when Temp >= 83 & Wind >= 10.6 61 when Temp < 83 & Wind < 7.2 75 when Temp is 83 to 89 & Wind < 10.6 93 when Temp >= 89 & Wind < 10.6 > plotmo.nonaOzone <- plotmo(rpart.nonaOzone, trace=0, SHOWCALL=TRUE) plotmo grid: Solar.R Wind Temp Month Day 207 9.7 79 7 16 > airquality.nonaOzone$Ozone <- NULL > stopifnot(identical(plotmo.nonaOzone, airquality.nonaOzone)) > > # test xflip and yflip > > par(mfrow=c(4, 4)) > par(mgp = c(1.6, 0.6, 0)) > par(mar=c(4, 4, 2, .5)) > > flip.test1 <- rpart(Kyphosis ~ ., data=kyphosis) > set.seed(2020) > plotmo(flip.test1, type="prob", nresp=2, degree1=NA, do.par=F, main="", type2="image", + col.response=ifelse(kyphosis$Kyphosis=="present", "red", "lightblue"), + pt.pch=20, image.col=gray(10:4/10)) > set.seed(2020) > plotmo(flip.test1, type="prob", nresp=2, degree1=NA, do.par=F, main="xflip", type2="image", + col.response=ifelse(kyphosis$Kyphosis=="present", "red", "lightblue"), + pt.pch=20, image.col=gray(10:4/10), + xflip=T) > set.seed(2020) > plotmo(flip.test1, type="prob", nresp=2, degree1=NA, do.par=F, main="yflip", type2="image", + col.response=ifelse(kyphosis$Kyphosis=="present", "red", "lightblue"), + pt.pch=20, image.col=gray(10:4/10), + yflip=T) > set.seed(2020) > plotmo(flip.test1, type="prob", nresp=2, degree1=NA, do.par=F, main="xflip and yflip", type2="image", + col.response=ifelse(kyphosis$Kyphosis=="present", "red", "lightblue"), + pt.pch=20, image.col=gray(10:4/10), + xflip=T, yflip=T) > > flip.test2 <- earth(O3~., data=ozone1, degree=2) > plotmo(flip.test2, degree1=NA, degree2=2, do.par=F, main="", type2="cont") > plotmo(flip.test2, degree1=NA, degree2=2, do.par=F, main="xflip", type2="cont", + xflip=T) > plotmo(flip.test2, degree1=NA, degree2=2, do.par=F, main="yflip", type2="cont", + yflip=T) > plotmo(flip.test2, degree1=NA, degree2=2, do.par=F, main="xflip and yflip", type2="cont", + xflip=T, yflip=T) > > cat("Expect warnings: ignoring xflip=TRUE for persp plot\n") Expect warnings: ignoring xflip=TRUE for persp plot > plotmo(flip.test2, degree1=NA, degree2=2, do.par=F, main="xflip and yflip", type2="persp", + xflip=T, yflip=T) Warning: ignoring xflip=TRUE for persp plot Warning: ignoring yflip=TRUE for persp plot > > library(randomForest) randomForest 4.7-1.1 Type rfNews() to see new features/changes/bug fixes. > data(etitanic) > etit <- etitanic[1:300,] > > cat("=== rf.regression ===\n") === rf.regression === > set.seed(2016) > # Expect Warning: The response has five or fewer unique values. Are you sure you want to do regression? > rf.regression <- randomForest(survived~., data=etit, ntree=100, importance = FALSE) Warning in randomForest.default(m, y, ...) : The response has five or fewer unique values. Are you sure you want to do regression? > plotmo(rf.regression, trace=1) stats::predict(randomForest.formula.object, data.frame[3,5], type="response") stats::fitted(object=randomForest.formula.object) fitted() was unsuccessful, will use predict() instead got model response from model.frame(survived ~ pclass + sex + age + sibsp..., data=call$data, na.action="na.fail") randomForest built with importance=FALSE, ranking variables on IncNodePurity plotmo grid: pclass sex age sibsp parch 1st male 38 0 0 > > cat("=== rf.regression.importance ===\n") === rf.regression.importance === > set.seed(2016) > # Expect Warning: The response has five or fewer unique values. Are you sure you want to do regression? > rf.regression.importance <- randomForest(survived~., data=etit, ntree=100, importance = TRUE) Warning in randomForest.default(m, y, ...) : The response has five or fewer unique values. Are you sure you want to do regression? > plotmo(rf.regression.importance, trace=1) stats::predict(randomForest.formula.object, data.frame[3,5], type="response") stats::fitted(object=randomForest.formula.object) fitted() was unsuccessful, will use predict() instead got model response from model.frame(survived ~ pclass + sex + age + sibsp..., data=call$data, na.action="na.fail") randomForest built with importance=TRUE, ranking variables on %IncMSE plotmo grid: pclass sex age sibsp parch 1st male 38 0 0 > > etit <- etitanic[1:300,] > etit$survived <- factor(ifelse(etit$survived == 1, "survived", "died"), + levels = c("survived", "died")) > cat("=== rf.classification ===\n") === rf.classification === > set.seed(2016) > rf.classification <- randomForest(survived~., data=etit, ntree=100, importance = FALSE) > plotmo(rf.classification, trace=1, type="prob", nresponse="surv", SHOWCALL=TRUE) stats::predict(randomForest.formula.object, data.frame[3,5], type="prob") stats::fitted(object=randomForest.formula.object) fitted() was unsuccessful, will use predict() instead got model response from model.frame(survived ~ pclass + sex + age + sibsp..., data=call$data, na.action="na.fail") randomForest built with importance=FALSE, ranking variables on MeanDecreaseGini plotmo grid: pclass sex age sibsp parch 1st male 38 0 0 > plotmo(rf.classification, trace=1, type="prob", nresponse="died", degree2=0, SHOWCALL=TRUE) stats::predict(randomForest.formula.object, data.frame[3,5], type="prob") stats::fitted(object=randomForest.formula.object) fitted() was unsuccessful, will use predict() instead nresponse=2 but for plotmo_y using nresponse=1 because ncol(y) == 1 got model response from model.frame(survived ~ pclass + sex + age + sibsp..., data=call$data, na.action="na.fail") randomForest built with importance=FALSE, ranking variables on MeanDecreaseGini plotmo grid: pclass sex age sibsp parch 1st male 38 0 0 > > cat("=== rf.classification.importance ===\n") === rf.classification.importance === > set.seed(2016) > rf.classification.importance <- randomForest(survived~., data=etit, ntree=100, importance = TRUE) > plotmo(rf.classification.importance, trace=1, type="prob", nresponse="surv", SHOWCALL=TRUE) stats::predict(randomForest.formula.object, data.frame[3,5], type="prob") stats::fitted(object=randomForest.formula.object) fitted() was unsuccessful, will use predict() instead got model response from model.frame(survived ~ pclass + sex + age + sibsp..., data=call$data, na.action="na.fail") randomForest built with importance=TRUE, ranking variables on MeanDecreaseAccuracy plotmo grid: pclass sex age sibsp parch 1st male 38 0 0 > > cat("=== plotres randomForest ===\n") === plotres randomForest === > plotres(rf.regression) > plotres(rf.regression.importance) > # TODO residuals are in range 0 to 1 > plotres(rf.classification, type="prob", nresponse="surv") > plotres(rf.classification.importance, type="prob", nresponse="surv") > > #--- fda ------------------------------------------------------------------------------ > > par(org.par) > par(mfrow=c(4,5)) > par(mar = c(3, 2, 3, .1)) # b, l, t, r > par(mgp = c(1.5, .5, 0)) > fda.earth <- fda(Species~., data=iris, keep.fitted=TRUE, method=earth, keepxy=TRUE) > fda.polyreg <- fda(Species~., data=iris, keep.fitted=TRUE, keepxy=TRUE) > fda.bruto <- fda(Species~., data=iris, keep.fitted=TRUE, method=bruto) > > # 'fda.polyreg$fit' does not have a 'call' field or 'x' and 'y' fields > expect.err(try(plotmo(fda.polyreg$fit, type="variates", nresponse=1, clip=F, do.par=F))) Error : 'fda.polyreg$fit' does not have a 'call' field or 'x' and 'y' fields Got expected error from try(plotmo(fda.polyreg$fit, type = "variates", nresponse = 1, clip = F, do.par = F)) > > plot(1, main="plotmo with fda", xaxt="n", yaxt="n", xlab="", ylab="", + type="n", bty="n", cex.main=1.2, xpd=NA) > > plotmo(fda.earth, type="variates", nresponse=1, clip=F, do.par=F) plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 5.8 3 4.35 1.3 > > plot(1, main="plotmo with fda.earth$fit", xaxt="n", yaxt="n", xlab="", ylab="", + type="n", bty="n", cex.main=1.2, xpd=NA) > > plotmo(fda.earth$fit, nresponse=1, clip=F, do.par=F) plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 5.8 3 4.35 1.3 > > plot(1, main="", xaxt="n", yaxt="n", xlab="", ylab="", + type="n", bty="n", cex.main=1.5, xpd=NA) > > plot(fda.earth) > plotmo(fda.earth, clip=F, do.par=F) # default type is class plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 5.8 3 4.35 1.3 > > plot(fda.polyreg) > plotmo(fda.polyreg, type="variates", nresponse=1, clip=F, do.par=F, degree1=c(1,3,4)) plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 5.8 3 4.35 1.3 > plot(1, main="", xaxt="n", yaxt="n", xlab="", ylab="", + type="n", bty="n", cex.main=1.5, xpd=NA) > > par(mfrow=c(3,3)) > par(mar = c(3, 2, 3, .1)) # b, l, t, r > par(mgp = c(1.5, .5, 0)) > plot(fda.bruto) > plotmo(fda.bruto, type="variates", nresponse=1, do.par=F) plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 5.8 3 4.35 1.3 > par(org.par) > > # neural net package > # for speed we use artificial data because neuralnet is very slow on say trees > library(neuralnet) > n <- 20 > set.seed(3) > x1 <- runif(n, min=-1, max=1) > x2 <- runif(n, min=-1, max=1) # x2 is noise > y <- x1^2 > data <- data.frame(y=y, x1=x1, x2=x2) > colnames(data) <- c("y","x1", "x2") > set.seed(3) > nn <- neuralnet(y~x1+x2, data=data, hidden=3, rep=3) > print(head(plotmo:::predict.nn(nn, rep="best", trace=TRUE))) predict.nn: rep = "best" is rep = 2 [,1] [1,] 0.46903930 [2,] 0.36653551 [3,] 0.02542870 [4,] 0.10970959 [5,] 0.06457524 [6,] 0.04182985 > set.seed(2020) > plotmo(nn, trace=1, col.response=2, all2=TRUE, SHOWCALL=TRUE) stats::predict(nn.object, data.frame[3,2], trace=TRUE) predict.nn: rep = "mean" will take the mean of 3 reps stats::fitted(object=nn.object) fitted() was unsuccessful, will use predict() instead assuming "y" in the model.frame is the response, because terms(object) did not return the terms assuming "y" in the model.frame is the response, because terms(object) did not return the terms got model response from model.frame(y ~ x1 + x2, data=object$data, na.action="na.fail") plotmo grid: x1 x2 0.09128479 -0.2904531 > # trace=0 below to test hushing of message "assuming "y" in the model.frame is the response, because object$terms is NULL" > set.seed(2020) > plotmo(nn, trace=0, col.response=2, predict.rep="best", SHOWCALL=TRUE) plotmo grid: x1 x2 0.09128479 -0.2904531 > plotres(nn, trace=0, info=TRUE, SHOWCALL=TRUE) > plotres(nn, trace=1, info=TRUE, predict.rep="best", SHOWCALL=TRUE) stats::residuals(object=nn.object, type="response") residuals() was unsuccessful, will use predict() instead stats::predict(nn.object, data.frame[3,2], trace=TRUE, rep="best") predict.nn: rep = "best" is rep = 2 stats::fitted(object=nn.object) fitted() was unsuccessful, will use predict() instead assuming "y" in the model.frame is the response, because terms(object) did not return the terms assuming "y" in the model.frame is the response, because terms(object) did not return the terms got model response from model.frame(y ~ x1 + x2, data=object$data, na.action="na.fail") assuming "y" in the model.frame is the response, because terms(object) did not return the terms training rsq 0.99 > > library(nnet) Attaching package: 'nnet' The following object is masked from 'package:mgcv': multinom > data(iris3) > set.seed(301) > samp <- c(sample(1:50,25), sample(51:100,25), sample(101:150,25)) > ird <- data.frame(rbind(iris3[,,1], iris3[,,2], iris3[,,3]), + species=factor(c(rep("seto",50), rep("vers", 50), rep("virg", 50)))) > ir.nn2 <- nnet(species ~ ., data = ird, subset = samp, size = 2, rang = 0.1, + decay = 5e-4, maxit = 20) # weights: 19 initial value 82.506969 iter 10 value 21.754594 iter 20 value 8.896424 final value 8.896424 stopped after 20 iterations > plotmo(ir.nn2, nresponse=1, type="class", all2=T, degree2=2:6) plotmo grid: Sepal.L. Sepal.W. Petal.L. Petal.W. 5.8 3 4.4 1.3 > plotmo(ir.nn2, nresponse=2, clip=F, all2=T, degree2=1:5) plotmo grid: Sepal.L. Sepal.W. Petal.L. Petal.W. 5.8 3 4.4 1.3 > plotres(ir.nn2, nresponse=2) > > library(biglm) Loading required package: DBI > data(trees) > ff <- log(Volume)~log(Girth)+log(Height) > chunk1 <- trees[1:20,] > chunk2 <- trees[20:31,] > biglm <- biglm(ff,chunk1) > biglm <- update(biglm, chunk2) > plotmo(biglm, pt.col=2, SHOWCALL=TRUE) plotmo grid: Girth Height 11.25 75 > plotres(biglm, SHOWCALL=TRUE) Warning: plotting 20 cases but the model was built with 32 cases > > library(adabag) Loading required package: caret Loading required package: ggplot2 Attaching package: 'ggplot2' The following object is masked from 'package:randomForest': margin Loading required package: lattice Attaching package: 'lattice' The following object is masked from 'package:faraway': melanoma Loading required package: doParallel Loading required package: iterators Loading required package: parallel > data(iris) > set.seed(2015) > # mfinal=3 for speed during testing > mod.boosting <- boosting(Species~., data=iris, mfinal=3) > mod.bagging <- bagging(Species~., data=iris, mfinal=3) > dopar(4, 4, caption="adabag package") adabag package > plotmo(mod.boosting, nresponse=1, ylim=c(0,1), do.par=FALSE) # default type="prob" plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 5.8 3 4.35 1.3 > plotmo(mod.boosting, type="class", do.par=FALSE) plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 5.8 3 4.35 1.3 > plotmo(mod.bagging, nresponse=1, ylim=c(0,1), do.par=FALSE) plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 5.8 3 4.35 1.3 > plotmo(mod.bagging, nresponse=1, type="votes", do.par=FALSE) plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 5.8 3 4.35 1.3 > par(org.par) > > library(e1071) > data(iris) > x.iris <- subset(iris, select=-Species) > y.iris <- iris$Species > set.seed(2016) > svm.xy <- svm(x.iris, y.iris, probability=FALSE) > par(mfrow = c(3, 3), mar = c(3, 3, 3, 1), mgp = c(1.5, 0.5, 0)) > expect.err(try(plotmo(svm.xy, prob=TRUE, nresponse="vers", do.par=TRUE, all2=TRUE))) # probability=FALSE in call to svm stats::predict(svm.object, data.frame[3,4], prob=TRUE) Error in predict.svm(structure(list(call = svm.default(x = x.iris, y = y.iris, : (converted from warning) SVM has not been trained using `probability = TRUE`, probabilities not available for predictions. Got expected error from try(plotmo(svm.xy, prob = TRUE, nresponse = "vers", do.par = TRUE, all2 = TRUE)) > plotmo(svm.xy, decision=TRUE, + nresponse="vers", do.par=FALSE, all2=TRUE, degree1=2:3, degree2=6) plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 5.8 3 4.35 1.3 > svm.xy <- svm(x.iris, y.iris, probability=TRUE) > plotmo(svm.xy, prob=TRUE, + nresponse="vers", do.par=FALSE, all2=TRUE, degree1=2:3, degree2=6) plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 5.8 3 4.35 1.3 > set.seed(2016) > svm.form <- svm(Species ~ ., data=iris, probability=T) > plotmo(svm.form, predict.p=TRUE, + nresponse="vers", do.par=FALSE, all2=TRUE, degree1=2:3, degree2=6) plotmo grid: Sepal.Length Sepal.Width Petal.Length Petal.Width 5.8 3 4.35 1.3 > expect.err(try(plotmo(svm.form, decision.values=TRUE, probab=TRUE))) # not both Error : predict.svm: specify either 'decision.values' or 'probability' (not both) Got expected error from try(plotmo(svm.form, decision.values = TRUE, probab = TRUE)) > plotres(svm.form, predict.prob=TRUE, nresponse="vers", info=TRUE) Cannot get training rsq (nresponse is 2 but the number of columns is only 1) > plotres(svm.form, jitter=5, info=TRUE) > par(org.par) > > source("test.epilog.R") plotmo/inst/slowtests/makeclean.bat0000755000176200001440000000075514273324334017237 0ustar liggesusers@rem makeclean.bat: clean up R package slowtests directory @rem make sure we are in the right directory @cd ..\..\.. @if %errorlevel% NEQ 0 goto err @cd plotmo\inst\slowtests @if %errorlevel% NEQ 0 goto err rm -rf Debug Release .vs rm -f ../../src/earth_res.rc ../Makedeps rm -f *.dll *.lib *.pdb *.map *.ilk rm -f *.ps *.pdf *.Rout *.exe *.out @goto done :err @echo ==== ERROR ==== @exit /B %errorlevel% :done @exit /B 0 plotmo/inst/slowtests/test.caret.Rout.save0000644000176200001440000003615214563614021020505 0ustar liggesusers> # test.caret.R: test plotmo on caret models > # > # TODO This is a minimal set of tests. > > source("test.prolog.R") > library(plotmo) Loading required package: Formula Loading required package: plotrix > library(earth) > library(caret) Loading required package: ggplot2 Loading required package: lattice > data(ozone1) > data(etitanic) > dopar <- function(nrows, ncols, caption = "") + { + cat(" ", caption, "\n") + par(mfrow=c(nrows, ncols)) + par(oma = c(0, 0, 3, 0)) + par(mar = c(3, 3, 1.7, 0.5)) + par(mgp = c(1.6, 0.6, 0)) + par(cex = 0.7) + } > set.seed(2010) > caret.earth.mod <- train(O3~., data=ozone1, method="earth", + tuneGrid=data.frame(degree=2, nprune=10)) > # SHOWCALL is just a testing thing, so we can see who created the plot on the plot itself > plotmo(caret.earth.mod, trace=1, SHOWCALL=TRUE) plotmo.prolog(object$finalModel) succeeded (caret model) stats::predict(train.object, data.frame[3,9], type="raw") stats::fitted(object=train.object) got model response from model.frame(O3 ~ vh + wind + humidity + temp + ib..., data=call$data, na.action="na.fail") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > plotmo(caret.earth.mod$finalModel, trace=1, SHOWCALL=TRUE) stats::predict(earth.object, NULL, type="response") stats::fitted(object=earth.object) got model response from object$y plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > plotres(caret.earth.mod, trace=1, SHOWCALL=TRUE) plotmo.prolog(object$finalModel) succeeded (caret model) residuals() was unsuccessful, will use predict() instead stats::predict(train.object, data.frame[3,9], type="raw") stats::fitted(object=train.object) got model response from model.frame(O3 ~ vh + wind + humidity + temp + ib..., data=call$data, na.action="na.fail") training rsq 0.81 > # plotres(caret.earth.mod$finalModel, trace=1, SHOWCALL=TRUE) > > set.seed(2015) > bag <- bagEarth(O3~., data=ozone1, degree=2, B=3) > print(bag$fit) $Resample1 Selected 13 of 19 terms, and 7 of 9 predictors Termination condition: Reached nk 21 Importance: temp, humidity, ibt, doy, vis, dpg, wind, vh-unused, ... Number of terms at each degree of interaction: 1 4 8 GCV 10.06481 RSS 2726.679 GRSq 0.8269797 RSq 0.8570949 $Resample2 Selected 15 of 21 terms, and 7 of 9 predictors Termination condition: Reached nk 21 Importance: temp, ibh, humidity, doy, vh, dpg, wind, ibt-unused, ... Number of terms at each degree of interaction: 1 6 8 GCV 14.07142 RSS 3685.688 GRSq 0.7976107 RSq 0.8383817 $Resample3 Selected 16 of 21 terms, and 8 of 9 predictors Termination condition: Reached nk 21 Importance: temp, ibt, humidity, doy, vis, dpg, vh, ibh, wind-unused Number of terms at each degree of interaction: 1 7 8 GCV 12.3789 RSS 3187.464 GRSq 0.8064265 RSq 0.8480394 > # pairs are plotted correctly (I think) > plotmo(bag, type="response", trace=1, SHOWCALL=TRUE) stats::predict(bagEarth.object, data.frame[3,9], type="response") stats::fitted(object=bagEarth.object) fitted() was unsuccessful, will use predict() instead assuming "O3" in the model.frame is the response, because terms(object) did not return the terms assuming "O3" in the model.frame is the response, because terms(object) did not return the terms got model response from model.frame(O3 ~ ., data=call$data, na.action="na.fail") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > plotres(bag, type="response", trace=1, SHOWCALL=TRUE) stats::residuals(object=bagEarth.object, type="response") residuals() was unsuccessful, will use predict() instead stats::predict(bagEarth.object, data.frame[3,9], type="response") stats::fitted(object=bagEarth.object) fitted() was unsuccessful, will use predict() instead assuming "O3" in the model.frame is the response, because terms(object) did not return the terms assuming "O3" in the model.frame is the response, because terms(object) did not return the terms got model response from model.frame(O3 ~ ., data=call$data, na.action="na.fail") assuming "O3" in the model.frame is the response, because terms(object) did not return the terms training rsq 0.83 > > set.seed(2015) > a.bag1 <- bagEarth(trees[,-3], trees[,3], degree=2, B = 3) > plotmo(a.bag1, trace=1, SHOWCALL=TRUE, all2=TRUE, caption="bagEarth, trees") stats::predict(bagEarth.object, data.frame[3,2], type="response") stats::fitted(object=bagEarth.object) fitted() was unsuccessful, will use predict() instead got model response from getCall(object)$y plotmo grid: Girth Height 12.9 76 > plotres(a.bag1, trace=1, SHOWCALL=TRUE) stats::residuals(object=bagEarth.object, type="response") residuals() was unsuccessful, will use predict() instead stats::predict(bagEarth.object, data.frame[3,2], type="response") stats::fitted(object=bagEarth.object) fitted() was unsuccessful, will use predict() instead got model response from getCall(object)$y training rsq 0.98 > > # trace=1 to display "Fixed rank deficient bx by removing 1 term" messages > set.seed(2015) > a.bag3 <- bagEarth(survived~., data=etitanic, degree=2, B=3, trace=1) x[1046,7] with colnames pclass1st pclass2nd pclass3rd sexmale age sibsp parch y[1046,1] with colname subY, and values 0, 0, 0, 0, 1, 1, 1, 0, 0, 0,... weights: no weights (because all weights equal) Forward pass term 1, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20 Reached nk 21 After forward pass GRSq 0.435 RSq 0.472 Prune backward penalty 3 nprune null: selected 10 of 15 terms, and 6 of 7 preds After pruning pass GRSq 0.444 RSq 0.468 x[1046,7] with colnames pclass1st pclass2nd pclass3rd sexmale age sibsp parch y[1046,1] with colname subY, and values 0, 0, 1, 1, 1, 0, 0, 0, 1, 1,... weights: no weights (because all weights equal) Forward pass term 1, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20 Reached nk 21 After forward pass GRSq 0.385 RSq 0.434 Prune backward penalty 3 nprune null: selected 12 of 18 terms, and 6 of 7 preds After pruning pass GRSq 0.402 RSq 0.433 x[1046,7] with colnames pclass1st pclass2nd pclass3rd sexmale age sibsp parch y[1046,1] with colname subY, and values 1, 1, 0, 1, 1, 1, 0, 1, 0, 0,... weights: no weights (because all weights equal) Forward pass term 1, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20 Reached nk 21 After forward pass GRSq 0.451 RSq 0.487 Prune backward penalty 3 nprune null: selected 13 of 15 terms, and 6 of 7 preds After pruning pass GRSq 0.456 RSq 0.487 > plotmo(a.bag3, clip=F, caption="bagEarth, etitanic", trace=1, SHOWCALL=TRUE) stats::predict(bagEarth.object, data.frame[3,7], type="response") stats::fitted(object=bagEarth.object) fitted() was unsuccessful, will use predict() instead assuming "survived" in the model.frame is the response, because terms(object) did not return the terms assuming "survived" in the model.frame is the response, because terms(object) did not return the terms got model response from model.frame(survived ~ ., data=call$data, na.action="na.fail") plotmo grid: pclass1st pclass2nd pclass3rd sexmale age sibsp parch 0 0 0 1 28 0 0 > plotres(a.bag3, clip=F, trace=1, SHOWCALL=TRUE) stats::residuals(object=bagEarth.object, type="response") residuals() was unsuccessful, will use predict() instead stats::predict(bagEarth.object, data.frame[3,7], type="response", clip=FALSE) stats::fitted(object=bagEarth.object) fitted() was unsuccessful, will use predict() instead assuming "survived" in the model.frame is the response, because terms(object) did not return the terms assuming "survived" in the model.frame is the response, because terms(object) did not return the terms got model response from model.frame(survived ~ ., data=call$data, na.action="na.fail") assuming "survived" in the model.frame is the response, because terms(object) did not return the terms training rsq 0.44 > > # following based on example by Max Kuhn on stackoverflow > etit <- etitanic > etit$survived <- factor(ifelse(etit$survived == 1, "yes", "no"), + levels = c("yes", "no")) > set.seed(2015) > caret.earth.mod2 <- train(survived ~ ., + data = etit, + method = "earth", + tuneGrid = data.frame(degree = 2, nprune = 9), + trControl = trainControl(method = "none", + classProbs = TRUE)) > # Following gives expected warning (because factors in caret-earth model) > # Warning: Cannot determine which variables to plot (use all1=TRUE?) > plotmo(caret.earth.mod2, trace=1, SHOWCALL=TRUE) plotmo.prolog(object$finalModel) succeeded (caret model) stats::predict(train.object, data.frame[3,5], type="raw") stats::fitted(object=train.object) got model response from model.frame(survived ~ pclass + sex + age + sibsp..., data=call$data, na.action="na.fail") Warning: Cannot determine which variables to plot (use all1=TRUE?) ncol(x) 5 < nrow(modvars) 6 colnames(x)=c(pclass,sex,age,sibsp,parch) rownames(modvars)=c(pclass2nd,pclass3rd,sexmale,age,sibsp,parch) plotmo grid: pclass sex age sibsp parch 3rd male 28 0 0 > # changed Sep 2020: following with all2=2 generates the same plot as above (because with warning, above defaults to all2=TRUE) > plotmo(caret.earth.mod2, trace=1, all2=TRUE, SHOWCALL=TRUE, caption="caret.earth.mod2: all2=2") plotmo.prolog(object$finalModel) succeeded (caret model) stats::predict(train.object, data.frame[3,5], type="raw") stats::fitted(object=train.object) got model response from model.frame(survived ~ pclass + sex + age + sibsp..., data=call$data, na.action="na.fail") Warning: Cannot determine which variables to plot (use all1=TRUE?) ncol(x) 5 < nrow(modvars) 6 colnames(x)=c(pclass,sex,age,sibsp,parch) rownames(modvars)=c(pclass2nd,pclass3rd,sexmale,age,sibsp,parch) plotmo grid: pclass sex age sibsp parch 3rd male 28 0 0 > plotres(caret.earth.mod2, trace=1, SHOWCALL=TRUE) plotmo.prolog(object$finalModel) succeeded (caret model) residuals() was unsuccessful, will use predict() instead stats::predict(train.object, data.frame[3,5], type="raw") stats::fitted(object=train.object) got model response from model.frame(survived ~ pclass + sex + age + sibsp..., data=call$data, na.action="na.fail") training rsq 0.21 > > # Sep 2020: test with a logical variable (check that get.earth.vars.for.plotmo strips "sexTRUE" to "sex") > # following should be exactly the same model as caret.earth.mod2 except for the variable naming for sex > etit.bool <- etitanic > etit.bool$survived <- factor(ifelse(etit.bool$survived == 1, "yes", "no"), + levels = c("yes", "no")) > etit.bool$sex <- etit.bool$sex == "male" # to bool > set.seed(2015) # same random seed as above (may not be necessary) > caret.earth.boolfac <- train(survived ~ ., + data = etit.bool, + method = "earth", + tuneGrid = data.frame(degree = 2, nprune = 9), + trControl = trainControl(method = "none", + classProbs = TRUE)) > print(summary(caret.earth.boolfac)) Call: earth(x=matrix[1046,6], y=factor.object, keepxy=TRUE, glm=list(family=function.object, maxit=100), degree=2, nprune=9) GLM coefficients no (Intercept) -2.9135260 pclass3rd 5.0300560 sexTRUE 3.1856245 h(age-32) 0.0375715 pclass2nd * sexTRUE 1.7680945 pclass3rd * sexTRUE -1.2226954 pclass3rd * h(4-sibsp) -0.6186527 sexTRUE * h(16-age) -0.2418140 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 1414.62 1045 892.794 1038 0.369 908.8 5 1 Earth selected 8 of 17 terms, and 5 of 6 predictors (nprune=9) Termination condition: Reached nk 21 Importance: sexTRUE, pclass3rd, pclass2nd, age, sibsp, parch-unused Number of terms at each degree of interaction: 1 3 4 Earth GCV 0.1404529 RSS 141.7629 GRSq 0.4197106 RSq 0.4389834 > > plotmo(caret.earth.boolfac, trace=0, SHOWCALL=TRUE) # Warning: Cannot determine which variables to plot (use all1=TRUE?) Warning: Cannot determine which variables to plot (use all1=TRUE?) ncol(x) 5 < nrow(modvars) 6 colnames(x)=c(pclass,sex,age,sibsp,parch) rownames(modvars)=c(pclass2nd,pclass3rd,sexTRUE,age,sibsp,parch) plotmo grid: pclass sex age sibsp parch 3rd TRUE 28 0 0 > # changed Sep 2020: following with all1=TRUE, all2=TRUE generates the same plot as above > plotmo(caret.earth.boolfac, trace=0, all1=TRUE, all2=TRUE, SHOWCALL=TRUE, caption="caret.earth.mod2: all1=T, all2=T") plotmo grid: pclass sex age sibsp parch 3rd TRUE 28 0 0 > > data(ozone1) > set.seed(2020) > a <- train(O3 ~ ., data = ozone1, method = "earth", + tuneGrid = data.frame(degree = 2, nprune = 14)) > plotmo(a, trace=1, SHOWCALL=TRUE) plotmo.prolog(object$finalModel) succeeded (caret model) stats::predict(train.object, data.frame[3,9], type="raw") stats::fitted(object=train.object) got model response from model.frame(O3 ~ vh + wind + humidity + temp + ib..., data=call$data, na.action="na.fail") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > plotres(a, trace=1, SHOWCALL=TRUE) plotmo.prolog(object$finalModel) succeeded (caret model) residuals() was unsuccessful, will use predict() instead stats::predict(train.object, data.frame[3,9], type="raw") stats::fitted(object=train.object) got model response from model.frame(O3 ~ vh + wind + humidity + temp + ib..., data=call$data, na.action="na.fail") training rsq 0.83 > > cat("=== method=\"svmRadial\" (S4 model wrapped in an S3 model) ===\n") === method="svmRadial" (S4 model wrapped in an S3 model) === > data(trees) > set.seed(2019) > library(kernlab) Attaching package: 'kernlab' The following object is masked from 'package:ggplot2': alpha > mod <- train(Girth~., data=trees, method="svmRadial", + trControl=trainControl(method="cv", number=2), + tuneLength=2, preProcess = c("center", "scale")) > plotres(mod, info=TRUE) > set.seed(2020) > plotmo(mod, pt.col=2, all2=TRUE, pmethod="partdep") calculating partdep for Height calculating partdep for Volume calculating partdep for Height:Volume 01234567890 > > source("test.epilog.R") plotmo/inst/slowtests/test.glmnetUtils.Rout.save0000644000176200001440000002615214563614021021715 0ustar liggesusers> # test.glmnet.R: glmnetUtils tests for plotmo and plotres > > source("test.prolog.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix > library(glmnetUtils) > data(ozone1) > data(etitanic) > get.tit <- function() # abbreviated titanic data + { + tit <- etitanic + pclass <- as.character(tit$pclass) + # change the order of the factors so not alphabetical + pclass[pclass == "1st"] <- "first" + pclass[pclass == "2nd"] <- "class2" + pclass[pclass == "3rd"] <- "classthird" + tit$pclass <- factor(pclass, levels=c("class2", "classthird", "first")) + # log age is so we have a continuous predictor even when model is age~. + set.seed(2015) + tit$logage <- log(tit$age) + rnorm(nrow(tit)) + tit$parch <- NULL + # by=12 gives us a small fast model with an additive and a interaction term + tit <- tit[seq(1, nrow(etitanic), by=12), ] + } > plotmores <- function(object, ..., trace=0, SHOWCALL=TRUE, title.extra="", ncol=2) { + old.par <- par(no.readonly=TRUE) + on.exit(par(old.par)) + par(mfrow=c(2,ncol)) + caption <- paste(deparse(substitute(object)), collapse=" ") + call <- match.call(expand.dots=TRUE) + call <- strip.space(paste(deparse(substitute(call)), collapse=" ")) + call <- gsub(",", ", ", call) + call <- paste(title.extra, call, sep="") + printf("%s\n", call) + # plotmo on glmnet mods is boring but we test it anyway + plotres(object, trace=trace, SHOWCALL=SHOWCALL, do.par=FALSE, which=c(1,3), ...) + title(paste("\n", call), outer=TRUE) + plotmo(object, trace=trace, SHOWCALL=SHOWCALL, do.par=FALSE, ...) + } > tit <- get.tit() > set.seed(2015) > xmat <- as.matrix(tit[,c(2,5,6)]) > agedata <- data.frame(tit[,4], xmat) > colnames(agedata) <- c("age", "survived", "sibsp", "logage") > set.seed(2015) > mod.glmnet.xmat <- glmnet(xmat, tit[,4]) # tit[,4] is age > plotres(mod.glmnet.xmat) > plotmo(mod.glmnet.xmat) plotmo grid: survived sibsp logage 0 0 3.06991 > plotmores(mod.glmnet.xmat, predict.s=2.5) plotmores(object=mod.glmnet.xmat, predict.s=2.5) plotmo grid: survived sibsp logage 0 0 3.06991 > > mod.glmnet.agedata <- glmnet(age~., data=agedata) > expect.err(try(plotres(mod.glmnet.agedata)), "for this plot, glmnet.formula must be called with use.model.frame=TRUE") Error : for this plot, glmnet.formula must be called with use.model.frame=TRUE Got expected error from try(plotres(mod.glmnet.agedata)) > mod.glmnet.agedata <- glmnet(age~., data=agedata, use.model.frame=TRUE) > plotmores(mod.glmnet.agedata, predict.s=2.5) plotmores(object=mod.glmnet.agedata, predict.s=2.5) plotmo grid: survived sibsp logage 0 0 3.06991 > > set.seed(2015) > mod.cv.glmnet.xmat <- cv.glmnet(xmat, tit[,4], nfolds=3) > > cat("==Test plotmo trace=1 and lambda.min\n") ==Test plotmo trace=1 and lambda.min > plotmores(mod.cv.glmnet.xmat, predict.s="lambda.min", trace=1, ncol=3) plotmores(object=mod.cv.glmnet.xmat, predict.s="lambda.min", trace=1, ncol=3) stats::residuals(object=cv.glmnet.object, type="response") residuals() was unsuccessful, will use predict() instead stats::predict(cv.glmnet.object, matrix[3,3], type="response", s="lambda.min") stats::fitted(object=cv.glmnet.object) fitted() was unsuccessful, will use predict() instead got model response from getCall(object)$y graphics::plot(cv.glmnet.object) training rsq 0.29 stats::predict(cv.glmnet.object, matrix[3,3], type="response", s="lambda.min") stats::fitted(object=cv.glmnet.object) fitted() was unsuccessful, will use predict() instead got model response from getCall(object)$y plotmo grid: survived sibsp logage 0 0 3.06991 > > set.seed(2015) > mod.cv.glmnet.agedata <- cv.glmnet(age~., data=agedata) > expect.err(try(plotres(mod.cv.glmnet.agedata)), "for this plot, cv.glmnet.formula must be called with use.model.frame=TRUE") Error : for this plot, cv.glmnet.formula must be called with use.model.frame=TRUE Got expected error from try(plotres(mod.cv.glmnet.agedata)) > set.seed(2015) > mod.cv.glmnet.agedata <- cv.glmnet(age~., data=agedata, use.model.frame=TRUE) > cat("==Test lambda.min\n") ==Test lambda.min > plotmores(mod.cv.glmnet.agedata, predict.s="lambda.min", trace=1, ncol=3) plotmores(object=mod.cv.glmnet.agedata, predict.s="lambda.min", trace=1, ncol=3) stats::residuals(object=cv.glmnet.formula.object, type="response") residuals() was unsuccessful, will use predict() instead stats::predict(cv.glmnet.formula.object, data.frame[3,3], type="response", s="lambda.min") stats::fitted(object=cv.glmnet.formula.object) fitted() was unsuccessful, will use predict() instead got model response from model.frame(age ~ survived + sibsp + logage, data=call$data, na.action="na.omit") graphics::plot(cv.glmnet.formula.object) training rsq 0.33 stats::predict(cv.glmnet.formula.object, data.frame[3,3], type="response", s="lambda.min") stats::fitted(object=cv.glmnet.formula.object) fitted() was unsuccessful, will use predict() instead got model response from model.frame(age ~ survived + sibsp + logage, data=call$data, na.action="na.omit") plotmo grid: survived sibsp logage 0 0 3.06991 > > printf("======== binomial model\n") ======== binomial model > > set.seed(2016) > n <- 50 > p <- 4 > xx <- matrix(rnorm(n*p), n, p) > colnames(xx) <- paste("x", 1:ncol(xx), sep="") > yy <- ifelse(xx[,1] + xx[,2] + rnorm(n) > .5, TRUE, FALSE) > print(cov(xx, yy)) [,1] x1 0.19664644 x2 0.19303946 x3 0.11937700 x4 0.03037754 > yy <- factor(yy) > dataxy <- data.frame(yy, xx) > binomial.mod <- glmnet(xx, yy, family="binomial") > plotmores(binomial.mod, ncol=3) plotmores(object=binomial.mod, ncol=3) plotmo grid: x1 x2 x3 x4 -0.2965405 -0.03311923 0.2416254 0.01017809 > binomial.mod.form <- glmnet(yy~., data=dataxy, family="binomial", use.model.frame=TRUE) > plotmores(binomial.mod.form, ncol=3) plotmores(object=binomial.mod.form, ncol=3) plotmo grid: x1 x2 x3 x4 -0.2965405 -0.03311923 0.2416254 0.01017809 > par(org.par) > > printf("======== glmnet family=\"mgaussian\"\n") ======== glmnet family="mgaussian" > set.seed(2015) > p <- 10 > n <- 30 > xx <- cbind((1:n)/n, matrix(rnorm(n*(p-1)),n,p-1)) > colnames(xx) <- paste0("x", 1:p) > # ymultresp <- cbind(rowSums(xx[,1:5]^3), rowSums(xx[,5:p]^3), 1:n) > set.seed(1) > ymultresp <- cbind(xx[,1]+.001*rnorm(n), rowSums(xx[,2:5]^3), rnorm(n)) > glmnet.mgaussian <- glmnet(xx, ymultresp, family="mgaussian") > plotres(glmnet.mgaussian, nresponse=1, SHOWCALL=TRUE, which=c(1:3), do.par=2, info=1) > # manually calculate the residuals > plot(x=predict(glmnet.mgaussian, newx=xx, s=0)[,1,1], + y=ymultresp[,1] - predict(glmnet.mgaussian, newx=xx, s=0)[,1,1], + pch=20, xlab="Fitted", ylab="Residuals", + main="Manually calculated residuals, nresponse=1, s=0") > abline(h=0, col="gray") > par(org.par) > > # # TODO is glmnet mgaussian supported with a formula interface? > # dataxy <- data.frame(ymultresp, xx) > # colnames(dataxy) <- c("y1", "y2", "y3", "x1", "x2", "x3", "x4", "x5", "x5", "x6", "x7", "x8", "x9", "x10") > # glmnet.mgaussian.form <- glmnet(xx, ymultresp, family="mgaussian") > # plotres(glmnet.mgaussian.form, nresponse=1, SHOWCALL=TRUE, which=c(1:3), do.par=2, info=1) > > par(mfrow=c(2,3), mar=c(3,3,3,.5), oma=c(0,0,3,0), mgp=c(1.5,0.4,0), tcl=-0.3) > > data(trees) > set.seed(2015) > # variable with a long name > x50 <- cbind(trees[,1:2], Girth12345678901234567890=rnorm(nrow(trees))) > mod.with.long.name <- glmnet(data.matrix(x50),data.matrix(trees$Volume)) > plotmores(mod.with.long.name, ncol=3) plotmores(object=mod.with.long.name, ncol=3) plotmo grid: Girth Height Girth12345678901234567890 12.9 76 0.004544606 > data.x50 <- data.frame(trees$Volume, x50) > colnames(data.x50) <- c("Volume", "Girth", "Height", "Girth12345678901234567890") > mod.with.long.name.form <- glmnet(Volume~., data=data.x50, use.model.frame=TRUE) > plotmores(mod.with.long.name.form, ncol=3) plotmores(object=mod.with.long.name.form, ncol=3) plotmo grid: Girth Height Girth12345678901234567890 12.9 76 0.004544606 > par(org.par) > > #-- make sure that we can work with all families > > set.seed(2016) > par(mfrow=c(3,3), mar=c(3,3,3,1)) > n <- 100 > p <- 4 > xx <- matrix(rnorm(n*p), n, p) > g2 <- sample(1:2, n, replace=TRUE) > data.xg2 <- data.frame(g2, xx) > for(family in c("gaussian","binomial","poisson")) { + title.extra <- paste(family, ": ") + mod <- glmnet(xx,g2,family=family) + plotmores(mod, xvar="lambda", ncol=3, title.extra=title.extra) + title.extra <- paste("formula", family, ": ") + mod.form <- glmnet(g2~., data.xg2, family=family, use.model.frame=TRUE) + plotmores(mod.form, xvar="lambda", ncol=3, title.extra=title.extra) + } gaussian : plotmores(object=mod, xvar="lambda", title.extra=title.extra, ncol=3) plotmo grid: x1 x2 x3 x4 -0.2662071 0.1805768 0.03613807 0.2422419 formula gaussian : plotmores(object=mod.form, xvar="lambda", title.extra=title.extra, ncol=3) plotmo grid: X1 X2 X3 X4 -0.2662071 0.1805768 0.03613807 0.2422419 binomial : plotmores(object=mod, xvar="lambda", title.extra=title.extra, ncol=3) plotmo grid: x1 x2 x3 x4 -0.2662071 0.1805768 0.03613807 0.2422419 formula binomial : plotmores(object=mod.form, xvar="lambda", title.extra=title.extra, ncol=3) plotmo grid: X1 X2 X3 X4 -0.2662071 0.1805768 0.03613807 0.2422419 poisson : plotmores(object=mod, xvar="lambda", title.extra=title.extra, ncol=3) plotmo grid: x1 x2 x3 x4 -0.2662071 0.1805768 0.03613807 0.2422419 formula poisson : plotmores(object=mod.form, xvar="lambda", title.extra=title.extra, ncol=3) plotmo grid: X1 X2 X3 X4 -0.2662071 0.1805768 0.03613807 0.2422419 > par(org.par) > # cox > library(plotmo) > n <- 100 > p <- 20 > nzc <- trunc(p/10) > set.seed(2016) > beta <- rnorm(nzc) > x7 <- matrix(rnorm(n*p), n, p) > beta <- rnorm(nzc) > fx <- x7[,seq(nzc)] %*% beta/3 > hx <- exp(fx) > ty <- rexp(n, hx) > tcens <- rbinom(n=n, prob=.3, size=1)# censoring indicator > yy <- cbind(time=ty, status=1-tcens) # yy=Surv(ty,1-tcens) with library(survival) > glmnet.cox <- glmnet(x=x7, y=yy, family="cox") > plotmores(glmnet.cox, ncol=3, degree1=1:4) plotmores(object=glmnet.cox, degree1=1:4, ncol=3) plotmo grid: x1 x2 x3 x4 x5 x6 -0.2662071 0.1805768 0.1144668 0.2262892 0.1050429 -0.02858422 x7 x8 x9 x10 x11 x12 x13 -0.0799275 0.08172409 -0.107284 0.2036831 0.08643651 -0.0435986 0.1664937 x14 x15 x16 x17 x18 x19 x20 -0.003946797 -0.1313896 0.1714765 0.2209166 -0.2018331 -0.1230542 -0.04088624 > par(org.par) > # TODO formula interface not tested for cox models > > source("test.epilog.R") plotmo/inst/slowtests/make.README.R0000644000176200001440000000041013725307662016612 0ustar liggesusers# create README.html from README.md # the paths below assume that this file is in the plotmo/inst/slowtests directory library(rpart.plot) library(rmarkdown) rmarkdown::render("../../README.md", output_dir="../../.#") if(!interactive()) q(runLast=FALSE) plotmo/inst/slowtests/make.README.figs.R0000644000176200001440000000310413725307662017544 0ustar liggesusers# make.README.figs.R: Build the figures used by plotmo README.md # The paths below assume that this file is in the plotmo/inst/slowtests directory # Swindon May 2018 library(plotmo) library(earth) # for the ozone1 data data(ozone1) library(randomForest) oz <- ozone1[, c("O3", "humidity", "temp")] # small set for illustration set.seed(2018) rf.mod <- randomForest(O3 ~ ., data=oz) # png("../../inst/README-figures/plotmo-randomForest.png", width=460, height=500) # plotmo(rf.mod, cex.caption=1.5, font.caption=2, oma=c(0,0,5,0), # persp.ticktype="detailed", persp.nticks=2) # dev.off() # png("../../inst/README-figures/plotres-randomForest.png", width=460, height=530) # set.seed(2018) # plotres(rf.mod, cex=1.1, cex.caption=1.5, font.caption=2, oma=c(1,0,3,0)) # dev.off() # png("../../inst/README-figures/plotres-glmnet-gbm.png", width=700, height=400) # par(mfrow=c(1,2), oma=c(1,0,0,0)) # library(glmnet) # set.seed(2016) # x <- matrix(rnorm(100 * 10), 100, 10) # y <- x[,1] + x[,2] + 3 * rnorm(100) # y depends only on x[,1] and x[,2] # mod <- glmnet(x, y) # plotres(mod, which=1, predict.s=0.25, cex=1.2, pt.cex=.8) # title("glmnet model\n\n\n") # library(gbm) # library(earth); data(ozone1) # get the ozone data # set.seed(2017) # oz <- ozone1[sample.int(n=nrow(ozone1)),] # randomize row order for train.fraction # gbm.mod <- gbm(O3~., data=oz, distribution="gaussian", interaction.depth=2, # shrinkage=.01, train.fraction=.8, cv.folds=10, n.trees=3000) # plotres(gbm.mod, which=1) # title("gbm model\n\n", xpd=NA) # dev.off() plotmo/inst/slowtests/test.unusual.vars.bat0000755000176200001440000000173314655214117020741 0ustar liggesusers@rem test.unusual.vars.bat: test unusual variable names and formulas @rem this file was first created for plotmo 3.6.0 (Sep 2020) @echo test.unusual.vars.bat @"C:\PROGRA~1\R\R-4.4.1\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.unusual.vars.R @if %errorlevel% equ 0 goto good1: @echo R returned errorlevel %errorlevel%, see test.unusual.vars.Rout: @echo. @tail test.unusual.vars.Rout @echo test.unusual.vars.R @exit /B 1 :good1 mks.diff test.unusual.vars.Rout test.unusual.vars.Rout.save @if %errorlevel% equ 0 goto good2: @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.unusual.vars.save.ps @exit /B 1 :good2 @rem test.unusual.vars.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.unusual.vars.save.ps @if %errorlevel% equ 0 goto good3: @echo === Files are different === @exit /B 1 :good3 @rm -f test.unusual.vars.Rout @rm -f Rplots.ps @exit /B 0 plotmo/inst/slowtests/test.plotres.Rout.save0000644000176200001440000003563314663412422021104 0ustar liggesusers> # test.plotres.R > > source("test.prolog.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix > data(ozone1) > data(etitanic) > example(plotres) plotrs> # we use lm in this example, but plotres is more useful for models plotrs> # that don't have a function like plot.lm for plotting residuals plotrs> plotrs> lm.model <- lm(Volume~., data=trees) plotrs> plotres(lm.model) > > # basic tests of plotmo on abbreviated titanic data > > get.tit <- function() + { + tit <- etitanic + pclass <- as.character(tit$pclass) + # change the order of the factors so not alphabetical + pclass[pclass == "1st"] <- "first" + pclass[pclass == "2nd"] <- "class2" + pclass[pclass == "3rd"] <- "classthird" + tit$pclass <- factor(pclass, levels=c("class2", "classthird", "first")) + # log age is so we have a continuous predictor even when model is age~. + set.seed(2015) + tit$logage <- log(tit$age) + rnorm(nrow(tit)) + tit$parch <- NULL + # by=12 gives us a small fast model with an additive and a interaction term + tit <- tit[seq(1, nrow(etitanic), by=12), ] + } > > tit <- get.tit() > > plotlm1 <- function(object) + { + old.par <- par(no.readonly=TRUE) + on.exit(par(old.par)) + par(mfrow=c(2,2), oma=c(0,0,3,0), mar=c(4, 3, 3, 1.5), + mgp=c(1.5, 0.4, 0), tcl=-.3, font.main=1, cex.main=1) + plot(object, sub.caption="standard call to plot.lm") + } > plotlm.using.plotres <- function(object) + { + old.par <- par(no.readonly=TRUE) + on.exit(par(old.par)) + par(mfrow=c(2,2), oma=c(0,0,3,0), mar=c(4, 3, 3, 1.5), + mgp=c(1.5, 0.4, 0), tcl=-.3, font.main=1, cex.main=1) + # residuals vs fitted + plotres(object, pch=1, which=3, + caption=paste(deparse(object$call), collapse=" ")) + # QQ plot + plotres(object, pch=1, which=4, standardize=TRUE) + # scale-location plot + plotres(object, pch=1, which=6, standardize=TRUE) + # leverage plot + plotres(object, pch=1, which=3, versus=4, standardize=TRUE) + } > lm.mod <- lm(Volume~., data=trees) > plotlm1(lm.mod) > plotlm.using.plotres(lm.mod) > > # various arguments > > plotres(lm.mod, SHOWCALL=TRUE) > plotres(lm.mod, level=.95, id.n=-3, SHOWCALL=TRUE) > lm.tit <- lm(survived~., data=tit) > col <- ifelse(tit$survived, "green", "red") > pch <- ifelse(tit$sex == "male", 20, 6) > plotres(lm.tit, level=.95, col=col, pch=pch, + level.shade="gray", level.shade2="lightgray", SHOWCALL=TRUE) > plotres(lm.tit, col.resp=3, cum.col=2, cum.cex=1.2, grid.col=5, qq.col=1, qq.cex=.3, SHOWCALL=TRUE) > plotres(lm.tit, pt.col="pink", smooth.col=0, SHOWCALL=TRUE) > plotres(lm.tit, smooth.col=3, smooth.lwd=1.2, smooth.lty=2, smooth.f=.2, + label.col=4, label.cex=.9, label.font=2, SHOWCALL=TRUE) > foo <- function() + { + afoo <- earth(O3~., data=ozone1, deg=2) + old.par <- par(no.readonly=TRUE) + on.exit(par(old.par)) + par(mfrow=c(2,2), oma=c(0,0,3,0), mar=c(4, 3, 3, 1.5), + mgp=c(1.5, 0.4, 0), tcl=-.3, font.main=1, cex.main=1) + # test xlim ylim etc. on qq and cum plots + plotres(afoo, which=2, trace=0, xlim=c(0,20), ylim=c(-.2,1.1), grid.col="pink", info=TRUE) + plotres(afoo, which=2, trace=0, + grid.col="pink", info=TRUE, cum.col=2, cum.cex=1.4) + plotres(afoo, which=4) + plotres(afoo, which=4, trace=0, xlim=c(-7,7), ylim=c(-20, 20), + qq.col=2, qq.cex=.5, label.col=1, qqline.col="orange", qqline.lty=1) + # check xlim and ylim apply only to resids plots if multiple plots + plotres(afoo, which=c(2:5), trace=0, xlim=c(-1,5), ylim=c(-8, 8), + qq.col=2, qq.cex=.5, label.col=1, qqline.col="orange", smooth.col=3, smooth.lwd=2) + } > foo() > > # test id.n and npoints > set.seed(1066) > a20 <- earth(Volume~., data=trees, ncr=3, nfo=3, varmod.method="lm", keepxy=TRUE) > par(mfrow=c(2,2), oma=c(0,0,3,0), mar=c(4, 3, 3, 1.5), mgp=c(1.5, 0.4, 0), tcl=-.3, cex=1) > plot(a20, which=3, standardize=TRUE, smooth.col=0, id.n=-1, main="a20-00, smooth.col=0, id.n=-1", + caption="test id.n and npoints") > plot(a20, which=3, standardize=TRUE, smooth.col=0, id.n=10, main="a20-01, smooth.col=0, id.n=10") > # this tests cex with do.par=FALSE > plot(a20, which=3, standardize=TRUE, smooth.col=0, npoints=10, cex=.8, main="a20-02, smooth.col=0, npoints=10, cex=.8") > # TODO labels are hosed in the following > plot(a20, which=3, standardize=TRUE, smooth.col=0, npoints=5, id.n=10, main="a20-03, labels hosed\nsmooth.col=0, npoints=10, id.n=10") > > # test leverages and handling of unity leverages > lm.mod <- lm(Volume~., data=trees) > par(mfrow=c(2,2), oma=c(0,0,3,0), mar=c(4, 3, 3, 1.5), mgp=c(1.5, 0.4, 0), tcl=-.3, cex=1) > a20$leverages[31] <- 1 # fake a unity leverage > plot(a20, which=3, versus=4, standardize=TRUE, main="resids vs leverage\nunity leverage", + caption="leverage plots") > plotres(a20, which=3, standardize=TRUE, main="resids vs fitted\nunity leverage") > plotres(lm.mod, which=3, versus=4, standardize=TRUE, main="lever plot for lm.mod") > plotres(lm.mod, which=3, versus=4, standardize=TRUE, main="cook args", + cook.levels=c(.5, .8, 1), cook.col="blue", cook.lty=2) > > plot(a20, which=3, versus=4, standardize=TRUE, info=TRUE, main="resids vs leverage\nunity leverage", + caption="leverage plots with info=TRUE") > plotres(a20, which=3, standardize=TRUE, info=TRUE, main="resids vs fitted\nunity leverage") > plotres(lm.mod, which=3, versus=4, standardize=TRUE, info=TRUE, main="lever plot for lm.mod") > plotres(lm.mod, which=3, versus=4, standardize=TRUE, info=TRUE, main="cook args", + cook.levels=c(.5, .8, 1), cook.col="blue", cook.lty=2) > > # back compat tests > par(mfrow=c(2,2), oma=c(0,0,3,0), mar=c(4, 3, 3, 1.5), mgp=c(1.5, 0.4, 0), tcl=-.3) > plotres(a20, which=3, col.smooth=4, smooth.lwd=2, smooth.lty=2, + main="a20-04 col.smooth=4, smooth.lwd=2, smooth.lty=2", + caption="back compat tests with plot.earth") > plotres(a20, which=4, qq.col=3, + qqline.col="lightblue", qqline.lty=2, main="a20-05 qq.col=3") > plotres(a20, which=4, qqline.col=0, main="a20-06 qqline.col=0") > # set.seed(1066) > # mod.earth.tit <- earth(tit[,-3], tit[,3], degree=2, nfold=3, ncross=3, varmod.method="earth", keepxy=TRUE) > plot(0,0) > plot(a20, which=1, col.grid="pink", col.rsq=3, lty.rsq=1, main="a20-07 col.grid=\"pink\", col.rsq=3, lty.rsq=1") > > # TODO following not working? > plot(a20, which=3, col.cv=4, col.grid="pink", main="a20-08 col.cv=4, col.grid=\"pink\"") > > plot(a20, which=3, col.points="orange", cex.points=1.5, main="a20-09 col.points=\"orange\", cex.points=1.5") > plot(a20, which=3, col.residuals="orange", smooth.f=.2, col.line=3, main="a20-10 col.residuals=\"orange\", smooth.f=.2, col.line=3") > > # test graphics args outside do.par > par(col.main="#456789") > cat("before par: cex=", par("cex"), " col.main=", par("col.main"), " col.axis=", par("col.axis"), "\n", sep="") before par: cex=0.83 col.main=#456789 col.axis=black > plot(a20, which=c(2,3), caption="a20 which=c(2,3) (i.e. do.par=TRUE) no cex") > plot(a20, which=c(2,3), cex=1, caption="a20 which=c(2,3) (i.e. do.par=TRUE) cex=1, plot should be identical to previous page") > plot(a20, which=c(2,3), cex=1.2, caption="a20 which=c(2,3) (i.e. do.par=TRUE) cex=1.2") > plot(a20, which=3, main="no cex", caption="a20 test graphics args with do.par=FALSE") > plot(a20, which=3, cex=1, main="cex=1") > plot(a20, which=3, cex=.8, main="cex=.8") > plot(a20, which=3, cex=1.1, col.main=2, col.axis="blue", col.lab=3, font.lab=2, + main="cex=1.1, col.main=2, col.axis=\"blue\", col.lab=3, font.lab=2") > # all of these should have been restored > cat("after par: cex=", par("cex"), " col.main=", par("col.main"), " col.axis=", par("col.axis"), "\n", sep="") after par: cex=0.83 col.main=#456789 col.axis=black > stopifnot(par("col.main") == "#456789") > par(col.main=1) > > survived <- as.numeric(tit$survived) # 0 or 1 > sex <- as.numeric(tit$sex) # 1 or 2 > pclass <- as.numeric(tit$pclass) # 1,2, or 3 > age <- tit$age # .2 to 80 > > printf("======== basic operation, compare to plot.lm etc.\n") ======== basic operation, compare to plot.lm etc. > par(mfrow=c(2,2), mar=c(3,3,3,1), mgp=c(1.5,0.5,0), oma=c(0,0,2.5,0)) > lm <- lm(survived~sex+pclass+age) > plot(lm, which=5, pch=20) > plot(0, 0) > plot(lm, which=1, pch=20) > plot(lm, which=2, pch=20) > plotres(lm, standardize=1, cook.levels=c(.1,.2,.3), SHOWCALL=TRUE) > elm <- earth(survived~sex+pclass+age, linpreds=TRUE, thresh=0, penalty=-1) > plotres(elm, col=survived+2, SHOWCALL=TRUE) > set.seed(2015) > elm.glm <- earth(survived~sex+pclass+age, linpreds=TRUE, thresh=0, penalty=-1, + glm=list(family=binomial), + ncr=3, nfold=3, varmod.method="lm") > plotres(elm.glm, col=survived+2, SHOWCALL=TRUE) > > printf("======== check type arg with earth\n") ======== check type arg with earth > par(mfrow=c(2,2), mar=c(3,3,3,1), mgp=c(1.5,0.5,0), oma=c(0,0,2.5,0)) > # following two are equivalent > # TODO $$ following look wrong (the plots have changed from plotmo/earth pre Sep 2020) > plotres(elm.glm, col=survived+2, standardize=TRUE, + which=3, do.par=FALSE, main="standardize=TRUE") > mtext("elm.glm with various type options", outer=TRUE, font=2, line=1, cex=1) > plotres(elm.glm, col=survived+2, type="standardize", + which=3, do.par=FALSE, main="type=\"standardize\"\nequivalent to standardize=TRUE") > # TODO double standardization, should not be allowed > plotres(elm.glm, col=survived+2, standardize=TRUE, type="standardize", + which=3, do.par=FALSE, + main="standard=TRUE, type=\"deviance\"\ndouble standardization") > plotres(elm.glm, col=survived+2, type="deviance", + which=3, do.par=FALSE, main="type=\"deviance\"") > > printf("======== multiple response earth models\n") ======== multiple response earth models > par(mfrow=c(2,2), mar=c(3,3,3,1), mgp=c(1.5,0.5,0), oma=c(0,0,2.5,0)) > set.seed(2015) > emulti0 <- earth(cbind(Volume, Volume + 100 + 5 * rnorm(nrow(trees)))~., data=trees) > set.seed(2015) > plot(emulti0, nresponse=2, which=3, do.par=FALSE, main="emulti0 nresponse=2") > set.seed(2015) > rnorm1 <- rnorm(nrow(trees)) > emulti <- earth(cbind(Volume, Volume + 100 + 5 * rnorm1)~., data=trees) > plot(emulti, nresponse=2, + which=3, do.par=FALSE, main="emulti nresponse=2") > mtext("multiple response earth models", outer=TRUE, font=2, line=1, cex=1) > plot(emulti, nresponse=2, FORCEPREDICT=TRUE, + which=3, do.par=FALSE, main="emulti, nresponse=2\nFORCEPREDICT=TRUE") > > printf("======== earth model with a factor response\n") ======== earth model with a factor response > epclass <- earth(pclass~., data=tit) > par(mfrow=c(2,2), mar=c(3,3,3,1), mgp=c(1.5,0.5,0), oma=c(0,0,2.5,0)) > set.seed(2015) > plot(epclass, nresponse="first", trace=1, + which=3, do.par=FALSE, main="pclass response, nresponse=\"first\"") stats::residuals(object=earth.object, type="response") stats::fitted(object=earth.object) got model response from model.frame(pclass ~ survived + sex + age + sibsp..., data=call$data, na.action="na.fail") training rsq 0.23 > mtext("earth model with a factor response", outer=TRUE, font=2, line=1, cex=1) > plot(epclass, nresponse="first", trace=1, FORCEPREDICT=TRUE, + which=3, do.par=FALSE, + main="pclass response, nresponse=\"first\"\nFORCEPREDICT=TRUE") stats::predict(earth.object, NULL, type="response") stats::fitted(object=earth.object) got model response from model.frame(pclass ~ survived + sex + age + sibsp..., data=call$data, na.action="na.fail") training rsq 0.23 > > printf("======== glm\n") ======== glm > glm <- glm(survived~sex+pclass+age, family=binomial) > par(mfrow=c(2,2), mar=c(3,3,3,1), mgp=c(1.5,0.5,0), oma=c(0,0,2.5,0)) > plot(glm, which=1, pch=20, main="plot.lm") > mtext("glm model with plot.lm and plotres", outer=TRUE, font=2, line=1, cex=1) > plotres(glm, which=3, main="plotres glm survived") > # with plotres we can also plot pearson etc. residuals > plotres(glm, which=3, type="pearson", main="plotres glm survived\ntype=\"pearson\"") > > printf("======== rpart\n") ======== rpart > library(rpart) > par(mfrow=c(2,2), mar=c(3,3,3,1), mgp=c(1.5,0.5,0), oma=c(0,0,2.5,0)) > rpart <- rpart(survived~sex+pclass+age) > plotres(rpart, SHOWCALL=TRUE) > plotres(rpart, SHOWCALL=TRUE, FORCEPREDICT=TRUE) # identical > # TODO following fails in plotmo.predict.rpart (which is called to get the fitted values) > # plotres(rpart, type="pearson") > plotres(rpart, jitter=3, w1.extra=100, w1.under=TRUE, w1.branch.type=5, + col=survived+2, smooth.col=NA, label.col=1, SHOWCALL=TRUE) > > fit <- rpart(Kyphosis ~ Age + Number + Start, data = kyphosis) > plotres(fit, nresponse=1, SHOWCALL=TRUE, jitter=5) > plotres(fit, nresponse=2, SHOWCALL=TRUE, jitter=TRUE) > > printf("======== versus=\"b:\"\n") ======== versus="b:" > > library(gam) Loading required package: splines Loading required package: foreach Loaded gam 1.22-4 > gam.package.loaded <- "package:gam" %in% search() > mgcv.package.loaded <- "package:mgcv" %in% search() > if(mgcv.package.loaded && gam.package.loaded) { + # prevent downstream confusing error messages + stop0("both 'gam' and 'mgcv' are loaded") + } > library(earth) > data(ozone1) > data(ozone1) > oz <- ozone1[, c("O3", "humidity", "temp", "ibt")] > gam.mod <- gam(O3^(1/3) ~ lo(humidity)+lo(ibt,temp), data=oz) > plotmo(gam.mod, SHOWCALL=TRUE) plotmo grid: humidity ibt temp 64 167.5 62 > plotres(gam.mod, SHOWCALL=TRUE) > plotres(gam.mod, versus="b:", SHOWCALL=TRUE) > plotres(gam.mod, versus="b:ib", info=TRUE, SHOWCALL=TRUE) > > gam.linear.humidity.only <- gam(O3^(1/3) ~ humidity, data=oz) > plotres(gam.linear.humidity.only, versus="b:", SHOWCALL=TRUE) > > library(mda) Loading required package: class Loaded mda 0.5-4 > mars <- mars(ozone1[,2:3], ozone1[,1], degree=2) > mars.to.earth <- mars.to.earth(mars) Converted mars(x=ozone1[,2:3], y=ozone1[,1], degree=2) to earth(x=ozone1[,2:3], y=ozone1[,1], degree=2) > plotres(mars, versus="b:", caption="mars model, versus=\"b:\"", SHOWCALL=TRUE) > plotres(mars.to.earth, versus="b:", caption="earth model, versus=\"b:\", should be same as previous page", SHOWCALL=TRUE) > plotres(mars, versus="b:1", caption="mars model, versus=\"b:1\"", SHOWCALL=TRUE) > > # lars is tested in plotmo3.R > # gbm is tested in plotmo3.R > # TODO fda is not tested > > source("test.epilog.R") plotmo/inst/slowtests/test.plotres.bat0000755000176200001440000000145714655214117017766 0ustar liggesusers@rem test.plotres.bat: test plotres @echo test.plotres.bat @"C:\PROGRA~1\R\R-4.4.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/linmod.R0000644000176200001440000002555313727275573016251 0ustar liggesusers# linmod.R: Example S3 linear model. # # See www.milbo.org/doc/modguide.pdf. # This software may be freely used. linmod <- function(...) UseMethod("linmod") linmod.default <- function(x = stop("no 'x' argument"), y = stop("no 'y' argument"), keep = FALSE, ...) { stop.if.dot.arg.used(...) xmat <- as.matrix(x) # use name "(Intercept)" here so coef names match linmod.formula x <- cbind("(Intercept)" = 1, xmat) fit <- linmod.fit(x, y) fit$call <- match.call() if(keep) { fit$x <- xmat # save y as a one-column matrix, so can use colname to save response name colname <- deparse(substitute(y))[1] colname <- gsub(" ", "", substr(colname, 1, 100)) # strip spaces, truncate fit$y <- as.matrix(y, ncol = 1) colnames(fit$y) <- colname } fit } linmod.formula <- function(formula = stop("no 'formula' argument"), data = parent.frame(), keep = FALSE, ...) { stop.if.dot.arg.used(...) if(is.matrix(data)) # allow data to be a matrix data <- as.data.frame(data) # will create colnames V1 V2 V3 if necessary # note that na.action=na.pass because we will catch NAs later # in linmod.fit, for uniformity with linmod.default mf <- model.frame(formula = formula, data = data, na.action = na.pass) terms <- attr(mf, "terms") x <- model.matrix(terms, mf) y <- model.response(mf) fit <- linmod.fit(x, y) fit$call <- match.call() fit$terms <- terms fit$xlevels <- .getXlevels(terms, mf) # for use by predict.linmod if(keep) fit$data <- data fit } linmod.fit <- function(x = stop("no 'x' argument"), y = stop("no 'y' argument"), ...) { # internal function, not for the casual user # if model has an intercept, the first col of x must be intercept (all 1s) stop.if.dot.arg.used(...) x <- check.linmod.x(x) y <- check.linmod.y(x, y) fit <- do.linmod.fit(x, y) class(fit) <- "linmod" fit } check.linmod.x <- function(x) { if(!is.matrix(x)) stop("'x' is not a matrix or could not be converted to a matrix") if(NROW(x) == 0 || NCOL(x) == 0) stop("'x' is empty") if(anyNA(x)) stop("NA in 'x'") # checking just the first column of x suffices because all columns # of a matrix have the same type # we allow is.logical because qr etc. treat logical vars as numeric if(!is.numeric(x[,1]) && !is.logical(x[,1])) stop("non-numeric column in 'x'") # ensure all columns in x are named (needed for names in vcov etc.) # use the same naming convention as lm (prefix for unnamed cols is "V") missing.colnames <- if(is.null(colnames(x))) 1:NCOL(x) else nchar(colnames(x)) == 0 colnames(x)[missing.colnames] <- c("(Intercept)", paste("V", seq_len(NCOL(x) - 1), sep = ""))[missing.colnames] duplicated <- which(duplicated(colnames(x))) if(length(duplicated)) stop("column name \"", colnames(x)[duplicated[1]], "\" in 'x' is duplicated") x } check.linmod.y <- function(x, y) { # as.vector(as.matrix(y)) is necessary when y is a data.frame # (because as.vector alone on a data.frame returns a data.frame) y <- as.vector(as.matrix(y)) if(length(y) == 0) stop("'y' is empty") if(anyNA(y)) stop("NA in 'y'") if(!is.numeric(y) && !is.logical(y)) stop("'y' is not numeric or logical") if(length(y) != nrow(x)) stop("nrow(x) is ", nrow(x), " but length(y) is ", length(y)) y } do.linmod.fit <- function(x, y) { # workhorse function for fitting linear models # essential processing and sanity checks on x and y are already completed # x is a numeric matrix, y is a numeric vector qx <- qr(x) # QR-decomposition of x if(qx$rank < ncol(x)) stop("'x' is singular (it has ", ncol(x), " columns but its rank is ", qx$rank, ")\n colnames(x): ", paste0(colnames(x), collapse=' ')) coef <- solve.qr(qx, y) # compute (x'x)^(-1) x'y stopifnot(!anyNA(coef)) # NA impossible after rank check above df.residual <- max(0, nrow(x) - ncol(x)) # degrees of freedom sigma2 <- sum((y - x %*% coef)^2) / df.residual # variance of residuals vcov <- sigma2 * chol2inv(qx$qr) # covar mat is sigma^2 * (x'x)^(-1) fitted.values <- qr.fitted(qx, y) colnames(vcov) <- rownames(vcov) <- colnames(x) names(fitted.values) <- rownames(x) colnames(coef) <- colnames(y) # returned fields match lm's fields list(coefficients = coef, residuals = y - fitted.values, rank = qx$rank, fitted.values = fitted.values, vcov = vcov, sigma = sqrt(sigma2), df.residual = df.residual) } predict.linmod <- function(object = stop("no 'object' argument"), newdata = NULL, type = "response", ...) { stopifnot(inherits(object, "linmod")) stop.if.dot.arg.used(...) match.arg(type, "response") # the type argument is not yet supported if(is.null(newdata)) yhat <- fitted(object) else { if(NROW(newdata) == 0) stop("'newdata' is empty") # preempt obscure message later x <- if(is.null(object$terms)) # model built with linmod.default? process.newdata(object, newdata) else # model built with linmod.formula process.newdata.formula(object, newdata) # The following tests suffice to catch all illegal input. However # they aren't ideal in that they don't always direct you to the root # cause of the problem (i.e. the error messages aren't always optimal). nvar <- length(object$coefficients) - 1 # nbr vars, -1 for intercept if(ncol(x) - 1 != nvar) stop("ncol(newdata) is ", ncol(x) - 1, " but should be ", nvar) if(anyNA(x)) stop("NA in 'newdata'") if(!is.numeric(x[,1]) && !is.logical(x[,1])) stop("non-numeric column in 'newdata' (after processing)") yhat <- as.vector(do.predict.linmod(object, x)) names(yhat) <- rownames(x) } yhat } process.newdata <- function(object, newdata) { # process newdata for models built with linmod.default x <- if(is.vector(newdata)) # allow newdata to be a vector matrix(newdata, ncol = length(object$coefficients) - 1) else as.matrix(newdata) # allow newdata to be a data.frame cbind(1, x) # return data with an intercept column } process.newdata.formula <- function(object, newdata) { # process newdata for models built with linmod.formula newdata <- as.data.frame(newdata) # allows newdata to be a matrix terms <- object$terms dataClasses <- attr(terms, "dataClasses") iresp <- attr(terms, "response") terms <- delete.response(terms) # na.action=na.pass because we will catch NAs after (for clearer error msg) # xlevels is needed to convert strings to factor levels, for example: # a <- linmod(Sepal.Length~Species,data=iris) # predict(a,newdata=data.frame(Species="setosa")) mf <- model.frame(terms, newdata, na.action = na.pass, xlev = object$xlevels) if(anyNA(mf)) stop("NA in 'newdata'") if(NROW(mf) != NROW(newdata)) { # Get here when model.frame() issues # Warning: 'newdata' had M rows but variables found have N rows # Must stop, else the call to model.matrix() below would silently return bad data. # If a variable is missing, print its name to help the user. # TODO This will erroneously identify "sqrt(x)" as a missing var in the # formula "y ~ sqrt(x)" (because the var is wrapped in a func call). varnames <- names(dataClasses) varnames <- varnames[-iresp] missing <- which(!(varnames %in% colnames(newdata))) missing.msg <- "" if(length(missing)) missing.msg <- paste0(" (variable '", varnames[missing[1]], "' may be missing from newdata)") stop("newdata has ", NROW(newdata), " rows but model.frame returned ", NROW(mf), " rows", missing.msg) } .checkMFClasses(dataClasses, mf) # check types in newdata match original data model.matrix(terms, mf) } do.predict.linmod <- function(object, x) { # workhorse function for linear model predictions # processing by model.matrix etc. and sanity checks on x already completed # x is a numeric matrix (if model has intercept, first col of x is all 1s) x %*% coef(object) } summary.linmod <- function(object = stop("no 'object' argument"), ...) { stop.if.dot.arg.used(...) se <- sqrt(diag(object$vcov)) t.value <- coef(object) / se p.value <- if(object$df.residual == 0) # avoid warning from pt() rep_len(0, length.out=length(t.value)) else 2 * pt(-abs(t.value), df = object$df.residual) coefficients <- cbind(Estimate = coef(object), StdErr = se, t.value = t.value, p.value = p.value) retval <- list(call = object$call, coefficients = coefficients) class(retval) <- "summary.linmod" retval } print.linmod <- function(x = stop("no 'x' argument"), ...) { stop.if.dot.arg.used(...) print.model.call(x) print(x$coefficients) invisible(x) } print.summary.linmod <- function(x = stop("no 'x' argument"), ...) { stop.if.dot.arg.used(...) print.model.call(x) print(x$coefficients) invisible(x) } print.model.call <- function(x) { cat("Call: ") # print.lm has a newline here, but a space is more compact # use paste0 to convert vector of strings to single string if necessary cat(strwrap(paste0(deparse(x$call, control = NULL, nlines = 5), sep = " ", collapse = " "), exdent = 6), sep = "\n") cat("\n") } # stop.if.dot.arg.used will cause an error message if any args are passed to it. # We use it to test if any dots arg of the calling function was used, for # functions that must have a dots arg (to match the generic method) but don't # actually use the dots. This helps the user catch mistyped or illegal args. # R version 3.3-0 or higher has a function chkDots which could be used instead. stop.if.dot.arg.used <- function() { NULL } plotmo/inst/slowtests/test.plotmo3.bat0000755000176200001440000000151614655214117017667 0ustar liggesusers@rem test.plotmo3.bat: extra tests for plotmo version 3 and higher @echo test.plotmo3.bat @"C:\PROGRA~1\R\R-4.4.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.linmod.bat0000755000176200001440000000147014655214117017553 0ustar liggesusers@rem test.linmod.bat: test example S3 model in linmod.R @echo test.linmod.bat @"C:\PROGRA~1\R\R-4.4.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.caret.R0000644000176200001440000001041513737416673017031 0ustar liggesusers# test.caret.R: test plotmo on caret models # # TODO This is a minimal set of tests. source("test.prolog.R") library(plotmo) library(earth) library(caret) data(ozone1) data(etitanic) dopar <- function(nrows, ncols, caption = "") { cat(" ", caption, "\n") par(mfrow=c(nrows, ncols)) par(oma = c(0, 0, 3, 0)) par(mar = c(3, 3, 1.7, 0.5)) par(mgp = c(1.6, 0.6, 0)) par(cex = 0.7) } set.seed(2010) caret.earth.mod <- train(O3~., data=ozone1, method="earth", tuneGrid=data.frame(degree=2, nprune=10)) # SHOWCALL is just a testing thing, so we can see who created the plot on the plot itself plotmo(caret.earth.mod, trace=1, SHOWCALL=TRUE) plotmo(caret.earth.mod$finalModel, trace=1, SHOWCALL=TRUE) plotres(caret.earth.mod, trace=1, SHOWCALL=TRUE) # plotres(caret.earth.mod$finalModel, trace=1, SHOWCALL=TRUE) set.seed(2015) bag <- bagEarth(O3~., data=ozone1, degree=2, B=3) print(bag$fit) # pairs are plotted correctly (I think) plotmo(bag, type="response", trace=1, SHOWCALL=TRUE) plotres(bag, type="response", trace=1, SHOWCALL=TRUE) set.seed(2015) a.bag1 <- bagEarth(trees[,-3], trees[,3], degree=2, B = 3) plotmo(a.bag1, trace=1, SHOWCALL=TRUE, all2=TRUE, caption="bagEarth, trees") plotres(a.bag1, trace=1, SHOWCALL=TRUE) # trace=1 to display "Fixed rank deficient bx by removing 1 term" messages set.seed(2015) a.bag3 <- bagEarth(survived~., data=etitanic, degree=2, B=3, trace=1) plotmo(a.bag3, clip=F, caption="bagEarth, etitanic", trace=1, SHOWCALL=TRUE) plotres(a.bag3, clip=F, trace=1, SHOWCALL=TRUE) # following based on example by Max Kuhn on stackoverflow etit <- etitanic etit$survived <- factor(ifelse(etit$survived == 1, "yes", "no"), levels = c("yes", "no")) set.seed(2015) caret.earth.mod2 <- train(survived ~ ., data = etit, method = "earth", tuneGrid = data.frame(degree = 2, nprune = 9), trControl = trainControl(method = "none", classProbs = TRUE)) # Following gives expected warning (because factors in caret-earth model) # Warning: Cannot determine which variables to plot (use all1=TRUE?) plotmo(caret.earth.mod2, trace=1, SHOWCALL=TRUE) # changed Sep 2020: following with all2=2 generates the same plot as above (because with warning, above defaults to all2=TRUE) plotmo(caret.earth.mod2, trace=1, all2=TRUE, SHOWCALL=TRUE, caption="caret.earth.mod2: all2=2") plotres(caret.earth.mod2, trace=1, SHOWCALL=TRUE) # Sep 2020: test with a logical variable (check that get.earth.vars.for.plotmo strips "sexTRUE" to "sex") # following should be exactly the same model as caret.earth.mod2 except for the variable naming for sex etit.bool <- etitanic etit.bool$survived <- factor(ifelse(etit.bool$survived == 1, "yes", "no"), levels = c("yes", "no")) etit.bool$sex <- etit.bool$sex == "male" # to bool set.seed(2015) # same random seed as above (may not be necessary) caret.earth.boolfac <- train(survived ~ ., data = etit.bool, method = "earth", tuneGrid = data.frame(degree = 2, nprune = 9), trControl = trainControl(method = "none", classProbs = TRUE)) print(summary(caret.earth.boolfac)) plotmo(caret.earth.boolfac, trace=0, SHOWCALL=TRUE) # Warning: Cannot determine which variables to plot (use all1=TRUE?) # changed Sep 2020: following with all1=TRUE, all2=TRUE generates the same plot as above plotmo(caret.earth.boolfac, trace=0, all1=TRUE, all2=TRUE, SHOWCALL=TRUE, caption="caret.earth.mod2: all1=T, all2=T") data(ozone1) set.seed(2020) a <- train(O3 ~ ., data = ozone1, method = "earth", tuneGrid = data.frame(degree = 2, nprune = 14)) plotmo(a, trace=1, SHOWCALL=TRUE) plotres(a, trace=1, SHOWCALL=TRUE) cat("=== method=\"svmRadial\" (S4 model wrapped in an S3 model) ===\n") data(trees) set.seed(2019) library(kernlab) mod <- train(Girth~., data=trees, method="svmRadial", trControl=trainControl(method="cv", number=2), tuneLength=2, preProcess = c("center", "scale")) plotres(mod, info=TRUE) set.seed(2020) plotmo(mod, pt.col=2, all2=TRUE, pmethod="partdep") source("test.epilog.R") plotmo/inst/slowtests/test.mlr.R0000644000176200001440000003721514015545377016526 0ustar liggesusers# test.mlr.R: test the "mlr" package with plotmo and plotres # # TODO mlr is in maintenance mode, add mlr3 support to plotmo? # TODO generally, plotres residuals for WrappedModel prob models aren't right source("test.prolog.R") library(mlr) library(plotmo) library(rpart.plot) library(earth) # TODO following function is temporary until mlr package is updated train.with.call <- function(learner, task, subset=NULL, weights=NULL) { retval <- train(learner, task, subset, weights) retval$call <- match.call() retval } cat("==simple one variable regression model with earth ===============================\n") data(trees) trees1 <- trees[,c("Volume", "Girth")] task <- makeRegrTask(data=trees1, target="Volume") lrn <- makeLearner("regr.earth", degree=2) regr.earth.with.call = train.with.call(lrn, task) regr.earth = train(lrn, task) earth <- earth(Volume~., data=trees1, degree=2) # SHOWCALL is just a testing thing, so we can see who created the plot on the plot itself plotres(regr.earth.with.call, SHOWCALL=TRUE) plotres(regr.earth$learner.model, SHOWCALL=TRUE) plotres(earth, SHOWCALL=TRUE) plotmo(regr.earth.with.call, trace=1, SHOWCALL=TRUE) plotmo(regr.earth$learner.model, trace=1, SHOWCALL=TRUE) plotmo(earth, trace=1, SHOWCALL=TRUE) # compare partial dependence plots from mlr and plotmo packages set.seed(2018) plotmo(earth, pmethod="partdep", SHOWCALL=TRUE, col=2, pt.col="darkgray", grid.col="lightgray") set.seed(2018) pd <- generatePartialDependenceData(regr.earth, task, "Girth", n=c(50, NA)) print(plotPartialDependence(pd, data = getTaskData(task))) cat("==test error handling if original data is messed up===========================\n") par(mfrow=c(4,2), mar=c(1.5,2.5,4,1), oma=c(0,0,0,0)) colnames(trees1) <- c("nonesuch", "Volume") plotmo(regr.earth$learner.model, do.par=0, degree1=1, degree2=0, main='colnames(trees1) <- c("nonesuch", "Volume")') plotmo(regr.earth.with.call, do.par=0, degree1=1, degree2=0) par(org.par) expect.err(try(plotmo(earth, degree1=1, degree2=0)), "cannot get the original model predictors") cat("==regression model with randomForest (binary response)============================\n") library(randomForest) library(earth) # for etitanic data data(etitanic) set.seed(2018) # use a logical subset (since we test for numeric subset elsewhere) # use a small subset so we can see easily if subset is applied or ignored in plots train.subset <- rnorm(nrow(etitanic)) > 1 # 166 cases ((16% of 1046 cases)) printf("sum(train.subset) %g (%.0f%% of %g cases)\n", sum(train.subset), 100 * sum(train.subset) / nrow(etitanic), nrow(etitanic)) task.regr.rf <- makeRegrTask(data=etitanic, target="survived") lrn.regr.rf = makeLearner("regr.randomForest") set.seed(2018) regr.rf.with.call = train.with.call(lrn.regr.rf, task.regr.rf, subset=train.subset) set.seed(2018) rf <- randomForest(survived~., data=etitanic, subset=train.subset) # sanity check that the models are identical stopifnot(identical(predict(regr.rf.with.call$learner.model), predict(rf))) plotres(regr.rf.with.call, info=TRUE, SHOWCALL=TRUE) # plotres(regr.rf$learner.model, info=TRUE, SHOWCALL=TRUE) # Error: no formula in getCall(object) plotres(rf, info=TRUE, SHOWCALL=TRUE) set.seed(2018) # for repeatable jitter in points (specified with pt.col) plotmo(regr.rf.with.call, pt.col=2, SHOWCALL=TRUE) # plotmo(regr.rf$learner.model, trace=1, SHOWCALL=TRUE) # Error: no formula in getCall(object) set.seed(2018) plotmo(rf, pt.col=2, SHOWCALL=TRUE) # compare partial dependence plots set.seed(2018) plotmo(regr.rf.with.call, degree1="age", degree2=0, pmethod="partdep", grid.col="gray", col=2, pt.col="darkgray", SHOWCALL=TRUE) # function from randomForest package set.seed(2018) partialPlot(rf, pred.data=etitanic[train.subset,], x.var="age", n.pt=50, ylim=c(0, 1)) grid() # function from mlr package set.seed(2018) pd <- generatePartialDependenceData(regr.rf.with.call, task.regr.rf, "age", n=c(50, NA)) print(plotPartialDependence(pd, data = getTaskData(task.regr.rf))) plotmo(regr.rf.with.call, degree1="pclass", degree2=0, pmethod="partdep", SHOWCALL=TRUE) set.seed(2018) # function from randomForest package set.seed(2018) partialPlot(rf, pred.data=etitanic[train.subset,], x.var="pclass", n.pt=50, ylim=c(0, 1)) grid() # TODO following fails pd <- generatePartialDependenceData(regr.rf.with.call, task.regr.rf, "pclass", n=c(50, NA)) try(print(plotPartialDependence(pd, data = getTaskData(task.regr.rf)))) # Error: Discrete value supplied to continuous scale cat("==classification model with randomForest (binary response)======================\n") set.seed(2018) library(earth) # for etitanic data data(etitanic) etit <- etitanic etit$survived <- factor(etit$survived, labels=c("notsurvived", "survived")) task.classif.rf <- makeClassifTask(data=etit, target="survived") lrn.classif.rf <- makeLearner("classif.randomForest", predict.type="prob") set.seed(2018) classif.rf.with.call <- train.with.call(lrn.classif.rf, task.classif.rf, , subset=train.subset) set.seed(2018) rf <- randomForest(survived~., data=etit, method="class", subset=train.subset) # sanity check that the models are identical stopifnot(identical(predict(classif.rf.with.call$learner.model), predict(rf))) # TODO following causes Error: classif.earth: Setting parameter glm without available description object # lrn <- makeLearner("classif.earth", degree=2, glm=list(family=binomial)) # TODO residuals on WrappedModel don't match direct call to rf model set.seed(2018) # for repeatable jitter plotres(classif.rf.with.call, nresponse="prob.survived", SHOWCALL=TRUE, jitter=2) set.seed(2018) plotres(classif.rf.with.call$learner.model, type="prob", SHOWCALL=TRUE, jitter=2) set.seed(2018) plotres(rf, type="prob", SHOWCALL=TRUE, jitter=2) options(warn=2) # treat warnings as errors expect.err(try(plotmo(classif.rf.with.call)), "Defaulting to nresponse=1, see above messages") options(warn=1) set.seed(2018) # for repeatable jitter plotmo(classif.rf.with.call, SHOWCALL=TRUE, nresponse="prob.survived", pt.col=2, trace=2) set.seed(2018) plotmo(classif.rf.with.call$learner.model, SHOWCALL=TRUE, type="prob", pt.col=2) set.seed(2018) # note that in the following, get.y.shift.scale (in plotmo code) rescales the plotted y to 0..1 plotmo(rf, SHOWCALL=TRUE, type="prob", pt.col="gray") set.seed(2018) # in following graph, note that get.y.shift.scale doesn't rescale the plotted y because ylim=c(0,2) plotmo(rf, SHOWCALL=TRUE, type="prob", ylim=c(0,2), pt.col="gray") # compare partial dependence plots set.seed(2018) plotmo(rf, type="prob", degree1="pclass", degree2=0, pmethod="partdep", pt.col=2, SHOWCALL=TRUE) set.seed(2018) plotmo(rf, degree1="pclass", degree2=0, pmethod="partdep", pt.col=2, SHOWCALL=TRUE) set.seed(2018) # TODO following fails pd <- generatePartialDependenceData(classif.rf.with.call, task.classif.rf, "pclass", n=c(50, NA)) try(print(plotPartialDependence(pd, data = getTaskData(task.classif.rf)))) # Error: Discrete value supplied to continuous scale plotmo(rf, type="prob", nresponse="notsurvived", degree1="age", degree2=0, pmethod="partdep", ylim=c(.3,.75), nrug=TRUE, grid.col="gray") # looks plausible set.seed(2018) pd <- generatePartialDependenceData(classif.rf.with.call, task.classif.rf, "age", n=c(50, NA)) print(plotPartialDependence(pd, data = getTaskData(task.classif.rf))) cat("==examples from plotmo-notes.pdf ===============================================\n") #-- Regression model with mlr ------------------------------------------- library(mlr) library(plotmo) lrn <- makeLearner("regr.svm") fit1.with.call <- train.with.call(lrn, bh.task) fit1 <- train(lrn, bh.task) # generate partial dependence plots for all variables # we use "apartdep" and not "partdep" to save testing time plotmo(fit1.with.call, pmethod="apartdep") plotmo(fit1$learner.model, pmethod="apartdep") # generate partial dependence plot for just "lstat" set.seed(2018) # so slight jitter on pt.col points in plotmo doesn't change across test runs plotmo(fit1.with.call, degree1="lstat", # what predictor to plot degree2=0, # no interaction plots pmethod="partdep", # generate partial dependence plot pt.col=2, grid.col="gray", # optional bells and whistles nrug=TRUE) # rug ticks along the bottom set.seed(2018) # so slight jitter on pt.col points in plotmo doesn't change across test runs plotmo(fit1$learner.model, degree1="lstat", # what predictor to plot degree2=0, # no interaction plots pmethod="partdep", # generate partial dependence plot pt.col=2, grid.col="gray", # optional bells and whistles nrug=TRUE) # rug ticks along the bottom # compare to the function provided by the mlr package set.seed(2018) pd <- generatePartialDependenceData(fit1, bh.task, "lstat", n=c(50, NA)) print(plotPartialDependence(pd, data = getTaskData(bh.task))) # # TODO following fails: Error: Discrete value supplied to continuous scale # pd <- generatePartialDependenceData(fit1, bh.task, "chas", n=c(50, NA)) # plotPartialDependence(pd, data = getTaskData(bh.task)) #-- Classification model with mlr --------------------------------------- lrn.classif.rpart <- makeLearner("classif.rpart", predict.type = "prob", minsplit = 10) fit2.with.call <- train.with.call(lrn.classif.rpart, iris.task) fit2 <- train(lrn.classif.rpart, iris.task) # generate partial dependence plots for all variables # TODO plotmo can plot the response for only one class at a time plotmo(fit2.with.call, nresponse="prob.virginica", # what response to plot # type="prob", # type gets passed to predict.rpart pmethod="apartdep") # generate partial dependence plot plotmo(fit2$learner.model, nresponse="virginica", # what response to plot type="prob", # type gets passed to predict.rpart pmethod="apartdep") # generate partial dependence plot # generate partial dependence plot for just "Petal.Length" plotmo(fit2.with.call, degree1="Petal.Length", # what predictor to plot degree2=0, # no interaction plots nresponse="prob.virginica", # what response to plot # type="prob", # type gets passed to predict.rpart pmethod="apartdep") # generate partial dependence plot plotmo(fit2$learner.model, degree1="Petal.Length", # what predictor to plot degree2=0, # no interaction plots nresponse="virginica", # what response to plot type="prob", # type gets passed to predict.rpart pmethod="apartdep") # generate partial dependence plot # compare to the function provided by the mlr package set.seed(2018) pd <- generatePartialDependenceData(fit2, iris.task, "Petal.Length", n=c(50, NA)) print(plotPartialDependence(pd, data = getTaskData(iris.task))) cat("==lda example from mlr documentation, and plotmo error handling =================\n") set.seed(2018) data(iris) task.lda <- makeClassifTask(data=iris, target="Species") lrn.lda <- makeLearner("classif.lda") n <- nrow(iris) train.set <- sample(n, size=2/3*n) test.set <- setdiff(1:n, train.set) classif.lda.with.call <- train.with.call(lrn.lda, task.lda, subset=train.set) classif.lda <- train(lrn.lda, task.lda, subset=train.set) iris1 <- iris[train.set, ] library(MASS) lda <- lda(Species~., data=iris1) # expect.err(try(plotres(classif.lda.with.call)), "plotres does not (yet) support type=\"class\" for \"lda\" objects") expect.err(try(plotres(classif.lda$learner.model)), "plotres does not (yet) support type=\"class\" for \"lda\" objects") options(warn=2) # treat warnings as errors # expect.err(try(plotres(classif.lda.with.call, type="response")), "predict.lda returned multiple columns (see above) but nresponse is not specified") expect.err(try(plotres(classif.lda$learner.model, type="response")), "Defaulting to nresponse=1, see above messages") options(warn=1) expect.err(try(plotres(classif.lda.with.call, type="response", nresponse="nonesuch")), "nresponse=\"nonesuch\" is not allowed") expect.err(try(plotres(classif.lda$learner.model, type="response", nresponse="nonesuch")), "nresponse=\"nonesuch\" is not allowed") expect.err(try(plotres(classif.lda.with.call, type="response", nresponse=0)), "nresponse=0 but it should be at least 1") expect.err(try(plotres(classif.lda$learner.model, type="response", nresponse=0)), "nresponse=0 but it should be at least 1") expect.err(try(plotres(classif.lda.with.call, type="response", nresponse=99)), "nresponse is 99 but the number of columns is only 1") expect.err(try(plotres(classif.lda$learner.model, type="response", nresponse=99)), "nresponse is 99 but the number of columns is only 2") expect.err(try(plotmo(classif.lda)), "getCall(classif.lda) failed") expect.err(try(plotres(classif.lda)), "getCall(classif.lda) failed") # TODO residuals don't match plotres(classif.lda.with.call, SHOWCALL=TRUE, type="response") plotres(classif.lda$learner.model, SHOWCALL=TRUE, type="response", nresponse="LD2") plotres(lda, SHOWCALL=TRUE, type="response", nresponse="LD2") plotmo(classif.lda.with.call, SHOWCALL=TRUE) plotmo(classif.lda$learner.model, SHOWCALL=TRUE) plotmo(lda, SHOWCALL=TRUE) # # TODO plotPartialDependence and plotmo graphs below don't match # pd <- generatePartialDependenceData(classif.lda, task.lda, "Petal.Width", n=c(50, NA)) # TODO generates warnings # print(plotPartialDependence(pd, data = getTaskData(task.lda))) plotmo(classif.lda.with.call, degree1="Petal.Width", degree2=0, pmethod="partdep", do.par=FALSE) plotmo(classif.lda.with.call, SHOWCALL=TRUE, all2=TRUE, type="response") plotmo(classif.lda$learner.model, SHOWCALL=TRUE, all2=TRUE, type="class") plotmo(lda, SHOWCALL=TRUE, all2=TRUE, type="class") plotmo(classif.lda$learner.model, SHOWCALL=TRUE, all2=TRUE, type="response", nresponse="LD1") plotmo(lda, SHOWCALL=TRUE, all2=TRUE, type="response", nresponse="LD1") cat("==test recursive call to plotmo_prolog for learner.model===============\n") set.seed(2018) n <- 100 data <- data.frame( x1 = rnorm(n), x2 = rnorm(n), x3 = rnorm(n), x4 = rnorm(n), x5 = rnorm(n), x6 = rnorm(n), x7 = rnorm(n), x8 = rnorm(n), x9 = rnorm(n)) data$y <- sin(data$x3) + sin(data$x4) + 2 * cos(data$x5) set.seed(2018) library(gbm) # reference model gbm = gbm(y~., data=data, n.trees=300) plotmo(gbm, trace=-1, SHOWCALL=TRUE) set.seed(2018) task <- makeRegrTask(data=data, target="y") lrn <- makeLearner("regr.gbm", n.trees=300, keep.data=TRUE) regr.gbm = train.with.call(lrn, task) plotmo(regr.gbm, trace=-1, SHOWCALL=TRUE) set.seed(2018) lrn <- makeLearner("regr.gbm", n.trees=300) regr.gbm.nokeepdata = train.with.call(lrn, task) # expect message: use keep.data=TRUE in the call to gbm (cannot determine the variable importances) plotmo(regr.gbm.nokeepdata, trace=1, SHOWCALL=TRUE) plotres(regr.gbm, SHOWCALL=TRUE) cat("==example from makeClassificationViaRegressionWrapper help page ===============\n") # this tests that plotmo.prolog can access the learner.model at object$learner.model$next.model$learner.model set.seed(2018) lrn = makeLearner("regr.rpart") lrn = makeClassificationViaRegressionWrapper(lrn) ClassificationViaRegression = train.with.call(lrn, sonar.task, subset = 1:140) plotmo(ClassificationViaRegression, SHOWCALL=TRUE) source("test.epilog.R") plotmo/inst/slowtests/test.parsnip.bat0000755000176200001440000000221414655214117017742 0ustar liggesusers@rem test.parsnip.bat @rem Stephen Milborrow Sep 2020 Petaluma @echo test.parsnip.bat @"C:\PROGRA~1\R\R-4.4.1\bin\x64\R.exe" CMD BATCH --quiet --vanilla test.parsnip.R @if %errorlevel% equ 0 goto good1 @echo R returned errorlevel %errorlevel%, see test.parsnip.Rout: @echo. @tail test.parsnip.Rout @echo test.parsnip.R @exit /B 1 :good1 @rem second egrep gets rid of random messages issued by library(tidymodels) @rem could perhaps use suppressPackageStartupMessages() instead @egrep -v "Fit time:| Use | Dig | Learn | Search |^\* " test.parsnip.Rout >test.parsnip.Rout2 mv test.parsnip.Rout2 test.parsnip.Rout mks.diff test.parsnip.Rout test.parsnip.Rout.save @if %errorlevel% equ 0 goto good2 @echo === Files are different === @diffps -s Rplots.ps ..\..\.#\test-reference\test.parsnip.save.ps @exit /B 1 :good2 @rem test.parsnip.save.ps is too big to be included in the release @rem so it is stored elsewhere diffps Rplots.ps ..\..\.#\test-reference\test.parsnip.save.ps @if %errorlevel% equ 0 goto good3 @echo === Files are different === @exit /B 1 :good3 @rm -f test.parsnip.Rout test.parsnip.Rout @rm -f Rplots.ps @exit /B 0 plotmo/inst/slowtests/test.printcall.R0000644000176200001440000000751113725307664017722 0ustar liggesusers# test.printcall.R # # TODO we don't test use of printcall in a namespace source("test.prolog.R") options(warnPartialMatchArgs=FALSE) library(plotmo) for(all in c(FALSE, TRUE)) { for(EVAL in c(FALSE, TRUE)) { printf("=== Test printcall with all=%s EVAL=%s ===\n", all, EVAL) foo30 <- function() { plotmo:::printcall(all=all) } foo30() foo32 <- function(...) { plotmo:::printcall(all=all); plotmo:::printdots(..., EVAL=EVAL) } foo32() foo32(a=31) foo34 <- function(aa=1, ...) { plotmo:::printcall(all=all); plotmo:::printdots(..., EVAL=EVAL) } foo34() foo34(a=31) # argname a will be expanded to aa foo34(a=31, x=1:10, y=NULL) foo34(a=31, y=NULL) foo34(x=stopifnot(TRUE), y=NULL) foo36 <- function(aa=NULL, ...) { plotmo:::printcall(all=all); plotmo:::printdots(..., EVAL=EVAL) } foo36() foo36(a=NULL) foo36(a=1) foo36(a=1:3) foo36(a=1:3, x=NULL) # check formatting of various argument types # note that we correctly don't call stopifnot(FALSE) (which would call stop) foo38 <- function(aa=1:3, bb=4:6, cc=print.default, dd=stopifnot(FALSE), ee=function(m=1) cat(m), ff=7, ...) { plotmo:::printcall(all=all); plotmo:::printdots(..., EVAL=EVAL) } foo38(x=matrix(ncol=1, nrow=3)) list1 <- list(aa=1:3, bb=4:6, cc=print.default, dd=stopifnot(TRUE), ee=function(m=1) cat(m), ff=7) cat("list1 ", plotmo:::list.as.char(list1), "\n", sep="") list2 <- list(lmmod=lm(Volume~Girth, data=trees), boolean=c(TRUE, FALSE, TRUE, TRUE, FALSE, TRUE), env=parent.frame(), chars=c("a", "b", "c", "a", "b", "c"), trees=trees, l=list(x=1, y="2", z=foo38)) cat("list2 ", plotmo:::list.as.char(list2), "\n", sep="") # test unnamed arguments foo40 <- function(aa, ...) { plotmo:::printcall(all=all); plotmo:::printdots(..., EVAL=EVAL) } foo40() foo40(aa=b, c) foo40(b, c) # test printcall when called in an S3 method foo.s3 <- function(a=NULL, ...) { UseMethod("foo.s3") } foo.s3.list <- function(a=NULL, ...) { cat("in foo.s3.list: "); plotmo:::printcall(all=all) plotmo:::printdots(..., EVAL=EVAL) } foo.s3.default <- function(a=NULL, ...) { cat("in foo.s3.default: "); plotmo:::printcall(all=all) plotmo:::printdots(..., EVAL=EVAL) } foo.s3(a=list(m=1, n=2)) foo.s3(a=NULL) foo.s3(a=list(m=1, n=2, o=3, p=4, q=5, r=6, s=7, t=8, u=9), b=30) # test formatting with long argument list foo46 <- function(mmmmmmmmmmm=1000, nnnnnnnnnnn=2000, ooooooooooo=3000, ppppppppppp=4000, qqqqqqqqqqq=5000, rrrrrrrrrrr=6000, sssssssssss=7000, ttttttttttt=8000, uuuuuuuuuuu=9000, vvvvvvvvvvv=1000, wwwwwwwwwww=2000, xxxxxxxxxxx=3000, ...) { plotmo:::printcall(all=all); plotmo:::printdots(..., EVAL=EVAL) } foo46(a=30) # test call.as.char foo47 <- function(aa=1, ...) { s <- plotmo:::call.as.char(all=all); cat(s, "\n", sep="") } foo47(b=30) # create a variable named foo48 in foo48 foo48 <- function(aa=1, ...) { foo48 <- 99; s <- plotmo:::call.as.char(all=all); cat(s, "\n", sep="") } foo48(b=30) # Note that the following doesn't do what you might expect. # The calling function is print(), not foo50() as you may expecty. foo50 <- function(...) { print(plotmo:::call.as.char(all=all)) } foo50(a=1) } } source("test.epilog.R") plotmo/inst/slowtests/test.dots.bat0000755000176200001440000000143514655214117017243 0ustar liggesusers@rem test.dots.R: test handling of dots arguments @echo test.dots.bat @"C:\PROGRA~1\R\R-4.4.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.c50.R0000644000176200001440000000412613725307662016316 0ustar liggesusers# test.c50.R: c50 tests for plotmo and plotres source("test.prolog.R") library(C50) library(rpart.plot) # for ptitanic, want data with NAs for testing library(plotmo) library(earth) # for etitanic data(etitanic) get.tit <- function() # abbreviated titanic data { tit <- etitanic pclass <- as.character(tit$pclass) # change the order of the factors so not alphabetical pclass[pclass == "1st"] <- "first" pclass[pclass == "2nd"] <- "class2" pclass[pclass == "3rd"] <- "classthird" tit$pclass <- factor(pclass, levels=c("class2", "classthird", "first")) # log age is so we have a continuous predictor even when model is age~. set.seed(2015) tit$logage <- log(tit$age) + rnorm(nrow(tit)) tit$parch <- NULL # by=12 gives us a small fast model with an additive and a interaction term tit <- tit[seq(1, nrow(etitanic), by=12), ] } tit <- get.tit() c50.tree.xy <- C5.0(x=tit[,-1], y=tit[,1]) # predict pclass plotmo(c50.tree.xy, type="prob", nresponse="first", pmethod="apartdep") plotmo(c50.tree.xy, type="class") # TODO following gives error: type should be either 'class', 'confidence' or 'prob' # try(plotmo(c50.tree.xy, type="confidence")) plotres(c50.tree.xy, type="prob", nresponse="first") c50.tree.form <- C5.0(pclass~., data=tit) # predict pclass plotmo(c50.tree.form, type="prob", nresponse="first") plotmo(c50.tree.form, type="class") # TODO following gives error: type should be either 'class', 'confidence' or 'prob' # try(plotmo(c50.tree.form, type="confidence")) plotres(c50.tree.form, type="prob", nresponse="first") tit$survived <- factor(ifelse(tit$survived == 1, "yes", "no"), levels = c("yes", "no")) c50.tree.survived <- C5.0(survived~., data=tit, trials=5) # predict survived plotmo(c50.tree.survived, type="prob", nresponse="yes") plotmo(c50.tree.survived, type="class") # TODO following gives error: type should be either 'class', 'confidence' or 'prob' # try(plotmo(c50.tree.survived, type="confidence")) plotres(c50.tree.survived, type="prob", nresponse="yes") source("test.epilog.R") plotmo/inst/slowtests/test.plotmo.Rout.save0000644000176200001440000034530014655214544020727 0ustar liggesusers> # test.plotmo.R: regression tests for plotmo > # Stephen Milborrow, Petaluma Jan 2007 > > print(R.version.string) [1] "R version 4.4.1 (2024-06-14 ucrt)" > > source("test.prolog.R") > library(earth) Loading required package: Formula Loading required package: plotmo Loading required package: plotrix > options(warn=1) # print warnings as they occur > data(etitanic) > make.space.for.caption <- function(caption="CAPTION") + { + oma <- par("oma") + needed <- 3 + # adjust for newlines in caption + newlines <- grep("\n", caption) + if(length(newlines) > 0) + needed <- needed + .5 * newlines # .5 seems enough although 1 in theory + if(!is.null(caption) && any(nchar(caption)) && oma[3] <= needed) { + oma[3] <- needed + par(oma=oma) + } + } > dopar <- function(nrows, ncols, caption = "") + { + cat(" ", caption, "\n") + make.space.for.caption(caption) + par(mfrow=c(nrows, ncols)) + par(mar = c(3, 3, 1.7, 0.5)) + par(mgp = c(1.6, 0.6, 0)) + par(cex = 0.7) + } > example(plotmo) plotmo> if (require(rpart)) { plotmo+ data(kyphosis) plotmo+ rpart.model <- rpart(Kyphosis~., data=kyphosis) plotmo+ # pass type="prob" to plotmo's internal calls to predict.rpart, and plotmo+ # select the column named "present" from the matrix returned by predict.rpart plotmo+ plotmo(rpart.model, type="prob", nresponse="present") plotmo+ } Loading required package: rpart plotmo grid: Age Number Start 87 4 13 plotmo> if (require(earth)) { plotmo+ data(ozone1) plotmo+ earth.model <- earth(O3 ~ ., data=ozone1, degree=2) plotmo+ plotmo(earth.model) plotmo+ # plotmo(earth.model, pmethod="partdep") # partial dependence plots plotmo+ } plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > caption <- "basic earth test of plotmo" > a <- earth(O3 ~ ., data=ozone1, degree=2) > plotmo(a, degree1=2, degree2=4, caption=caption, trace=-1) > > caption <- "test 5 x 5 layout" > dopar(1,1,caption) test 5 x 5 layout > a <- earth(O3 ~ ., data=ozone1, nk=51, pmethod="n", degree=2) > plotmo(a, caption=caption, trace=1) stats::predict(earth.object, NULL, type="response") stats::fitted(object=earth.object) got model response from model.frame(O3 ~ vh + wind + humidity + temp + ib..., data=call$data, na.action="na.fail") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > > caption <- "test 4 x 4 layout with ylab" > dopar(1,1,caption) test 4 x 4 layout with ylab > a <- earth(O3 ~ ., data=ozone1, nk=30, pmethod="n", degree=2) > plotmo(a, caption=caption, trace=2) plotmo trace 2: plotmo(object=a, caption=caption, trace=2) --get.model.env for object with class earth object call is earth(formula=O3~., data=ozone1, pmethod="n", degree=2, nk=30) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'a' --plotmo_x for earth object get.object.x: object$x is NULL (and it has no colnames) object call is earth(formula=O3~., data=ozone1, pmethod="n", degree=2, nk=30) get.x.from.model.frame: formula(object) is O3 ~ vh + wind + humidity + temp + ibh + dpg + ibt + vis ... naked formula is the same formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) object$data is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names O3 vh wind humidity temp ibh dpg ibt vis doy na.action(object) is "na.fail" stats::model.frame(O3 ~ vh + wind + humidity + temp + ib..., data=call$data, na.action="na.fail") x=model.frame[,-1] is usable and has column names vh wind humidity temp ibh dpg ibt vis doy plotmo_x returned[330,9]: vh wind humidity temp ibh dpg ibt vis doy 1 5710 4 28 40 2693 -25 87 250 33 2 5700 3 37 45 590 -24 128 100 34 3 5760 3 51 54 1450 25 139 60 35 ... 5720 4 69 35 1568 15 121 60 36 330 5550 4 85 39 5000 8 44 100 390 ----Metadata: plotmo_predict with nresponse=NULL and newdata=NULL calling predict.earth with NULL newdata stats::predict(earth.object, NULL, type="response") predict returned[330,1]: O3 1 1.240608 2 3.596894 3 7.464276 ... 5.282731 330 3.228830 predict after processing with nresponse=NULL is [330,1]: O3 1 1.240608 2 3.596894 3 7.464276 ... 5.282731 330 3.228830 ----Metadata: plotmo_fitted with nresponse=NULL stats::fitted(object=earth.object) fitted(object) returned[330,1]: O3 1 1.240608 2 3.596894 3 7.464276 ... 5.282731 330 3.228830 fitted(object) after processing with nresponse=NULL is [330,1]: O3 1 1.240608 2 3.596894 3 7.464276 ... 5.282731 330 3.228830 ----Metadata: plotmo_y with nresponse=NULL --plotmo_y with nresponse=NULL for earth object get.object.y: object$y is NULL (and it has no colnames) object call is earth(formula=O3~., data=ozone1, pmethod="n", degree=2, nk=30) get.y.from.model.frame: formula(object) is O3 ~ vh + wind + humidity + temp + ibh + dpg + ibt + vis ... formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) object$data is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names O3 vh wind humidity temp ibh dpg ibt vis doy na.action(object) is "na.fail" stats::model.frame(O3 ~ vh + wind + humidity + temp + ib..., data=call$data, na.action="na.fail") y=model.frame[,1] is usable and has column name O3 plotmo_y returned[330,1]: O3 1 3 2 5 3 5 ... 6 330 1 plotmo_y after processing with nresponse=NULL is [330,1]: O3 1 3 2 5 3 5 ... 6 330 1 converted nresponse=NA to nresponse=1 nresponse=1 (was NA) ncol(fitted) 1 ncol(predict) 1 ncol(y) 1 ----Metadata: plotmo_y with nresponse=1 --plotmo_y with nresponse=1 for earth object get.object.y: object$y is NULL (and it has no colnames) object call is earth(formula=O3~., data=ozone1, pmethod="n", degree=2, nk=30) get.y.from.model.frame: formula(object) is O3 ~ vh + wind + humidity + temp + ibh + dpg + ibt + vis ... formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) object$data is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names O3 vh wind humidity temp ibh dpg ibt vis doy na.action(object) is "na.fail" stats::model.frame(O3 ~ vh + wind + humidity + temp + ib..., data=call$data, na.action="na.fail") y=model.frame[,1] is usable and has column name O3 got model response from model.frame(O3 ~ vh + wind + humidity + temp + ib..., data=call$data, na.action="na.fail") plotmo_y returned[330,1]: O3 1 3 2 5 3 5 ... 6 330 1 plotmo_y after processing with nresponse=1 is [330,1]: O3 1 3 2 5 3 5 ... 6 330 1 got response name "O3" from yhat resp.levs is NULL ----Metadata: done number of x values: vh 53 wind 11 humidity 65 temp 63 ibh 196 dpg 128 ibt 193... ----plotmo_singles for earth object singles: 4 temp, 5 ibh, 7 ibt, 8 vis, 9 doy ----plotmo_pairs for earth object pairs: [,1] [,2] [1,] "1 vh" "4 temp" [2,] "1 vh" "9 doy" [3,] "2 wind" "8 vis" [4,] "3 humidity" "4 temp" [5,] "4 temp" "5 ibh" [6,] "4 temp" "6 dpg" [7,] "4 temp" "9 doy" [8,] "5 ibh" "6 dpg" [9,] "7 ibt" "8 vis" graphics::par(mfrow=c(4,4), mgp=c(1.5,0.4,0), tcl=-0.3, font.main=2, mar=c(3,2,1.2,0.8), oma=c(0,0,3,0), cex.main=1.1, cex.lab=1, cex.axis=1, cex=0.66) ----Figuring out ylim --get.ylim.by.dummy.plots --plot.degree1(draw.plot=FALSE) degree1 plot1 (pmethod "plotmo") variable temp newdata[50,9]: vh wind humidity temp ibh dpg ibt vis doy 1 5760 5 64 25.00000 2112.5 24 167.5 120 205.5 2 5760 5 64 26.38776 2112.5 24 167.5 120 205.5 3 5760 5 64 27.77551 2112.5 24 167.5 120 205.5 ... 5760 5 64 29.16327 2112.5 24 167.5 120 205.5 50 5760 5 64 93.00000 2112.5 24 167.5 120 205.5 stats::predict(earth.object, data.frame[50,9], type="response") predict returned[50,1]: O3 1 8.724965 2 8.813294 3 8.901624 ... 8.989953 50 18.716007 predict after processing with nresponse=1 is [50,1]: O3 1 8.724965 2 8.813294 3 8.901624 ... 8.989953 50 18.716007 Reducing trace level for subsequent degree1 plots degree1 plot2 (pmethod "plotmo") variable ibh degree1 plot3 (pmethod "plotmo") variable ibt degree1 plot4 (pmethod "plotmo") variable vis degree1 plot5 (pmethod "plotmo") variable doy --plot.degree2(draw.plot=FALSE) degree2 plot1 (pmethod "plotmo") variables vh:temp newdata[400,9]: vh wind humidity temp ibh dpg ibt vis doy 1 5320.000 5 64 25 2112.5 24 167.5 120 205.5 2 5353.158 5 64 25 2112.5 24 167.5 120 205.5 3 5386.316 5 64 25 2112.5 24 167.5 120 205.5 ... 5419.474 5 64 25 2112.5 24 167.5 120 205.5 400 5950.000 5 64 93 2112.5 24 167.5 120 205.5 stats::predict(earth.object, data.frame[400,9], type="response") predict returned[400,1]: O3 1 10.41649 2 10.28902 3 10.16155 ... 10.03408 400 27.17075 predict after processing with nresponse=1 is [400,1]: O3 1 10.41649 2 10.28902 3 10.16155 ... 10.03408 400 27.17075 Reducing trace level for subsequent degree2 plots degree2 plot2 (pmethod "plotmo") variables vh:doy degree2 plot3 (pmethod "plotmo") variables wind:vis degree2 plot4 (pmethod "plotmo") variables humidity:temp degree2 plot5 (pmethod "plotmo") variables temp:ibh degree2 plot6 (pmethod "plotmo") variables temp:dpg degree2 plot7 (pmethod "plotmo") variables temp:doy degree2 plot8 (pmethod "plotmo") variables ibh:dpg degree2 plot9 (pmethod "plotmo") variables ibt:vis --done get.ylim.by.dummy.plots ylim c(-33.06, 31.48) clip TRUE --plot.degree1(draw.plot=TRUE) plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 graphics::plot.default(x=c(25,26.39,27.7...), y=c(8.725,8.813,8...), type="n", main="1 temp", xlab="", ylab="", xaxt="s", yaxt="s", xlim=c(25,93), ylim=c(-33.06,31.48)) --plot.degree2(draw.plot=TRUE) persp(vh:temp) theta -35 persp(vh:doy) theta -35 persp(wind:vis) theta 145 persp(humidity:temp) theta -35 persp(temp:ibh) theta 235 persp(temp:dpg) theta 235 persp(temp:doy) theta 235 persp(ibh:dpg) theta 235 persp(ibt:vis) theta 235 > > caption <- "test 3 x 3 layout" > dopar(1,1,caption) test 3 x 3 layout > a <- earth(O3 ~ ., data=ozone1, nk=16, pmethod="n", degree=2) > plotmo(a, caption=caption, trace=3) plotmo trace 3: plotmo(object=a, caption=caption, trace=3) --get.model.env for object with class earth object call is earth(formula=O3~., data=ozone1, pmethod="n", degree=2, nk=16) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'a' --plotmo_x for earth object get.object.x: object$x is NULL (and it has no colnames) object call is earth(formula=O3~., data=ozone1, pmethod="n", degree=2, nk=16) get.x.from.model.frame: formula(object) is O3 ~ vh + wind + humidity + temp + ibh + dpg + ibt + vis ... naked formula is the same formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) object$data is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names O3 vh wind humidity temp ibh dpg ibt vis doy na.action(object) is "na.fail" model.env is R_GlobalEnv data[330,10]: O3 vh wind humidity temp ibh dpg ibt vis doy 1 3 5710 4 28 40 2693 -25 87 250 33 2 5 5700 3 37 45 590 -24 128 100 34 3 5 5760 3 51 54 1450 25 139 60 35 ... 6 5720 4 69 35 1568 15 121 60 36 330 1 5550 4 85 39 5000 8 44 100 390 stats::model.frame(O3 ~ vh + wind + humidity + temp + ib..., data=call$data, na.action="na.fail") model.frame returned[330,10]: O3 vh wind humidity temp ibh dpg ibt vis doy 1 3 5710 4 28 40 2693 -25 87 250 33 2 5 5700 3 37 45 590 -24 128 100 34 3 5 5760 3 51 54 1450 25 139 60 35 ... 6 5720 4 69 35 1568 15 121 60 36 330 1 5550 4 85 39 5000 8 44 100 390 x=model.frame[,-1] is usable and has column names vh wind humidity temp ibh dpg ibt vis doy plotmo_x returned[330,9]: vh wind humidity temp ibh dpg ibt vis doy 1 5710 4 28 40 2693 -25 87 250 33 2 5700 3 37 45 590 -24 128 100 34 3 5760 3 51 54 1450 25 139 60 35 ... 5720 4 69 35 1568 15 121 60 36 330 5550 4 85 39 5000 8 44 100 390 ----Metadata: plotmo_predict with nresponse=NULL and newdata=NULL calling predict.earth with NULL newdata stats::predict(earth.object, NULL, type="response") predict returned[330,1]: O3 1 1.255037 2 4.164931 3 7.585888 ... 4.443360 330 1.685101 predict after processing with nresponse=NULL is [330,1]: O3 1 1.255037 2 4.164931 3 7.585888 ... 4.443360 330 1.685101 ----Metadata: plotmo_fitted with nresponse=NULL stats::fitted(object=earth.object) fitted(object) returned[330,1]: O3 1 1.255037 2 4.164931 3 7.585888 ... 4.443360 330 1.685101 fitted(object) after processing with nresponse=NULL is [330,1]: O3 1 1.255037 2 4.164931 3 7.585888 ... 4.443360 330 1.685101 ----Metadata: plotmo_y with nresponse=NULL --plotmo_y with nresponse=NULL for earth object get.object.y: object$y is NULL (and it has no colnames) object call is earth(formula=O3~., data=ozone1, pmethod="n", degree=2, nk=16) get.y.from.model.frame: formula(object) is O3 ~ vh + wind + humidity + temp + ibh + dpg + ibt + vis ... formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) object$data is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names O3 vh wind humidity temp ibh dpg ibt vis doy na.action(object) is "na.fail" model.env is R_GlobalEnv data[330,10]: O3 vh wind humidity temp ibh dpg ibt vis doy 1 3 5710 4 28 40 2693 -25 87 250 33 2 5 5700 3 37 45 590 -24 128 100 34 3 5 5760 3 51 54 1450 25 139 60 35 ... 6 5720 4 69 35 1568 15 121 60 36 330 1 5550 4 85 39 5000 8 44 100 390 stats::model.frame(O3 ~ vh + wind + humidity + temp + ib..., data=call$data, na.action="na.fail") model.frame returned[330,10]: O3 vh wind humidity temp ibh dpg ibt vis doy 1 3 5710 4 28 40 2693 -25 87 250 33 2 5 5700 3 37 45 590 -24 128 100 34 3 5 5760 3 51 54 1450 25 139 60 35 ... 6 5720 4 69 35 1568 15 121 60 36 330 1 5550 4 85 39 5000 8 44 100 390 y=model.frame[,1] is usable and has column name O3 plotmo_y returned[330,1]: O3 1 3 2 5 3 5 ... 6 330 1 plotmo_y after processing with nresponse=NULL is [330,1]: O3 1 3 2 5 3 5 ... 6 330 1 converted nresponse=NA to nresponse=1 nresponse=1 (was NA) ncol(fitted) 1 ncol(predict) 1 ncol(y) 1 ----Metadata: plotmo_y with nresponse=1 --plotmo_y with nresponse=1 for earth object get.object.y: object$y is NULL (and it has no colnames) object call is earth(formula=O3~., data=ozone1, pmethod="n", degree=2, nk=16) get.y.from.model.frame: formula(object) is O3 ~ vh + wind + humidity + temp + ibh + dpg + ibt + vis ... formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) object$data is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names O3 vh wind humidity temp ibh dpg ibt vis doy na.action(object) is "na.fail" model.env is R_GlobalEnv data[330,10]: O3 vh wind humidity temp ibh dpg ibt vis doy 1 3 5710 4 28 40 2693 -25 87 250 33 2 5 5700 3 37 45 590 -24 128 100 34 3 5 5760 3 51 54 1450 25 139 60 35 ... 6 5720 4 69 35 1568 15 121 60 36 330 1 5550 4 85 39 5000 8 44 100 390 stats::model.frame(O3 ~ vh + wind + humidity + temp + ib..., data=call$data, na.action="na.fail") model.frame returned[330,10]: O3 vh wind humidity temp ibh dpg ibt vis doy 1 3 5710 4 28 40 2693 -25 87 250 33 2 5 5700 3 37 45 590 -24 128 100 34 3 5 5760 3 51 54 1450 25 139 60 35 ... 6 5720 4 69 35 1568 15 121 60 36 330 1 5550 4 85 39 5000 8 44 100 390 y=model.frame[,1] is usable and has column name O3 got model response from model.frame(O3 ~ vh + wind + humidity + temp + ib..., data=call$data, na.action="na.fail") plotmo_y returned[330,1]: O3 1 3 2 5 3 5 ... 6 330 1 plotmo_y after processing with nresponse=1 is [330,1]: O3 1 3 2 5 3 5 ... 6 330 1 got response name "O3" from yhat resp.levs is NULL ----Metadata: done number of x values: vh 53 wind 11 humidity 65 temp 63 ibh 196 dpg 128 ibt 193... ----plotmo_singles for earth object singles: 4 temp, 5 ibh, 8 vis, 9 doy ----plotmo_pairs for earth object pairs: [,1] [,2] [1,] "2 wind" "8 vis" [2,] "3 humidity" "4 temp" [3,] "4 temp" "6 dpg" do.par invoked call.dots TRACE do.par called call.dots(par, DROP="*", KEEP="PREFIX,PAR.ARGS", TRACE=if(trace>=2)trace-1e...), SCALAR=TRUE, def.mfrow=c(nrows,nrows), def.mgp=mgp, def.tcl=-0.3, def.font.main=def.font.main, def.mar=mar, def.oma=def.oma, def.cex.main=def.cex.main, def.cex.lab=cex.lab, def.cex.axis=cex.lab, force.cex=cex) PREFIX par. DROP .* KEEP >STANDARDPREFIXES|^force\.|^def\.|^drop\. >PREFIX|^par\. >CALLARGS|^def\.mfrow$|^def\.mgp$|^def\.tcl$|^def\.font\.main$|^def\.mar$|^def\.oma$|^def\.cex\.main$|^def\.cex\.lab$|^def\.cex\.axis$|^force\.cex$ >EXPLICIT >PAR_ARGS|^adj$|^ann$|^ask$|^bg$|^bty$|^cex$|^cex\.axis$|^cex\.lab$|^cex\.main$|^cex\.sub$|^col\.axis$|^col\.lab$|^col\.main$|^col\.sub$|^crt$|^err$|^family$|^fg$|^fig$|^fin$|^font$|^font\.axis$|^font\.lab$|^font\.main$|^font\.sub$|^lab$|^las$|^lend$|^lheight$|^ljoin$|^lmitre$|^lty$|^mai$|^mar$|^mex$|^mfcol$|^mfg$|^mfrow$|^mgp$|^mkh$|^new$|^oma$|^omd$|^omi$|^pch$|^pin$|^plt$|^ps$|^pty$|^srt$|^tck$|^tcl$|^usr$|^xaxp$|^xaxs$|^xaxt$|^xlog$|^xpd$|^yaxp$|^yaxs$|^yaxt$|^ylbias$|^ylog$ input dotnames def.mfrow def.mgp def.tcl def.font.main def.mar def.oma def.cex.main def.cex.lab def.cex.axis force.cex after DROP and KEEP def.mfrow def.mgp def.tcl def.font.main def.mar def.oma def.cex.main def.cex.lab def.cex.axis force.cex return dotnames mfrow mgp tcl font.main mar oma cex.main cex.lab cex.axis cex graphics::par(mfrow=c(3,3), mgp=c(1.5,0.4,0), tcl=-0.3, font.main=2, mar=c(3,2,1.2,0.8), oma=c(0,0,3,0), cex.main=1.2, cex.lab=1, cex.axis=1, cex=0.66) ----Figuring out ylim --get.ylim.by.dummy.plots --plot.degree1(draw.plot=FALSE) degree1 plot1 (pmethod "plotmo") variable temp newdata[50,9]: vh wind humidity temp ibh dpg ibt vis doy 1 5760 5 64 25.00000 2112.5 24 167.5 120 205.5 2 5760 5 64 26.38776 2112.5 24 167.5 120 205.5 3 5760 5 64 27.77551 2112.5 24 167.5 120 205.5 ... 5760 5 64 29.16327 2112.5 24 167.5 120 205.5 50 5760 5 64 93.00000 2112.5 24 167.5 120 205.5 stats::predict(earth.object, data.frame[50,9], type="response") predict returned[50,1]: O3 1 5.311674 2 5.527233 3 5.742791 ... 5.958350 50 29.012915 predict after processing with nresponse=1 is [50,1]: O3 1 5.311674 2 5.527233 3 5.742791 ... 5.958350 50 29.012915 degree1 plot2 (pmethod "plotmo") variable ibh newdata[50,9]: vh wind humidity temp ibh dpg ibt vis doy 1 5760 5 64 62 111.0000 24 167.5 120 205.5 2 5760 5 64 62 210.7755 24 167.5 120 205.5 3 5760 5 64 62 310.5510 24 167.5 120 205.5 ... 5760 5 64 62 410.3265 24 167.5 120 205.5 50 5760 5 64 62 5000.0000 24 167.5 120 205.5 stats::predict(earth.object, data.frame[50,9], type="response") predict returned[50,1]: O3 1 10.870828 2 11.135522 3 11.400215 ... 11.664908 50 9.845279 predict after processing with nresponse=1 is [50,1]: O3 1 10.870828 2 11.135522 3 11.400215 ... 11.664908 50 9.845279 degree1 plot3 (pmethod "plotmo") variable vis newdata[50,9]: vh wind humidity temp ibh dpg ibt vis doy 1 5760 5 64 62 2112.5 24 167.5 0.000000 205.5 2 5760 5 64 62 2112.5 24 167.5 7.142857 205.5 3 5760 5 64 62 2112.5 24 167.5 14.285714 205.5 ... 5760 5 64 62 2112.5 24 167.5 21.428571 205.5 50 5760 5 64 62 2112.5 24 167.5 350.000000 205.5 stats::predict(earth.object, data.frame[50,9], type="response") predict returned[50,1]: O3 1 14.86257 2 14.72553 3 14.58850 ... 14.45147 50 11.88484 predict after processing with nresponse=1 is [50,1]: O3 1 14.86257 2 14.72553 3 14.58850 ... 14.45147 50 11.88484 degree1 plot4 (pmethod "plotmo") variable doy newdata[50,9]: vh wind humidity temp ibh dpg ibt vis doy 1 5760 5 64 62 2112.5 24 167.5 120 33.00000 2 5760 5 64 62 2112.5 24 167.5 120 40.28571 3 5760 5 64 62 2112.5 24 167.5 120 47.57143 ... 5760 5 64 62 2112.5 24 167.5 120 54.85714 50 5760 5 64 62 2112.5 24 167.5 120 390.00000 stats::predict(earth.object, data.frame[50,9], type="response") predict returned[50,1]: O3 1 7.968080 2 8.746490 3 9.524900 ... 10.303310 50 8.957033 predict after processing with nresponse=1 is [50,1]: O3 1 7.968080 2 8.746490 3 9.524900 ... 10.303310 50 8.957033 --plot.degree2(draw.plot=FALSE) degree2 plot1 (pmethod "plotmo") variables wind:vis newdata[400,9]: vh wind humidity temp ibh dpg ibt vis doy 1 5760 0.0000000 64 62 2112.5 24 167.5 0 205.5 2 5760 0.5789474 64 62 2112.5 24 167.5 0 205.5 3 5760 1.1578947 64 62 2112.5 24 167.5 0 205.5 ... 5760 1.7368421 64 62 2112.5 24 167.5 0 205.5 400 5760 11.0000000 64 62 2112.5 24 167.5 350 205.5 stats::predict(earth.object, data.frame[400,9], type="response") predict returned[400,1]: O3 1 16.19942 2 16.04463 3 15.88983 ... 15.73504 400 11.88484 predict after processing with nresponse=1 is [400,1]: O3 1 16.19942 2 16.04463 3 15.88983 ... 15.73504 400 11.88484 degree2 plot2 (pmethod "plotmo") variables humidity:temp newdata[400,9]: vh wind humidity temp ibh dpg ibt vis doy 1 5760 5 19.00000 25 2112.5 24 167.5 120 205.5 2 5760 5 22.89474 25 2112.5 24 167.5 120 205.5 3 5760 5 26.78947 25 2112.5 24 167.5 120 205.5 ... 5760 5 30.68421 25 2112.5 24 167.5 120 205.5 400 5760 5 93.00000 93 2112.5 24 167.5 120 205.5 stats::predict(earth.object, data.frame[400,9], type="response") predict returned[400,1]: O3 1 5.311674 2 5.311674 3 5.311674 ... 5.311674 400 32.296021 predict after processing with nresponse=1 is [400,1]: O3 1 5.311674 2 5.311674 3 5.311674 ... 5.311674 400 32.296021 degree2 plot3 (pmethod "plotmo") variables temp:dpg newdata[400,9]: vh wind humidity temp ibh dpg ibt vis doy 1 5760 5 64 25.00000 2112.5 -69 167.5 120 205.5 2 5760 5 64 28.57895 2112.5 -69 167.5 120 205.5 3 5760 5 64 32.15789 2112.5 -69 167.5 120 205.5 ... 5760 5 64 35.73684 2112.5 -69 167.5 120 205.5 400 5760 5 64 93.00000 2112.5 107 167.5 120 205.5 stats::predict(earth.object, data.frame[400,9], type="response") predict returned[400,1]: O3 1 5.311674 2 5.867588 3 6.423503 ... 6.979417 400 -6.671880 predict after processing with nresponse=1 is [400,1]: O3 1 5.311674 2 5.867588 3 6.423503 ... 6.979417 400 -6.671880 --done get.ylim.by.dummy.plots ylim c(-6.672, 40.23) clip TRUE --plot.degree1(draw.plot=TRUE) plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 draw.degree1 invoked call.dots TRACE draw.degree1 called call.plot(plot.default, PREFIX="degree1.", TRACE=if(isingle==1&&trace...), force.x=xframe[,ipred], force.y=yhat, force.type="n", force.main=main, force.xlab=xlab, force.ylab=ylab, force.xlim=xlim, force.ylim=ylim, def.xaxt=if(xaxis.is.levs)"n"...), def.yaxt=if(yaxis.is.levs)"n"...)) PREFIX degree1. DROP .* KEEP >STANDARDPREFIXES|^force\.|^def\.|^drop\. >PREFIX|^degree1\. >CALLARGS|^force\.x$|^force\.y$|^force\.type$|^force\.main$|^force\.xlab$|^force\.ylab$|^force\.xlim$|^force\.ylim$|^def\.xaxt$|^def\.yaxt$ >EXPLICIT >PLOT_ARGS|^add$|^adj$|^bty$|^cex$|^cex\.axis$|^cex\.lab$|^cex\.main$|^cex\.sub$|^col$|^col\.axis$|^col\.lab$|^col\.main$|^col\.sub$|^crt$|^family$|^font$|^font$|^font\.axis$|^font\.lab$|^font\.main$|^font\.sub$|^lend$|^ljoin$|^lmitre$|^lty$|^lwd$|^main$|^pch$|^srt$|^xaxp$|^xaxs$|^xaxt$|^xlab$|^xlim$|^xlog$|^xpd$|^yaxp$|^yaxs$|^yaxt$|^ylab$|^ylim$|^ylog$ input dotnames force.x force.y force.type force.main force.xlab force.ylab force.xlim force.ylim def.xaxt def.yaxt after DROP and KEEP force.x force.y force.type force.main force.xlab force.ylab force.xlim force.ylim def.xaxt def.yaxt return dotnames x y type main xlab ylab xaxt yaxt xlim ylim graphics::plot.default(x=c(25,26.39,27.7...), y=c(5.312,5.527,5...), type="n", main="1 temp", xlab="", ylab="", xaxt="s", yaxt="s", xlim=c(25,93), ylim=c(-6.67,40.23)) --plot.degree2(draw.plot=TRUE) persp(wind:vis) theta 145 TRACE plot.persp called deprefix(persp, FNAME="persp", KEEP="PREFIX,PLOT.ARGS", FORMALS=persp.def.formals, TRACE=if(ipair==1&&trace>=...), force.x=x1grid, force.y=x2grid, force.z=yhat, force.xlim=range(x1grid), force.ylim=range(x2grid), force.zlim=if(is.null(ylim))yli...), force.xlab=xlab, force.ylab=ylab, force.theta=theta, force.phi=30, force.d=1, force.main=main2, def.cex.lab=cex.lab, def.cex.axis=cex.lab, def.zlab=zlab, def.ticktype="simple", def.nticks=def.nticks, def.cex=cex1, force.col="lightblue", def.border=NULL, def.shade=0.5) PREFIX persp. DROP NULL KEEP >STANDARDPREFIXES|^force\.|^def\.|^drop\. >PREFIX|^persp\. >CALLARGS|^force\.x$|^force\.y$|^force\.z$|^force\.xlim$|^force\.ylim$|^force\.zlim$|^force\.xlab$|^force\.ylab$|^force\.theta$|^force\.phi$|^force\.d$|^force\.main$|^def\.cex\.lab$|^def\.cex\.axis$|^def\.zlab$|^def\.ticktype$|^def\.nticks$|^def\.cex$|^force\.col$|^def\.border$|^def\.shade$ >EXPLICIT >PLOT_ARGS|^add$|^adj$|^bty$|^cex$|^cex\.axis$|^cex\.lab$|^cex\.main$|^cex\.sub$|^col$|^col\.axis$|^col\.lab$|^col\.main$|^col\.sub$|^crt$|^family$|^font$|^font$|^font\.axis$|^font\.lab$|^font\.main$|^font\.sub$|^lend$|^ljoin$|^lmitre$|^lty$|^lwd$|^main$|^pch$|^srt$|^xaxp$|^xaxs$|^xaxt$|^xlab$|^xlim$|^xlog$|^xpd$|^yaxp$|^yaxs$|^yaxt$|^ylab$|^ylim$|^ylog$ input dotnames force.x force.y force.z force.xlim force.ylim force.zlim force.xlab force.ylab force.theta force.phi force.d force.main def.cex.lab def.cex.axis def.zlab def.ticktype def.nticks def.cex force.col def.border def.shade after DROP and KEEP force.x force.y force.z force.xlim force.ylim force.zlim force.xlab force.ylab force.theta force.phi force.d force.main def.cex.lab def.cex.axis def.zlab def.ticktype def.nticks def.cex force.col def.shade return dotnames x y main xlab ylab cex.lab cex.axis zlab ticktype nticks cex shade z xlim ylim zlim theta phi d col persp(humidity:temp) theta -35 persp(temp:dpg) theta 235 > > caption <- "test 2 x 2 layout" > dopar(1,1,caption) test 2 x 2 layout > a <- earth(O3 ~ ., data=ozone1, nk=9, pmethod="n", degree=2) > plotmo(a, caption=caption) plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > > caption <- "test 1 x 1 layout" > dopar(1,1,caption) test 1 x 1 layout > a <- earth(O3 ~ ., data=ozone1, nk=4, pmethod="n", degree=2) > plotmo(a, caption=caption) plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > > caption <- "test plotmo basic params" > a <- earth(O3 ~ ., data=ozone1, degree=2) > dopar(3,2,caption) test plotmo basic params > plotmo(a, do.par=FALSE, degree1=1, nrug=-1, degree2=F, caption=caption, + main="test main", xlab="test xlab", ylab="test ylab") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > plotmo(a, do.par=FALSE, degree1=F, degree2=4, grid.func=mean, persp.col="white", ngrid2=10, persp.phi=40) > set.seed(2016) > plotmo(a, do.par=FALSE, degree1=1, degree1.lty=2, degree1.lwd=4, degree1.col=2, nrug=TRUE, degree2=F, main="nrug=300") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > plotmo(a, do.par=FALSE, degree1=1, nrug=-1, degree2=F, main="nrug=TRUE") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > set.seed(2016) > plotmo(a, do.par=FALSE, degree1=1, nrug=10, ngrid1=50, degree2=F, main="ngrid1=50 nrug=10") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > plotmo(a, do.par=FALSE, degree1=NA, degree2=1, persp.phi=60) # graph args > > caption <- "test plotmo xlim and ylim" > a <- earth(O3 ~ ., data=ozone1, degree=2) > dopar(5,3,caption) test plotmo xlim and ylim > plotmo(a, do.par=FALSE, degree1=2:3, degree2=4, caption=caption, xlab="ylim=default") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > plotmo(a, do.par=FALSE, degree1=2:3, degree2=4, ylim=NA, xlab="ylim=NA") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > plotmo(a, do.par=FALSE, degree1=2:3, degree2=4, ylim=c(0,20), xlab="ylim=c(0,20)") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > plotmo(a, do.par=FALSE, degree1=2:3, degree2=4, xlim=c(190,250), xlab="xlim=c(190,250)") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > plotmo(a, do.par=FALSE, degree1=2:3, degree2=4, xlim=c(190,250), ylim=c(11,18), xlab="xlim=c(190,250), ylim=c(11,18)") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > > # check various types of predictors with grid.func and ndiscrete > > varied.type.data <- data.frame( + y = 1:13, + num = c(1, 3, 2, 3, 4, 5, 6, 4, 5, 6.5, 3, 6, 5), # 7 unique values (but one is non integral) + int = c(1L, 1L, 3L, 3L, 4L, 4L, 3L, 5L, 3L, 6L, 7L, 8L, 10L), # 8 unique values + bool = c(F, F, F, F, F, T, T, T, T, T, T, T, T), + date = as.Date( + c("2018-08-01", "2018-08-02", "2018-08-03", + "2018-08-04", "2018-08-05", "2018-08-06", + "2018-08-07", "2018-08-08", "2018-08-08", + "2018-08-08", "2018-08-10", "2018-08-11", "2018-08-11")), + ord = ordered(c("ord3", "ord3", "ord3", + "ord1", "ord2", "ord3", + "ord1", "ord2", "ord3", + "ord1", "ord1", "ord1", "ord1"), + levels=c("ord1", "ord3", "ord2")), + fac = as.factor(c("fac1", "fac1", "fac1", + "fac2", "fac2", "fac2", + "fac3", "fac3", "fac3", + "fac1", "fac2", "fac3", "fac3")), + str = c("str1", "str1", "str1", # will be treated like a factor + "str2", "str2", "str2", + "str3", "str3", "str3", + "str3", "str3", "str3", "str3")) > > varied.type.lm <- lm(y ~ ., data = varied.type.data) > print(summary(varied.type.lm)) Call: lm(formula = y ~ ., data = varied.type.data) Residuals: 1 2 3 4 5 6 7 9.619e-02 1.673e-01 -2.635e-01 1.297e-02 -1.297e-02 -6.592e-17 -1.029e-01 8 9 10 11 12 13 1.297e-02 5.898e-17 -8.674e-17 5.204e-17 5.772e-02 3.220e-02 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) -7192.3724 6018.6749 -1.195 0.3546 num 0.2618 0.1919 1.364 0.3057 int 0.6437 0.2279 2.824 0.1058 boolTRUE -1.7185 0.5305 -3.240 0.0835 . date 0.4053 0.3392 1.195 0.3547 ord.L -0.2014 0.1726 -1.167 0.3637 ord.Q -1.5481 0.4045 -3.827 0.0620 . facfac2 0.4621 1.1289 0.409 0.7219 facfac3 -0.4299 0.5784 -0.743 0.5348 strstr2 1.3480 0.8570 1.573 0.2564 strstr3 5.0732 1.2534 4.048 0.0560 . --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 0.2471 on 2 degrees of freedom Multiple R-squared: 0.9993, Adjusted R-squared: 0.996 F-statistic: 297.9 on 10 and 2 DF, p-value: 0.003351 > set.seed(2018) > plotres(varied.type.lm, info=TRUE) > plotmo(varied.type.lm, pmethod="apartdep", all2=TRUE, ticktype="d", col.response="red", caption="varied.type.lm\npmethod=\"apartdep\" default grid func") calculating apartdep for num calculating apartdep for int calculating apartdep for bool calculating apartdep for date calculating apartdep for ord calculating apartdep for fac calculating apartdep for str calculating apartdep for num:int 01234567890 calculating apartdep for num:bool 01234567890 calculating apartdep for num:date 01234567890 calculating apartdep for num:ord 01234567890 calculating apartdep for num:fac 01234567890 calculating apartdep for num:str 01234567890 calculating apartdep for int:bool 01234567890 calculating apartdep for int:date 01234567890 calculating apartdep for int:ord 01234567890 calculating apartdep for int:fac 01234567890 calculating apartdep for int:str 01234567890 calculating apartdep for bool:date 0123456790 calculating apartdep for bool:ord 0123456790 calculating apartdep for bool:fac 0123456790 calculating apartdep for bool:str 0123456790 calculating apartdep for date:ord 01234567890 calculating apartdep for date:fac 01234567890 calculating apartdep for date:str 01234567890 calculating apartdep for ord:fac 01234567890 calculating apartdep for ord:str 01234567890 calculating apartdep for fac:str 01234567890 > plotmo(varied.type.lm, all2=TRUE, ticktype="d", col.response="red", caption="varied.type.lm\ndefault grid func") plotmo grid: num int bool date ord fac str 4 4 TRUE 2018-08-07 ord1 fac3 str3 > plotmo(varied.type.lm, all2=TRUE, ndiscre=1, caption="varied.type.lm\nndiscrete=1") plotmo grid: num int bool date ord fac str 4 4 TRUE 2018-08-07 ord1 fac3 str3 > plotmo(varied.type.lm, all2=TRUE, ndiscr=2, caption="varied.type.lm\nndiscrete=2") plotmo grid: num int bool date ord fac str 4 4 TRUE 2018-08-07 ord1 fac3 str3 > plotmo(varied.type.lm, all2=TRUE, ndis=100, caption="varied.type.lm\nndiscrete=100") plotmo grid: num int bool date ord fac str 4 4 TRUE 2018-08-07 ord1 fac3 str3 > cat("grid.func=median:\n") grid.func=median: > plotmo(varied.type.lm, all2=TRUE, grid.func=median, caption="varied.type.lm\ngrid.func=median") Warning: grid.func failed for ord, so will use the most common value of ord Warning: grid.func failed for fac, so will use the most common value of fac Warning: grid.func failed for str, so will use the most common value of str Warning: grid.func failed for ord, so will use the most common value of ord Warning: grid.func failed for fac, so will use the most common value of fac Warning: grid.func failed for str, so will use the most common value of str plotmo grid: num int bool date ord fac str 4 4 TRUE 2018-08-07 ord1 fac3 str3 > cat("grid.func=quantile:\n") grid.func=quantile: > plotmo(varied.type.lm, all2=TRUE, grid.func=function(x, ...) quantile(x, 0.5), caption="varied.type.lm\ngrid.func=function(x, ...) quantile(x, 0.5)") Warning: grid.func failed for date, so will use the default grid.func for date Warning: grid.func failed for ord, so will use the most common value of ord Warning: grid.func failed for fac, so will use the most common value of fac Warning: grid.func failed for str, so will use the most common value of str Warning: grid.func failed for date, so will use the default grid.func for date Warning: grid.func failed for ord, so will use the most common value of ord Warning: grid.func failed for fac, so will use the most common value of fac Warning: grid.func failed for str, so will use the most common value of str plotmo grid: num int bool date ord fac str 4 4 TRUE 2018-08-07 ord1 fac3 str3 > cat("grid.func=mean:\n") grid.func=mean: > plotmo(varied.type.lm, all2=TRUE, grid.func=mean, caption="varied.type.lm\ngrid.func=mean") Warning in mean.default(x, na.rm = TRUE) : argument is not numeric or logical: returning NA Warning: grid.func returned NA for ord, so will use the default grid.func for ord Warning in mean.default(x, na.rm = TRUE) : argument is not numeric or logical: returning NA Warning: grid.func returned NA for fac, so will use the default grid.func for fac Warning in mean.default(x, na.rm = TRUE) : argument is not numeric or logical: returning NA Warning: grid.func returned NA for str, so will use the default grid.func for str Warning in mean.default(x, na.rm = TRUE) : argument is not numeric or logical: returning NA Warning: grid.func returned NA for ord, so will use the default grid.func for ord Warning in mean.default(x, na.rm = TRUE) : argument is not numeric or logical: returning NA Warning: grid.func returned NA for fac, so will use the default grid.func for fac Warning in mean.default(x, na.rm = TRUE) : argument is not numeric or logical: returning NA Warning: grid.func returned NA for str, so will use the default grid.func for str plotmo grid: num int bool date ord fac str 4.115385 4 TRUE 2018-08-06 ord1 fac3 str3 > > varied.type.earth <- earth(y ~ ., data = varied.type.data, thresh=0, penalty=-1, trace=1) x[13,10] with colnames num int boolTRUE date ord.L ord.Q facfac2 facfac3 strstr2... y[13,1] with colname y, and values 1, 2, 3, 4, 5, 6, 7, 8, 9, 10... Forward pass term 1, 2, 4, 6, 8, 10, 12, 14, 16, 18 Reached maximum RSq 1.0000 at 19 terms, 13 terms used (RSq 1.0000) After forward pass GRSq 1.000 RSq 1.000 Prune backward penalty -1 nprune null: selected 13 of 13 terms, and 9 of 10 preds After pruning pass GRSq 1 RSq 1 > print(summary(varied.type.earth)) Call: earth(formula=y~., data=varied.type.data, trace=1, thresh=0, penalty=-1) coefficients (Intercept) 9.5964912 boolTRUE -2.0473684 ord.L 0.4986964 ord.Q 0.0859470 facfac2 -4.4157895 facfac3 -3.1526316 strstr2 3.2526316 h(4-num) 1.4105263 h(num-4) -0.3157895 h(4-int) 2.1157895 h(int-4) 0.3421053 h(17749-date) -3.8210526 h(date-17749) 1.4368421 Selected 13 of 13 terms, and 9 of 10 predictors Termination condition: Reached maximum RSq 1.0000 at 13 terms Importance: date, facfac2, facfac3, int, strstr2, boolTRUE, num, ord.L, ... Number of terms at each degree of interaction: 1 12 (additive model) GCV 0 RSS 0 GRSq 1 RSq 1 > set.seed(2018) > plotres(varied.type.earth, info=TRUE) Warning in cor(rank(x), rank(y)) : the standard deviation is zero Warning: draw.density.along.the.bottom: cannot determine density > plotmo(varied.type.earth, all1=TRUE, all2=TRUE, persp.ticktype="d", col.response="red") plotmo grid: num int bool date ord fac str 4 4 TRUE 2018-08-07 ord1 fac3 str3 > > # term.plot calls predict.earth with an se parameter, even with termplot(se=FALSE) > > caption <- "basic earth test against termplot" > dopar(4,4,caption) basic earth test against termplot > make.space.for.caption("test caption1") > a <- earth(O3 ~ ., data=ozone1, degree=2) > plotmo(a, do.par=FALSE, ylim=NA, caption=caption, degree2=FALSE) plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > cat("Ignore warning: predict.earth ignored argument \"se.fit\"\n") Ignore warning: predict.earth ignored argument "se.fit" > termplot(a) Warning: predict.earth ignored argument 'se.fit' > > caption <- "test change order of earth predictors and cex" > dopar(4,4,caption) test change order of earth predictors and cex > # minspan=1 to force two degree2 graphs for the test (wasn't necessary in old versions of earth) > a <- earth(doy ~ humidity + temp + wind, data=ozone1, degree=2, minspan=1) > plotmo(a, do.par=FALSE, ylim=NA, caption=caption, degree2=c(1,2), cex=1.2) plotmo grid: humidity temp wind 64 62 5 > termplot(a) Warning: predict.earth ignored argument 'se.fit' > > caption <- "test all1=TRUE" > a <- earth(doy ~ humidity + temp + wind, data=ozone1, degree=2) > plotmo(a, caption=caption, all1=TRUE, persp.ticktype="d", persp.nticks=2) plotmo grid: humidity temp wind 64 62 5 > caption <- "test all2=TRUE" > print(summary(a)) Call: earth(formula=doy~humidity+temp+wind, data=ozone1, degree=2) coefficients (Intercept) 150.868918 h(humidity-28) 1.614397 h(49-temp) -6.984397 h(3-wind) 50.527668 h(28-humidity) * h(temp-53) 8.123127 h(28-humidity) * h(53-temp) 1.520105 h(28-humidity) * h(temp-45) 5.390040 h(28-humidity) * h(temp-50) -12.953206 h(41-humidity) * h(wind-3) -0.996454 Selected 9 of 18 terms, and 3 of 3 predictors Termination condition: Reached nk 21 Importance: wind, temp, humidity Number of terms at each degree of interaction: 1 3 5 GCV 8954.829 RSS 2590958 GRSq 0.1805267 RSq 0.2771303 > plotmo(a, caption=caption, all2=TRUE) plotmo grid: humidity temp wind 64 62 5 > > oz <- ozone1[150:200,c("O3","temp","humidity","ibh")] > a.glob <- earth(O3~temp+humidity, data=oz, degree=2) > ad.glob <- earth(oz[,2:3], oz[,1], degree=2) > func1 <- function() + { + caption <- "test environments and finding the correct data" + dopar(4,4,caption) + set.seed(2016) + + plotmo(a.glob, do.par=FALSE, main="a.glob oz", + degree1=1, all2=1, degree2=1, type2="im", + col.response=3, pt.pch=20, trace=2) + mtext(caption, outer=TRUE, font=2, line=1.5, cex=1) + plotmo(ad.glob, do.par=FALSE, main="ad.glob oz", + degree1=1, all2=1, degree2=1, type2="im", + col.response=3, pch.response=20, trace=2) # pch.response test backcompat + + a <- earth(O3~temp+humidity, data=oz, degree=2) + plotmo(a, do.par=FALSE, main="a oz", + degree1=1, all2=1, degree2=1, type2="im", + col.response=3, pt.pch=20) + + ad <- earth(oz[,2:3], oz[,1], degree=2) + plotmo(ad, do.par=FALSE, main="ad oz", + degree1=1, all2=1, degree2=1, type2="im", + col.response=3, pt.pch=20) + + oz.org <- oz + oz10 <- 10 * oz # multiply by 10 so we can see by the axis labels if right data is being used + oz <- oz10 # oz is now local to this function, but multiplied by 10 + a.oz10 <- earth(O3~temp+humidity, data=oz, degree=2) + a.oz10.keep <- earth(O3~temp+humidity, data=oz, degree=2, keepxy=TRUE) + plotmo(a.oz10, do.par=FALSE, main="a oz10", + degree1=1, all2=1, degree2=1, type2="im", + col.response=3, pt.pch=20) + + ad.oz10 <- earth(oz[,2:3], oz[,1], degree=2) + ad.oz10.keep <- earth(oz[,2:3], oz[,1], degree=2, keepxy=TRUE) + plotmo(ad.oz10, do.par=FALSE, main="ad oz10", + degree1=1, all2=1, degree2=1, type2="im", + col.response=3, pt.pch=20) + + func2 <- function() { + a.func <- earth(O3 ~ temp + humidity, data=oz10, degree=2) + plotmo(a.func, do.par=FALSE, main="a.func oz10", + degree1=1, all2=1, degree2=1, type2="im", + col.response=3, pt.pch=20) + + ad.func <- earth(oz10[,2:3], oz10[,1], degree=2) + plotmo(ad.func, do.par=FALSE, main="ad.func oz10", + degree1=1, all2=1, degree2=1, type2="im", + col.response=3, pt.pch=20) + + caption <- "test environments and finding the correct data, continued" + dopar(4,4,caption) + + oz <- .1 * oz.org + a.func <- earth(O3~temp+ humidity , data=oz, degree=2) + plotmo(a.func, do.par=FALSE, main="a.func oz.1", + degree1=1, all2=1, degree2=1, type2="im", + col.response=3, pt.pch=20) + + ad.func <- earth(oz[,2:3], oz[,1], degree=2) + plotmo(ad.func, do.par=FALSE, main="ad.func oz.1", + degree1=1, all2=1, degree2=1, type2="im", + col.response=3, pt.pch=20) + + plotmo(a.oz10.keep, do.par=FALSE, main="func1:a.oz10.keep", + degree1=1, all2=1, degree2=1, type2="im", + col.response=3, pt.pch=20) + + plotmo(ad.oz10.keep, do.par=FALSE, main="func1:ad.oz10.keep", + degree1=1, all2=1, degree2=1, type2="im", + col.response=3, pt.pch=20) + + cat("Expect error msg: formal argument \"do.par\" matched by multiple actual arguments\n") + expect.err(try(plotmo(a.oz10, do.par=FALSE, main="func1:a.oz10", + degree1=1, all2=1, degree2=1, type2="im", + col.response=3, pt.pch=20, do.par=FALSE))) + } + func2() + + y <- 3:11 + x1 <- c(1,3,2,4,5,6,6,6,6) + x2 <- c(2,3,4,5,6,7,8,9,10) + frame <- data.frame(y=y, x1=x1, x2=x2) + foo <- function() + { + lm.18.out <- lm(y~x1+x2, model=FALSE) + x1[2] <- 18 + y[3] <- 19 + frame <- data.frame(y=y, x1=x1, x2=x2) + list(lm.18.out = lm.18.out, + lm.18 = lm(y~x1+x2), + lm.18.keep = lm(y~x1+x2, x=TRUE, y=TRUE), + lm.18.frame = lm(y~x1+x2, data=frame)) + } + temp <- foo() + lm.18.out <- temp$lm.18.out + lm.18 <- temp$lm.18 + lm.18.keep <- temp$lm.18.keep + lm.18.frame <- temp$lm.18.frame + + # following should all use the x1 and y inside foo + + cat("==lm.18.out\n") + plotmo(lm.18.out, main="lm.18.out", + do.par=FALSE, degree1=1, clip=FALSE, ylim=c(0,20), + col.response=2, pt.pch=20) + + cat("==lm.18\n") + plotmo(lm.18, main="lm.18", + do.par=FALSE, degree1=1, clip=FALSE, ylim=c(0,20), + col.response=2, pt.pch=20) + + cat("==lm.18.keep\n") + plotmo(lm.18.keep, main="lm.18.keep", trace=2, + do.par=FALSE, degree1=1, clip=FALSE, ylim=c(0,20), + col.response=2, pt.pch=20) + + cat("==lm.18.frame\n") + plotmo(lm.18.frame, main="lm.18.frame", + do.par=FALSE, degree1=1, clip=FALSE, ylim=c(0,20), + col.response=2, pt.pch=20) + } > func1() test environments and finding the correct data plotmo trace 2: plotmo(object=a.glob, type2="im", degree1=1, degree2=1, all2=1, do.par=FALSE, trace=2, main="a.glob oz", col.response=3, pt.pch=20) --get.model.env for object with class earth object call is earth(formula=O3~temp+humidity, data=oz, degree=2) using the environment saved in $terms of the earth model: R_GlobalEnv --plotmo_prolog for earth object 'a.glob' --plotmo_x for earth object get.object.x: object$x is NULL (and it has no colnames) object call is earth(formula=O3~temp+humidity, data=oz, degree=2) get.x.from.model.frame: formula(object) is O3 ~ temp + humidity naked formula is the same formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) object$data is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names O3 temp humidity ibh na.action(object) is "na.fail" stats::model.frame(O3 ~ temp + humidity, data=call$data, na.action="na.fail") x=model.frame[,-1] is usable and has column names temp humidity plotmo_x returned[51,2]: temp humidity 150 48 81 151 59 63 152 67 58 ... 66 68 200 79 65 ----Metadata: plotmo_predict with nresponse=NULL and newdata=NULL calling predict.earth with NULL newdata stats::predict(earth.object, NULL, type="response") predict returned[51,1]: O3 1 7.990058 2 11.446254 3 13.959851 ... 13.645652 51 18.207402 predict after processing with nresponse=NULL is [51,1]: O3 1 7.990058 2 11.446254 3 13.959851 ... 13.645652 51 18.207402 ----Metadata: plotmo_fitted with nresponse=NULL stats::fitted(object=earth.object) fitted(object) returned[51,1]: O3 1 7.990058 2 11.446254 3 13.959851 ... 13.645652 51 18.207402 fitted(object) after processing with nresponse=NULL is [51,1]: O3 1 7.990058 2 11.446254 3 13.959851 ... 13.645652 51 18.207402 ----Metadata: plotmo_y with nresponse=NULL --plotmo_y with nresponse=NULL for earth object get.object.y: object$y is NULL (and it has no colnames) object call is earth(formula=O3~temp+humidity, data=oz, degree=2) get.y.from.model.frame: formula(object) is O3 ~ temp + humidity formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) object$data is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names O3 temp humidity ibh na.action(object) is "na.fail" stats::model.frame(O3 ~ temp + humidity, data=call$data, na.action="na.fail") y=model.frame[,1] is usable and has column name O3 plotmo_y returned[51,1]: O3 150 2 151 12 152 22 ... 17 200 14 plotmo_y after processing with nresponse=NULL is [51,1]: O3 150 2 151 12 152 22 ... 17 200 14 converted nresponse=NA to nresponse=1 nresponse=1 (was NA) ncol(fitted) 1 ncol(predict) 1 ncol(y) 1 ----Metadata: plotmo_y with nresponse=1 --plotmo_y with nresponse=1 for earth object get.object.y: object$y is NULL (and it has no colnames) object call is earth(formula=O3~temp+humidity, data=oz, degree=2) get.y.from.model.frame: formula(object) is O3 ~ temp + humidity formula is valid, now looking for data for the model.frame object$model is NULL (and it has no colnames) object$data is NULL (and it has no colnames) argument 2 of the call is 'data' eval(call$data, R_GlobalEnv) call$data is usable and has column names O3 temp humidity ibh na.action(object) is "na.fail" stats::model.frame(O3 ~ temp + humidity, data=call$data, na.action="na.fail") y=model.frame[,1] is usable and has column name O3 got model response from model.frame(O3 ~ temp + humidity, data=call$data, na.action="na.fail") plotmo_y returned[51,1]: O3 150 2 151 12 152 22 ... 17 200 14 plotmo_y after processing with nresponse=1 is [51,1]: O3 150 2 151 12 152 22 ... 17 200 14 got response name "O3" from yhat resp.levs is NULL ----Metadata: done number of x values: temp 27 humidity 27 ----plotmo_singles for earth object singles: 1 temp ----plotmo_pairs for earth object pairs: [,1] [,2] [1,] "1 temp" "2 humidity" ----Figuring out ylim --get.ylim.by.dummy.plots --plot.degree1(draw.plot=FALSE) degree1 plot1 (pmethod "plotmo") variable temp newdata[50,2]: temp humidity 1 48.00000 68 2 48.91837 68 3 49.83673 68 ... 50.75510 68 50 93.00000 68 stats::predict(earth.object, data.frame[50,2], type="response") predict returned[50,1]: O3 1 7.990058 2 8.278609 3 8.567159 ... 8.855710 50 29.834221 predict after processing with nresponse=1 is [50,1]: O3 1 7.990058 2 8.278609 3 8.567159 ... 8.855710 50 29.834221 --plot.degree2(draw.plot=FALSE) degree2 plot1 (pmethod "plotmo") variables temp:humidity newdata[400,2]: temp humidity 1 48.00000 33 2 50.36842 33 3 52.73684 33 ... 55.10526 33 400 93.00000 90 stats::predict(earth.object, data.frame[400,2], type="response") predict returned[400,1]: O3 1 7.990058 2 8.734215 3 9.478372 ... 10.222529 400 33.851866 predict after processing with nresponse=1 is [400,1]: O3 1 7.990058 2 8.734215 3 9.478372 ... 10.222529 400 33.851866 --done get.ylim.by.dummy.plots ylim c(1.936, 33.94) clip TRUE --plot.degree1(draw.plot=TRUE) plotmo grid: temp humidity 80 68 graphics::plot.default(x=c(48,48.92,49.8...), y=c(7.99,8.279,8...), type="n", main="a.glob oz", xlab="", ylab="", xaxt="s", yaxt="s", xlim=c(47.98,93.08), ylim=c(1.94,33.94)) --plot.degree2(draw.plot=TRUE) plotmo trace 2: plotmo(object=ad.glob, type2="im", degree1=1, degree2=1, all2=1, do.par=FALSE, trace=2, main="ad.glob oz", col.response=3, pch.response=20) --get.model.env for object with class earth object call is earth(x=oz[, 2:3], y=oz[, 1], degree=2) assuming the environment of the earth model is that of plotmo's caller: env(caption) --plotmo_prolog for earth object 'ad.glob' --plotmo_x for earth object get.object.x: object$x is NULL (and it has no colnames) object call is earth(x=oz[, 2:3], y=oz[, 1], degree=2) get.x.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$x, env(caption)) getCall(object)$x is usable and has column names temp humidity plotmo_x returned[51,2]: temp humidity 150 48 81 151 59 63 152 67 58 ... 66 68 200 79 65 ----Metadata: plotmo_predict with nresponse=NULL and newdata=NULL calling predict.earth with NULL newdata stats::predict(earth.object, NULL, type="response") predict returned[51,1]: oz[, 1] 1 7.990058 2 11.446254 3 13.959851 ... 13.645652 51 18.207402 predict after processing with nresponse=NULL is [51,1]: oz[, 1] 1 7.990058 2 11.446254 3 13.959851 ... 13.645652 51 18.207402 ----Metadata: plotmo_fitted with nresponse=NULL stats::fitted(object=earth.object) fitted(object) returned[51,1]: oz[, 1] 1 7.990058 2 11.446254 3 13.959851 ... 13.645652 51 18.207402 fitted(object) after processing with nresponse=NULL is [51,1]: oz[, 1] 1 7.990058 2 11.446254 3 13.959851 ... 13.645652 51 18.207402 ----Metadata: plotmo_y with nresponse=NULL --plotmo_y with nresponse=NULL for earth object get.object.y: object$y is NULL (and it has no colnames) object call is earth(x=oz[, 2:3], y=oz[, 1], degree=2) get.y.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$y, env(caption)) getCall(object)$y is usable but without colnames so we will keep on searching names(call) is "" "x" "y" "degree" the name of argument 2 is "y" so we will not process it with argn object$y is NULL call$y is usable but without colnames but we will use it anyway colname was NULL now "y" plotmo_y returned[51,1]: y 1 2 2 12 3 22 ... 17 51 14 plotmo_y after processing with nresponse=NULL is [51,1]: y 1 2 2 12 3 22 ... 17 51 14 converted nresponse=NA to nresponse=1 nresponse=1 (was NA) ncol(fitted) 1 ncol(predict) 1 ncol(y) 1 ----Metadata: plotmo_y with nresponse=1 --plotmo_y with nresponse=1 for earth object get.object.y: object$y is NULL (and it has no colnames) object call is earth(x=oz[, 2:3], y=oz[, 1], degree=2) get.y.from.model.frame: terms(object) did not return the terms, will look for the formula elsewhere no formula in getCall(object) get.data.from.object.call.field: eval(getCall(object)$y, env(caption)) getCall(object)$y is usable but without colnames so we will keep on searching names(call) is "" "x" "y" "degree" the name of argument 2 is "y" so we will not process it with argn object$y is NULL call$y is usable but without colnames but we will use it anyway got model response from getCall(object)$y colname was NULL now "y" plotmo_y returned[51,1]: y 1 2 2 12 3 22 ... 17 51 14 plotmo_y after processing with nresponse=1 is [51,1]: y 1 2 2 12 3 22 ... 17 51 14 got response name "oz[, 1]" from yhat resp.levs is NULL ----Metadata: done number of x values: temp 27 humidity 27 ----plotmo_singles for earth object singles: 1 temp ----plotmo_pairs for earth object pairs: [,1] [,2] [1,] "1 temp" "2 humidity" ----Figuring out ylim --get.ylim.by.dummy.plots --plot.degree1(draw.plot=FALSE) degree1 plot1 (pmethod "plotmo") variable temp newdata[50,2]: temp humidity 1 48.00000 68 2 48.91837 68 3 49.83673 68 ... 50.75510 68 50 93.00000 68 stats::predict(earth.object, data.frame[50,2], type="response") predict returned[50,1]: oz[, 1] 1 7.990058 2 8.278609 3 8.567159 ... 8.855710 50 29.834221 predict after processing with nresponse=1 is [50,1]: oz[, 1] 1 7.990058 2 8.278609 3 8.567159 ... 8.855710 50 29.834221 --plot.degree2(draw.plot=FALSE) degree2 plot1 (pmethod "plotmo") variables temp:humidity newdata[400,2]: temp humidity 1 48.00000 33 2 50.36842 33 3 52.73684 33 ... 55.10526 33 400 93.00000 90 stats::predict(earth.object, data.frame[400,2], type="response") predict returned[400,1]: oz[, 1] 1 7.990058 2 8.734215 3 9.478372 ... 10.222529 400 33.851866 predict after processing with nresponse=1 is [400,1]: oz[, 1] 1 7.990058 2 8.734215 3 9.478372 ... 10.222529 400 33.851866 --done get.ylim.by.dummy.plots ylim c(1.931, 34) clip TRUE --plot.degree1(draw.plot=TRUE) plotmo grid: temp humidity 80 68 graphics::plot.default(x=c(48,48.92,49.8...), y=c(7.99,8.279,8...), type="n", main="ad.glob oz", xlab="", ylab="", xaxt="s", yaxt="s", xlim=c(48,93), ylim=c(1.93,34)) --plot.degree2(draw.plot=TRUE) plotmo grid: temp humidity 80 68 plotmo grid: temp humidity 80 68 plotmo grid: temp humidity 800 680 plotmo grid: temp humidity 800 680 plotmo grid: temp humidity 800 680 plotmo grid: temp humidity 800 680 test environments and finding the correct data, continued plotmo grid: temp humidity 8 6.8 plotmo grid: temp humidity 8 6.8 plotmo grid: temp humidity 800 680 plotmo grid: temp humidity 800 680 Expect error msg: formal argument "do.par" matched by multiple actual arguments Error in plotmo(a.oz10, do.par = FALSE, main = "func1:a.oz10", degree1 = 1, : formal argument "do.par" matched by multiple actual arguments Got expected error from try(plotmo(a.oz10, do.par = FALSE, main = "func1:a.oz10", degree1 = 1, all2 = 1, degree2 = 1, type2 = "im", col.response = 3, pt.pch = 20, do.par = FALSE)) ==lm.18.out plotmo grid: x1 x2 6 6 ==lm.18 plotmo grid: x1 x2 6 6 ==lm.18.keep plotmo trace 2: plotmo(object=lm.18.keep, degree1=1, do.par=FALSE, clip=FALSE, ylim=c(0,20), trace=2, main="lm.18.keep", col.response=2, pt.pch=20) --get.model.env for object with class lm object call is lm(formula=y~x1+x2, x=TRUE, y=TRUE) using the environment saved in $terms of the lm model: env(frame, lm.18.out, x1, y) --plotmo_prolog for lm object 'lm.18.keep' --plotmo_x for lm object get.object.x: object$x is usable and has column names (Intercept) x1 x2 dropped "(Intercept)" column from x plotmo_x returned[9,2]: x1 x2 1 1 2 2 18 3 3 2 4 ... 4 5 9 6 10 ----Metadata: plotmo_predict with nresponse=NULL and newdata=NULL calling predict.lm with NULL newdata stats::predict(lm.object, NULL, type="response") predict returned[9,1] with no column names: 1 8.098674 2 3.323243 3 8.792796 ... 8.674176 9 10.564707 predict after processing with nresponse=NULL is [9,1] with no column names: 1 8.098674 2 3.323243 3 8.792796 ... 8.674176 9 10.564707 ----Metadata: plotmo_fitted with nresponse=NULL stats::fitted(object=lm.object) fitted(object) returned[9,1] with no column names: 1 8.098674 2 3.323243 3 8.792796 ... 8.674176 9 10.564707 fitted(object) after processing with nresponse=NULL is [9,1] with no column names: 1 8.098674 2 3.323243 3 8.792796 ... 8.674176 9 10.564707 ----Metadata: plotmo_y with nresponse=NULL --plotmo_y with nresponse=NULL for lm object get.object.y: object$y is usable but without colnames so we will keep on searching object call is lm(formula=y~x1+x2, x=TRUE, y=TRUE) get.y.from.model.frame: formula(object) is y ~ x1 + x2 formula is valid, now looking for data for the model.frame object$model is usable and has column names y x1 x2 y=model.frame[,1] is usable and has column name y plotmo_y returned[9,1]: y 1 3 2 4 3 19 ... 6 9 11 plotmo_y after processing with nresponse=NULL is [9,1]: y 1 3 2 4 3 19 ... 6 9 11 converted nresponse=NA to nresponse=1 nresponse=1 (was NA) ncol(fitted) 1 ncol(predict) 1 ncol(y) 1 ----Metadata: plotmo_y with nresponse=1 --plotmo_y with nresponse=1 for lm object get.object.y: object$y is usable but without colnames so we will keep on searching object call is lm(formula=y~x1+x2, x=TRUE, y=TRUE) get.y.from.model.frame: formula(object) is y ~ x1 + x2 formula is valid, now looking for data for the model.frame object$model is usable and has column names y x1 x2 y=model.frame[,1] is usable and has column name y got model response from object$model plotmo_y returned[9,1]: y 1 3 2 4 3 19 ... 6 9 11 plotmo_y after processing with nresponse=1 is [9,1]: y 1 3 2 4 3 19 ... 6 9 11 got response name "y" from yfull resp.levs is NULL ----Metadata: done number of x values: x1 6 x2 9 ----plotmo_singles for lm object singles: 1 x1 ----plotmo_pairs for lm object formula(object) returned y ~ x1 + x2 formula.vars "x1" "x2" term.labels "x1" "x2" plotmo_pairs_from_term_labels term.labels: "x1" "x2" "x1" "x2" pred.names: "x1" "x2" considering x1 considering x2 considering x1 considering x2 no pairs ----Figuring out ylim ylim c(0, 20) clip FALSE --plot.degree1(draw.plot=TRUE) plotmo grid: x1 x2 6 6 degree1 plot1 (pmethod "plotmo") variable x1 newdata[50,2]: x1 x2 1 1.000000 6 2 1.346939 6 3 1.693878 6 ... 2.040816 6 50 18.000000 6 stats::predict(lm.object, data.frame[50,2], type="response") predict returned[50,1] with no column names: 1 10.107826 2 10.000117 3 9.892409 ... 9.784700 50 4.830107 predict after processing with nresponse=1 is [50,1]: predict 1 10.107826 2 10.000117 3 9.892409 ... 9.784700 50 4.830107 graphics::plot.default(x=c(1,1.347,1.694...), y=c(10.11,10,9.89...), type="n", main="lm.18.keep", xlab="", ylab="", xaxt="s", yaxt="s", xlim=c(1,18.04), ylim=c(0,20)) ==lm.18.frame plotmo grid: x1 x2 6 6 > > caption <- "test earth formula versus x,y model" > # dopar(4,4,caption) > # mtext(caption, outer=TRUE, font=2, line=1.5, cex=1) > a <- earth(O3 ~ ., data=ozone1, degree=2) > plotmo(a, caption="test earth formula versus xy model (formula)") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > a <- earth(ozone1[, -1], ozone1[,1], degree=2) > plotmo(a, caption="test earth formula versus xy model (xy)") plotmo grid: vh wind humidity temp ibh dpg ibt vis doy 5760 5 64 62 2112.5 24 167.5 120 205.5 > > # single predictor > caption <- "test earth(O3~wind, data=ozone1, degree=2), single predictor" > dopar(2,2,caption) test earth(O3~wind, data=ozone1, degree=2), single predictor > a <- earth(O3~wind, data=ozone1, degree=2) > plotmo(a) > > caption = "se=2, earth(doy~humidity+temp+wind, data=ozone1) versus termplot (expect no se lines)" > dopar(3,3,caption) se=2, earth(doy~humidity+temp+wind, data=ozone1) versus termplot (expect no se lines) > mtext(caption, outer=TRUE, font=2, line=1.5, cex=1) > # minspan=1 to force two degree2 graphs for the test (wasn't necessary in old versions of earth) > a <- earth(doy~humidity + temp + wind, data=ozone1, degree=2, minspan=1) > cat("Ignore warning: predict.earth ignored argument \"se\"\n") Ignore warning: predict.earth ignored argument "se" > termplot(a) Warning: predict.earth ignored argument 'se.fit' > plotmo(a, do.par=FALSE, ylim=NA, degree2=c(1:2), clip=FALSE, caption=caption) plotmo grid: humidity temp wind 64 62 5 > > # test fix to bug reported by Joe Retzer, FIXED Dec 7, 2007 > N <- 650 > set.seed(2007) > q_4 <- runif(N, -1, 1) > q_2102 <- runif(N, -1, 1) > q_2104 <- runif(N, -1, 1) > q_3105 <- runif(N, -1, 1) > q_3106 <- runif(N, -1, 1) > q_4104 <- runif(N, -1, 1) > q_6101 <- runif(N, -1, 1) > q_6103 <- runif(N, -1, 1) > q_7104 <- runif(N, -1, 1) > q_3109 <- runif(N, -1, 1) > q_4103 <- runif(N, -1, 1) > q_2111 <- runif(N, -1, 1) > q_3107 <- runif(N, -1, 1) > q_3101 <- runif(N, -1, 1) > q_3104 <- runif(N, -1, 1) > q_7107 <- runif(N, -1, 1) > depIndex <- sin(1.0 * q_4 + rnorm(650, sd=.8)) + sin(1.8 * q_2102 + rnorm(650, sd=.8)) + sin(1.3 * q_2104 + rnorm(650, sd=.8)) + sin(1.4 * q_3105 + rnorm(650, sd=.8)) + + sin(1.5 * q_3106 + rnorm(650, sd=.8)) + sin(1.6 * q_4104 + rnorm(650, sd=.8)) + sin(1.8 * q_6101 + rnorm(650, sd=.8)) + sin(1.8 * q_6103 + rnorm(650, sd=.8)) + + sin(1.9 * q_7104 + rnorm(650, sd=.8)) + sin(2.0 * q_3109 + rnorm(650, sd=.8)) > > regDatCWD <- as.data.frame(cbind(depIndex, q_4, q_2102, q_2104, q_3105, q_3106, q_4104, q_6101, q_6103, q_7104, q_3109, q_4103, q_2111, q_3107, q_3101, q_3104, q_7107)) > cat("--plotmo(earthobj5)--\n") --plotmo(earthobj5)-- > earthobj5 <- earth(depIndex ~ q_4+q_2102+q_2104+q_3105+q_3106+q_4104+q_6101+q_6103+q_7104+q_3109+q_4103+q_2111+q_3107+q_3101+q_3104+q_7107, data=regDatCWD) > print(summary(earthobj5, digits = 2)) Call: earth(formula=depIndex~q_4+q_2102+q_2104+q_3105+q_3106+q_4104+q_...), data=regDatCWD) coefficients (Intercept) 1.79 h(0.782075-q_4) -0.97 h(q_4-0.782075) -5.36 h(q_2102- -0.664223) 1.19 h(q_2104- -0.954733) 0.85 h(0.83147-q_3105) -0.77 h(0.492009-q_3106) -0.93 h(q_4104- -0.671276) 1.02 h(0.483685-q_6101) -1.10 h(0.914724-q_6103) -1.12 h(0.545206-q_7104) -1.19 h(-0.157173-q_3109) -0.96 h(q_3109- -0.157173) 1.03 Selected 13 of 21 terms, and 10 of 16 predictors Termination condition: RSq changed by less than 0.001 at 21 terms Importance: q_6103, q_4104, q_2102, q_7104, q_3109, q_6101, q_2104, q_4, ... Number of terms at each degree of interaction: 1 12 (additive model) GCV 2.5 RSS 1509 GRSq 0.53 RSq 0.57 > plotmo(earthobj5) plotmo grid: q_4 q_2102 q_2104 q_3105 q_3106 q_4104 0.05726625 0.01725001 0.004659335 -0.01826179 -0.00913319 0.01401429 q_6101 q_6103 q_7104 q_3109 q_4103 q_2111 -0.04790454 0.03681165 0.01827148 -0.09899272 -0.0623349 0.01007481 q_3107 q_3101 q_3104 q_7107 -0.02481171 -0.07733527 -0.003053319 0.02821214 > > # long predictor names > > a.rather.long.in.fact.very.long.name.q_4 <- q_4 > a.rather.long.in.fact.very.long.name.q_2102 <- q_2102 > a.rather.long.in.fact.very.long.name.q_2104 <- q_2104 > a.rather.long.in.fact.very.long.name.q_3105 <- q_3105 > a.rather.long.in.fact.very.long.name.q_3106 <- q_3106 > a.rather.long.in.fact.very.long.name.q_4104 <- q_4104 > a.rather.long.in.fact.very.long.name.q_6101 <- q_6101 > a.rather.long.in.fact.very.long.name.q_6103 <- q_6103 > a.rather.long.in.fact.very.long.name.q_7104 <- q_7104 > a.rather.long.in.fact.very.long.name.q_3109 <- q_3109 > a.rather.long.in.fact.very.long.name.q_4103 <- q_4103 > a.rather.long.in.fact.very.long.name.q_2111 <- q_2111 > a.rather.long.in.fact.very.long.name.q_3107 <- q_3107 > a.rather.long.in.fact.very.long.name.q_3101 <- q_3101 > a.rather.long.in.fact.very.long.name.q_3104 <- q_3104 > a.rather.long.in.fact.very.long.name.q_7107 <- q_7107 > a.rather.long.in.fact.very.long.name.for.the.response <- depIndex > a.rather.long.in.fact.very.long.name.for.the.dataframe <- + as.data.frame(cbind( + a.rather.long.in.fact.very.long.name.for.the.response, + a.rather.long.in.fact.very.long.name.q_4, + a.rather.long.in.fact.very.long.name.q_2102, + a.rather.long.in.fact.very.long.name.q_2104, + a.rather.long.in.fact.very.long.name.q_3105, + a.rather.long.in.fact.very.long.name.q_3106, + a.rather.long.in.fact.very.long.name.q_4104, + a.rather.long.in.fact.very.long.name.q_6101, + a.rather.long.in.fact.very.long.name.q_6103, + a.rather.long.in.fact.very.long.name.q_7104, + a.rather.long.in.fact.very.long.name.q_3109, + a.rather.long.in.fact.very.long.name.q_4103, + a.rather.long.in.fact.very.long.name.q_2111, + a.rather.long.in.fact.very.long.name.q_3107, + a.rather.long.in.fact.very.long.name.q_3101, + a.rather.long.in.fact.very.long.name.q_3104, + a.rather.long.in.fact.very.long.name.q_7107)) > > cat("--a.rather.long.in.fact.very.long.name.for.the...A--\n") --a.rather.long.in.fact.very.long.name.for.the...A-- > a.rather.long.in.fact.very.long.name.for.the.modelA <- + earth(a.rather.long.in.fact.very.long.name.for.the.response ~ + a.rather.long.in.fact.very.long.name.q_4 + + a.rather.long.in.fact.very.long.name.q_2102 + + a.rather.long.in.fact.very.long.name.q_2104 + + a.rather.long.in.fact.very.long.name.q_3105 + + a.rather.long.in.fact.very.long.name.q_3106 + + a.rather.long.in.fact.very.long.name.q_4104 + + a.rather.long.in.fact.very.long.name.q_6101 + + a.rather.long.in.fact.very.long.name.q_6103 + + a.rather.long.in.fact.very.long.name.q_7104 + + a.rather.long.in.fact.very.long.name.q_3109 + + a.rather.long.in.fact.very.long.name.q_4103 + + a.rather.long.in.fact.very.long.name.q_2111 + + a.rather.long.in.fact.very.long.name.q_3107 + + a.rather.long.in.fact.very.long.name.q_3101 + + a.rather.long.in.fact.very.long.name.q_3104 + + a.rather.long.in.fact.very.long.name.q_7107, + data = a.rather.long.in.fact.very.long.name.for.the.dataframe) > print(summary(a.rather.long.in.fact.very.long.name.for.the.modelA, digits = 2)) Call: earth(formula=a.rather.long.in.fact.very.long.name.for.the.respo...), data=a.rather.long.in.fact.very.long.name.for.the.da...) coefficients (Intercept) 1.79 h(0.782075-a.rather.long.in.fact.very.long.name.q_4) -0.97 h(a.rather.long.in.fact.very.long.name.q_4-0.782075) -5.36 h(a.rather.long.in.fact.very.long.name.q_2102- -0.664223) 1.19 h(a.rather.long.in.fact.very.long.name.q_2104- -0.954733) 0.85 h(0.83147-a.rather.long.in.fact.very.long.name.q_3105) -0.77 h(0.492009-a.rather.long.in.fact.very.long.name.q_3106) -0.93 h(a.rather.long.in.fact.very.long.name.q_4104- -0.671276) 1.02 h(0.483685-a.rather.long.in.fact.very.long.name.q_6101) -1.10 h(0.914724-a.rather.long.in.fact.very.long.name.q_6103) -1.12 h(0.545206-a.rather.long.in.fact.very.long.name.q_7104) -1.19 h(-0.157173-a.rather.long.in.fact.very.long.name.q_3109) -0.96 h(a.rather.long.in.fact.very.long.name.q_3109- -0.157173) 1.03 Selected 13 of 21 terms, and 10 of 16 predictors Termination condition: RSq changed by less than 0.001 at 21 terms Importance: a.rather.long.in.fact.very.long.name.q_6103, ... Number of terms at each degree of interaction: 1 12 (additive model) GCV 2.5 RSS 1509 GRSq 0.53 RSq 0.57 > plot(a.rather.long.in.fact.very.long.name.for.the.modelA) > plotmo(a.rather.long.in.fact.very.long.name.for.the.modelA) plotmo grid: a.rather.long.in.fact.very.long.name.q_4 0.05726625 a.rather.long.in.fact.very.long.name.q_2102 0.01725001 a.rather.long.in.fact.very.long.name.q_2104 0.004659335 a.rather.long.in.fact.very.long.name.q_3105 -0.01826179 a.rather.long.in.fact.very.long.name.q_3106 -0.00913319 a.rather.long.in.fact.very.long.name.q_4104 0.01401429 a.rather.long.in.fact.very.long.name.q_6101 -0.04790454 a.rather.long.in.fact.very.long.name.q_6103 0.03681165 a.rather.long.in.fact.very.long.name.q_7104 0.01827148 a.rather.long.in.fact.very.long.name.q_3109 -0.09899272 a.rather.long.in.fact.very.long.name.q_4103 -0.0623349 a.rather.long.in.fact.very.long.name.q_2111 0.01007481 a.rather.long.in.fact.very.long.name.q_3107 -0.02481171 a.rather.long.in.fact.very.long.name.q_3101 -0.07733527 a.rather.long.in.fact.very.long.name.q_3104 -0.003053319 a.rather.long.in.fact.very.long.name.q_7107 0.02821214 > > cat("--a.rather.long.in.fact.very.long.name.for.the...C--\n") --a.rather.long.in.fact.very.long.name.for.the...C-- > a.rather.long.in.fact.very.long.name.for.the.modelC <- + earth(x = a.rather.long.in.fact.very.long.name.for.the.dataframe[,-1], + y = a.rather.long.in.fact.very.long.name.for.the.response, + degree = 3) > print(summary(a.rather.long.in.fact.very.long.name.for.the.modelC, digits = 2)) Call: earth(x=a.rather.long.in.fact.very.long.name.for.the.dataf...), y=a.rather.long.in.fact.very.long.name.for.the.re..., degree=3) coefficients (Intercept) 1.72 h(0.782075-a.rather.long.in.fact.very.long.name.q_4) -1.02 h(a.rather.long.in.fact.very.long.name.q_4-0.782075) -10.33 h(a.rather.long.in.fact.very.long.name.q_2102- -0.664223) 1.27 h(a.rather.long.in.fact.very.long.name.q_2104- -0.954733) 0.82 h(0.83147-a.rather.long.in.fact.very.long.name.q_3105) -1.00 h(0.492009-a.rather.long.in.fact.very.long.name.q_3106) -0.90 h(a.rather.long.in.fact.very.long.name.q_4104- -0.671276) 1.01 h(0.483685-a.rather.long.in.fact.very.long.name.q_6101) -1.09 h(0.914724-a.rather.long.in.fact.very.long.name.q_6103) -1.18 h(0.545206-a.rather.long.in.fact.very.long.name.q_7104) -1.62 h(-0.157173-a.rather.long.in.fact.very.long.name.q_3109) -1.81 h(a.rather.long.in.fact.very.long.name.q_3109- -0.157173) 1.15 h(-0.664223-a.rather.long.in.fact.very.long.name.q_2102) * h(a.rather.long.in.fact.very.long.name.q_3106- -0.148502) 3.71 h(0.83147-a.rather.long.in.fact.very.long.name.q_3105) * h(a.rather.long.in.fact.very.long.name.q_7107- -0.748278) 0.31 h(0.914724-a.rather.long.in.fact.very.long.name.q_6103) * h(-0.713314-a.rather.long.in.fact.very.long.name.q_3107) 2.90 h(0.545206-a.rather.long.in.fact.very.long.name.q_7104) * h(a.rather.long.in.fact.very.long.name.q_2111- -0.544753) 0.61 h(-0.157173-a.rather.long.in.fact.very.long.name.q_3109) * h(0.700096-a.rather.long.in.fact.very.long.name.q_2111) 1.33 h(a.rather.long.in.fact.very.long.name.q_4-0.82106) * h(0.545206-a.rather.long.in.fact.very.long.name.q_7104) * h(a.rather.long.in.fact.very.long.name.q_2111- -0.544753) 15.97 Selected 19 of 33 terms, and 13 of 16 predictors Termination condition: Reached nk 33 Importance: a.rather.long.in.fact.very.long.name.q_6103, ... Number of terms at each degree of interaction: 1 12 5 1 GCV 2.4 RSS 1374 GRSq 0.54 RSq 0.6 > plot(a.rather.long.in.fact.very.long.name.for.the.modelC) > plotmo(a.rather.long.in.fact.very.long.name.for.the.modelC) plotmo grid: a.rather.long.in.fact.very.long.name.q_4 0.05726625 a.rather.long.in.fact.very.long.name.q_2102 0.01725001 a.rather.long.in.fact.very.long.name.q_2104 0.004659335 a.rather.long.in.fact.very.long.name.q_3105 -0.01826179 a.rather.long.in.fact.very.long.name.q_3106 -0.00913319 a.rather.long.in.fact.very.long.name.q_4104 0.01401429 a.rather.long.in.fact.very.long.name.q_6101 -0.04790454 a.rather.long.in.fact.very.long.name.q_6103 0.03681165 a.rather.long.in.fact.very.long.name.q_7104 0.01827148 a.rather.long.in.fact.very.long.name.q_3109 -0.09899272 a.rather.long.in.fact.very.long.name.q_4103 -0.0623349 a.rather.long.in.fact.very.long.name.q_2111 0.01007481 a.rather.long.in.fact.very.long.name.q_3107 -0.02481171 a.rather.long.in.fact.very.long.name.q_3101 -0.07733527 a.rather.long.in.fact.very.long.name.q_3104 -0.003053319 a.rather.long.in.fact.very.long.name.q_7107 0.02821214 > > a <- earth(survived ~ pclass+sex+age, data=etitanic, degree=2) > print(summary(a)) Call: earth(formula=survived~pclass+sex+age, data=etitanic, degree=2) coefficients (Intercept) 0.92939850 pclass3rd -0.45571429 pclass2nd * sexmale -0.27354805 pclass3rd * sexmale 0.18991361 sexmale * h(age-16) 0.05497748 sexmale * h(age-25) -0.01885057 sexmale * h(age-2) -0.04217428 Selected 7 of 14 terms, and 4 of 4 predictors Termination condition: Reached nk 21 Importance: sexmale, pclass3rd, pclass2nd, age Number of terms at each degree of interaction: 1 1 5 GCV 0.1442766 RSS 146.3318 GRSq 0.4039126 RSq 0.4209023 > plotmo(a, caption="plotmo with facs: pclass+sex+age") plotmo grid: pclass sex age 3rd male 28 > plotmo(a, caption="plotmo with facs: pclass+sex+age, all1=T, grid.col=\"gray\"", all1=T, grid.col="gray") plotmo grid: pclass sex age 3rd male 28 > plotmo(a, caption="plotmo with facs: pclass+sex+age, all2=T, col.grid=\"green\"", all2=T, col.grid="green") plotmo grid: pclass sex age 3rd male 28 > plotmo(a, caption="plotmo with facs: pclass+sex+age, all1=T, all2=T, grid=2", all1=T, all2=T, grid.col=2) plotmo grid: pclass sex age 3rd male 28 > plotmo(a, clip=FALSE, degree2=FALSE, caption="plotmo (no degree2) with facs: pclass+sex+age") plotmo grid: pclass sex age 3rd male 28 > plotmo(a, clip=FALSE, grid.levels=list(pclass="2n", sex="ma"), + caption="plotmo with grid.levels: pclass+sex+age") plotmo grid: pclass sex age 2nd male 28 > # in above tests, all degree2 terms use facs > # now build a model with some degree2 term that use facs, some that don't > a <- earth(survived ~ pclass+age+sibsp, data=etitanic, degree=2) > print(summary(a)) Call: earth(formula=survived~pclass+age+sibsp, data=etitanic, degree=2) coefficients (Intercept) 1.20590993 pclass2nd -0.27484540 pclass3rd -0.45765086 h(age-5) -0.03561187 h(age-18) 0.03022469 h(18-age) * h(sibsp-2) -0.04797511 h(18-age) * h(sibsp-3) 0.04721023 Selected 7 of 17 terms, and 4 of 4 predictors Termination condition: Reached nk 21 Importance: pclass3rd, age, pclass2nd, sibsp Number of terms at each degree of interaction: 1 4 2 GCV 0.2040487 RSS 206.9554 GRSq 0.1569604 RSq 0.1809888 > plotmo(a, caption="plotmo with mixed fac and non-fac degree2 terms", persp.border=NA) plotmo grid: pclass age sibsp 3rd 28 0 > plotmo(a, caption="plotmo with mixed fac and non-fac degree2 terms and grid.levels", + grid.levels=list(pclass="2n", age=20), # test partial matching of grid levels, and numeric preds + persp.ticktype="d", persp.nticks=2) plotmo grid: pclass age sibsp 2nd 20 0 > > # check detection of illegal grid.levels argument > expect.err(try(plotmo(a, grid.levels=list(pcla="1", pclass="2"))), 'illegal grid.levels argument ("pcla" and "pclass" both match "pclass")') Error : illegal grid.levels argument ("pcla" and "pclass" both match "pclass") Got expected error from try(plotmo(a, grid.levels = list(pcla = "1", pclass = "2"))) > expect.err(try(plotmo(a, grid.levels=list(pclass="1", pcla="2"))), 'illegal grid.levels argument ("pclass" and "pcla" both match "pclass")') Error : illegal grid.levels argument ("pclass" and "pcla" both match "pclass") Got expected error from try(plotmo(a, grid.levels = list(pclass = "1", pcla = "2"))) > expect.err(try(plotmo(a, grid.levels=list(pcla="nonesuch"))), 'illegal level "nonesuch" for "pclass" in grid.levels (allowed levels are "1st" "2nd" "3rd")') Error : illegal level "nonesuch" for "pclass" in grid.levels (allowed levels are "1st" "2nd" "3rd") Got expected error from try(plotmo(a, grid.levels = list(pcla = "nonesuch"))) > expect.err(try(plotmo(a, grid.levels=list(pcla="1sx"))), 'illegal level "1sx" for "pclass" in grid.levels (allowed levels are "1st" "2nd" "3rd")') Error : illegal level "1sx" for "pclass" in grid.levels (allowed levels are "1st" "2nd" "3rd") Got expected error from try(plotmo(a, grid.levels = list(pcla = "1sx"))) > expect.err(try(plotmo(a, grid.levels=list(pcla=1))), 'illegal level for "pclass" in grid.levels (specify factor levels with a string)') Error : illegal level for "pclass" in grid.levels (specify factor levels with a string) Got expected error from try(plotmo(a, grid.levels = list(pcla = 1))) > expect.err(try(plotmo(a, grid.levels=list(pcla=c("ab", "cd")))), "length(pclass) in grid.levels is not 1") Error : length(pclass) in grid.levels is not 1 Got expected error from try(plotmo(a, grid.levels = list(pcla = c("ab", "cd")))) > expect.err(try(plotmo(a, grid.levels=list(pcla=NA))), 'pclass in grid.levels is NA') Error : pclass in grid.levels is NA Got expected error from try(plotmo(a, grid.levels = list(pcla = NA))) > expect.err(try(plotmo(a, grid.levels=list(pcla=Inf))), 'pclass in grid.levels is infinite') Error : pclass in grid.levels is infinite Got expected error from try(plotmo(a, grid.levels = list(pcla = Inf))) > expect.err(try(plotmo(a, grid.levels=list(pcla=9))), 'illegal level for "pclass" in grid.levels (specify factor levels with a string)') Error : illegal level for "pclass" in grid.levels (specify factor levels with a string) Got expected error from try(plotmo(a, grid.levels = list(pcla = 9))) > options(warn=2) > expect.err(try(plotmo(a, grid.levels=list(age="ab"))), 'grid.levels returned class \"character\" for age, so will use the default grid.func for age') Error : (converted from warning) grid.levels returned class "character" for age, so will use the default grid.func for age Got expected error from try(plotmo(a, grid.levels = list(age = "ab"))) > options(warn=1) > expect.err(try(plotmo(a, grid.levels=list(age=NA))), 'age in grid.levels is NA') Error : age in grid.levels is NA Got expected error from try(plotmo(a, grid.levels = list(age = NA))) > expect.err(try(plotmo(a, grid.levels=list(age=Inf))), 'age in grid.levels is infinite') Error : age in grid.levels is infinite Got expected error from try(plotmo(a, grid.levels = list(age = Inf))) > expect.err(try(plotmo(a, grid.lev=list(age=list(1,2)))), 'length(age) in grid.levels is not 1') Error : length(age) in grid.levels is not 1 Got expected error from try(plotmo(a, grid.lev = list(age = list(1, 2)))) > > # more-or-less repeat above, but with glm models > a <- earth(survived ~ pclass+age+sibsp, data=etitanic, degree=2, glm=list(family=binomial)) > print(summary(a)) Call: earth(formula=survived~pclass+age+sibsp, data=etitanic, glm=list(family=binomial), degree=2) GLM coefficients survived (Intercept) 3.4306891 pclass2nd -1.2012524 pclass3rd -2.0973424 h(age-5) -0.1769427 h(age-18) 0.1502007 h(18-age) * h(sibsp-2) -0.2887477 h(18-age) * h(sibsp-3) 0.2820357 GLM (family binomial, link logit): nulldev df dev df devratio AIC iters converged 1414.62 1045 1212.21 1039 0.143 1226 5 1 Earth selected 7 of 17 terms, and 4 of 4 predictors Termination condition: Reached nk 21 Importance: pclass3rd, age, pclass2nd, sibsp Number of terms at each degree of interaction: 1 4 2 Earth GCV 0.2040487 RSS 206.9554 GRSq 0.1569604 RSq 0.1809888 > plotmo(a, ylim=c(0, 1), caption="plotmo glm with mixed fac and non-fac degree2 terms") plotmo grid: pclass age sibsp 3rd 28 0 > plotmo(a, ylim=c(0, 1), caption="plotmo glm with mixed fac and non-fac degree2 terms and grid.levels", + grid.levels=list(pcl="2nd")) # test partial matching of variable name in grid levels plotmo grid: pclass age sibsp 2nd 28 0 > plotmo(a, type="earth", ylim=c(0, 1), caption="type=\"earth\" plotmo glm with mixed fac and non-fac degree2 terms") plotmo grid: pclass age sibsp 3rd 28 0 > plotmo(a, type="link", ylim=c(0, 1), clip=FALSE, caption="type=\"link\" plotmo glm with mixed fac and non-fac degree2 terms") plotmo grid: pclass age sibsp 3rd 28 0 > plotmo(a, type="class", ylim=c(0, 1), caption="type=\"class\" plotmo glm with mixed fac and non-fac degree2 terms") plotmo grid: pclass age sibsp 3rd 28 0 > plotmo(a, ylim=c(0, 1), caption="default type (\"response\")\nplotmo glm with mixed fac and non-fac degree2 terms") plotmo grid: pclass age sibsp 3rd 28 0 > # now with different type2s > set.seed(2016) > plotmo(a, do.par=FALSE, type2="persp", persp.theta=-20, degree1=FALSE, grid.levels=list(pclass="2nd")) > mtext("different type2s", outer=TRUE, font=2, line=1.5, cex=1) > plotmo(a, do.par=FALSE, type2="contour", degree1=FALSE, grid.levels=list(pclass="2nd")) > plotmo(a, do.par=FALSE, type2="image", degree1=FALSE, grid.levels=list(pclass="2nd"), + col.response=as.numeric(etitanic$survived)+2, pt.pch=20) > plotmo(a, do.par=FALSE, type="earth", type2="image", degree1=FALSE, + grid.levels=list(pclass="2")) > > # grid.levels with partdep > > set.seed(2018) > x1 <- (1:11) + runif(11) > x2 <- (1:11) + runif(11) > x3 <- as.integer((1:11) + runif(11)) > x4 <- runif(11) > .5 # logical > y <- x1 - x2 + x3 + x4 > data <- data.frame(y=y, x1=x1, x2=x2, x3=x3, x4=x4) > lm.x1.x2.x3 <- lm(y ~ x1 + x2 + x3 + x4 + x1*x2 + x1*x3, data=data) > cat("summary(lm.x1.x2.x3):\n") summary(lm.x1.x2.x3): > print(summary(lm.x1.x2.x3)) Warning in summary.lm(lm.x1.x2.x3) : essentially perfect fit: summary may be unreliable Call: lm(formula = y ~ x1 + x2 + x3 + x4 + x1 * x2 + x1 * x3, data = data) Residuals: 1 2 3 4 5 6 7 4.445e-17 -2.215e-16 9.227e-18 2.871e-16 2.251e-16 -9.376e-17 -5.566e-16 8 9 10 11 1.746e-17 2.252e-16 3.073e-16 -2.440e-16 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 2.142e-15 1.549e-15 1.383e+00 0.239 x1 1.000e+00 6.608e-16 1.513e+15 <2e-16 *** x2 -1.000e+00 1.816e-15 -5.507e+14 <2e-16 *** x3 1.000e+00 1.818e-15 5.502e+14 <2e-16 *** x4TRUE 1.000e+00 3.109e-16 3.216e+15 <2e-16 *** x1:x2 3.625e-16 2.328e-16 1.557e+00 0.195 x1:x3 -3.314e-16 2.274e-16 -1.458e+00 0.219 --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 4.207e-16 on 4 degrees of freedom Multiple R-squared: 1, Adjusted R-squared: 1 F-statistic: 1.326e+32 on 6 and 4 DF, p-value: < 2.2e-16 > par(mfrow = c(5, 6), mar = c(2, 3, 2, 1), mgp = c(1.5, 0.5, 0), cex = 0.6, oma=c(0,0,8,0)) > plotmo(lm.x1.x2.x3, do.par=0, ylim=c(0,16), pt.col=2, + caption="row1 default\nrow2 grid.levels=list(x3=15)\nrow3 partdep\nrow4 partdetp grid.levels=list(x3=15)") plotmo grid: x1 x2 x3 x4 6.301049 6.270736 6 TRUE > plotmo(lm.x1.x2.x3, do.par=0, ylim=c(0,16), pt.col=2, grid.levels=list(x3=15)) plotmo grid: x1 x2 x3 x4 6.301049 6.270736 15 TRUE > plotmo(lm.x1.x2.x3, do.par=0, ylim=c(0,16), pt.col=2, pmethod="partdep") calculating partdep for x1 calculating partdep for x2 calculating partdep for x3 calculating partdep for x4 calculating partdep for x1:x2 01234567890 calculating partdep for x1:x3 01234567890 > plotmo(lm.x1.x2.x3, do.par=0, ylim=c(0,16), pt.col=2, pmethod="partdep", grid.levels=list(x3=15)) calculating partdep for x1 calculating partdep for x2 calculating partdep for x3 calculating partdep for x4 calculating partdep for x1:x2 01234567890 calculating partdep for x1:x3 01234567890 > > # check auto type convert in grid.levels > plotmo(lm.x1.x2.x3, degree1="x1", degree2=0, main="x1 (x2=5L))", ylim=c(0,16), do.par=0, pmethod="partdep", grid.levels=list(x2=15L)) # integer to numeric calculating partdep for x1 > plotmo(lm.x1.x2.x3, degree1="x1", degree2=0, main="x1 (x3=5))", ylim=c(0,16), do.par=0, pmethod="partdep", grid.levels=list(x3=15)) # numeric to integer calculating partdep for x1 > plotmo(lm.x1.x2.x3, degree1="x1", degree2=0, main="x1 (x4=1))", ylim=c(0,16), do.par=0, pmethod="partdep", grid.levels=list(x4=1)) # numeric to logical calculating partdep for x1 > expect.err(try(plotmo(lm.x1.x2.x3, degree1="x1", degree2=0, main="x1 (x4=1))", ylim=c(0,16), do.par=0, pmethod="partdep", grid.levels=list(x4="x"))), "expected a logical value in grid.levels for x4") # char to logical Error : expected a logical value in grid.levels for x4 Got expected error from try(plotmo(lm.x1.x2.x3, degree1 = "x1", degree2 = 0, main = "x1 (x4=1))", ylim = c(0, 16), do.par = 0, pmethod = "partdep", grid.levels = list(x4 = "x"))) > expect.err(try(plotmo(lm.x1.x2.x3, degree1="x2", do.par=0, pmethod="partdep", grid.levels=list(x1="1"))), "the class \"character\" of \"x1\" in grid.levels does not match its class \"numeric\" in the input data") Warning: grid.levels returned class "character" for x1, so will use the default grid.func for x1 Error : the class "character" of "x1" in grid.levels does not match its class "numeric" in the input data Got expected error from try(plotmo(lm.x1.x2.x3, degree1 = "x2", do.par = 0, pmethod = "partdep", grid.levels = list(x1 = "1"))) > par(org.par) > > # test vector main > > a20 <- earth(O3 ~ humidity + temp + doy, data=ozone1, degree=2, glm=list(family=Gamma)) > > dopar(2, 2) > plotmo(a20, nrug=-1) plotmo grid: humidity temp doy 64 62 205.5 > > set.seed(2016) > plotmo(a20, nrug=10, caption="Test plotmo with a vector main (and npoints=200)", + main=c("Humidity", "Temperature", "Day of year", "Humidity: Temperature", "Temperature: Day of Year"), + col.response="darkgray", pt.pch=".", cex.response=3, npoints=200) # cex.response tests back compat plotmo grid: humidity temp doy 64 62 205.5 > > cat("Expect warning below (missing double titles)\n") Expect warning below (missing double titles) > plotmo(a20, nrug=-1, caption="Test plotmo with a vector main (and plain smooth)", + main=c("Humidity", "Temperature", "Day of year", "Humidity: Temperature", "Temp: Doy"), + smooth.col="indianred") plotmo grid: humidity temp doy 64 62 205.5 > > cat("Expect warning below (missing single titles)\n") Expect warning below (missing single titles) > plotmo(a20, nrug=-1, caption="Test plotmo with a vector main (and smooth args)", + main=c("Humidity", "Temperature"), + smooth.col="indianred", smooth.lwd=2, smooth.lty=2, smooth.f=.1, + col.response="gray", npoints=500) plotmo grid: humidity temp doy 64 62 205.5 > > plotmo(a20, nrug=-1, caption="Test plotmo with pt.pch=paste(1:nrow(ozone1))", + type2="im", + col.response=2, pt.cex=.8, pt.pch=paste(1:nrow(ozone1)), npoints=100) plotmo grid: humidity temp doy 64 62 205.5 > > aflip <- earth(O3~vh + wind + humidity + temp, data=ozone1, degree=2) > > # test all1 and all2, with and without degree1 and degree2 > plotmo(aflip, all2=T, caption="all2=T", npoints=TRUE) plotmo grid: vh wind humidity temp 5760 5 64 62 > plotmo(aflip, all2=T, degree2=c(4, 2), caption="all2=T, degree2=c(4, 2)") plotmo grid: vh wind humidity temp 5760 5 64 62 > plotmo(aflip, all1=T, caption="all1=T") plotmo grid: vh wind humidity temp 5760 5 64 62 > plotmo(aflip, all1=T, degree1=c(3,1), degree2=NA, caption="all1=T, degree1=c(3,1), degree2=NA") plotmo grid: vh wind humidity temp 5760 5 64 62 > > options(warn=2) > expect.err(try(plotmo(aflip, no.such.arg=9)), "(converted from warning) predict.earth ignored argument 'no.such.arg'") stats::predict(earth.object, NULL, type="response", no.such.arg=9) Error : (converted from warning) predict.earth ignored argument 'no.such.arg' Got expected error from try(plotmo(aflip, no.such.arg = 9)) > expect.err(try(plotmo(aflip, ycolumn=1)), "(converted from warning) predict.earth ignored argument 'ycolumn'") stats::predict(earth.object, NULL, type="response", ycolumn=1) Error : (converted from warning) predict.earth ignored argument 'ycolumn' Got expected error from try(plotmo(aflip, ycolumn = 1)) > expect.err(try(plotmo(aflip, title="abc")), "(converted from warning) predict.earth ignored argument 'title'") stats::predict(earth.object, NULL, type="response", title="abc") Error : (converted from warning) predict.earth ignored argument 'title' Got expected error from try(plotmo(aflip, title = "abc")) > expect.err(try(plotmo(aflip, persp.ticktype="d", persp.ntick=3, tic=3, tick=9)), "(converted from warning) predict.earth ignored argument 'tic'") stats::predict(earth.object, NULL, type="response", tic=3, tick=9) Error : (converted from warning) predict.earth ignored argument 'tic' Got expected error from try(plotmo(aflip, persp.ticktype = "d", persp.ntick = 3, tic = 3, tick = 9)) > expect.err(try(plotmo(aflip, persp.ticktype="d", ntick=3, tic=3)), "(converted from warning) predict.earth ignored argument 'ntick'") stats::predict(earth.object, NULL, type="response", ntick=3, tic=3) Error : (converted from warning) predict.earth ignored argument 'ntick' Got expected error from try(plotmo(aflip, persp.ticktype = "d", ntick = 3, tic = 3)) > options(warn=1) > # expect.err(try(plotmo(aflip, adj1=8, adj2=9))) # Error : plotmo: illegal argument "adj1" > # expect.err(try(plotmo(aflip, yc=8, x2=9))) # "ycolumn" is no longer legal, use "nresponse" instead > # expect.err(try(plotmo(aflip, persp.ticktype="d", ntick=3, ti=3))) # Error : "title" is illegal, use "caption" instead ("ti" taken to mean "title") > # expect.err(try(plotmo(aflip, persp.ticktype="d", ntick=3, title=3))) # Error : "title" is illegal, use "caption" instead > # expect.err(try(plotmo(aflip, persp.ticktype="d", ntick=3, tit=3, titl=7))) # Error : "title" is illegal, use "caption" instead ("tit" taken to mean "title") > # expect.err(try(plotmo(aflip, zlab="abc"))) # "zlab" is illegal, use "ylab" instead > # expect.err(try(plotmo(aflip, z="abc"))) # "zlab" is illegal, use "ylab" instead ("z" taken to mean "zlab") > expect.err(try(plotmo(aflip, degree1=c(4,1))), "'degree1' is out of range, allowed values are 1 to 2") Error : 'degree1' is out of range, allowed values are 1 to 2 Got expected error from try(plotmo(aflip, degree1 = c(4, 1))) > # expect.err(try(plotmo(aflip, none.such=TRUE))) # illegal argument "all1" > # expect.err(try(plotmo(aflip, ntick=3, type2="im"))) # the ntick argument is illegal for type2="image" > # expect.err(try(plotmo(aflip, breaks=3, type2="persp"))) # the breaks argument is illegal for type2="persp" > # expect.err(try(plotmo(aflip, breaks=99, type2="cont"))) # the breaks argument is illegal for type2="contour" > > # Test error handling when accessing the original data > > lm.bad <- lm.fit(as.matrix(ozone1[,-1]), as.matrix(ozone1[,1])) > expect.err(try(plotmo(lm.bad)), "'lm.bad' is a plain list, not an S3 model") Error : 'lm.bad' is a plain list, not an S3 model Got expected error from try(plotmo(lm.bad)) > expect.err(try(plotmo(99)), "'99' is not an S3 model") Error : '99' is not an S3 model Got expected error from try(plotmo(99)) > > x <- matrix(c(1,3,2,4,5,6,7,8,9,10, + 2,3,4,5,6,7,8,9,8,9), ncol=2) > > colnames(x) <- c("c1", "c2") > x1 <- x[,1] > x2 <- x[,2] > y <- 3:12 > df <- data.frame(y=y, x1=x1, x2=x2) > foo1 <- function() + { + a.foo1 <- lm(y~x1+x2, model=FALSE) + x1 <- NULL + expect.err(try(plotmo(a.foo1)), "cannot get the original model predictors") + } > foo1() Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: invalid type (NULL) for variable 'x1' (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(plotmo(a.foo1)) > foo2 <- function() + { + a.foo2 <- lm(y~x1+x2, data=df, model=FALSE) + df <- 99 # note that df <- NULL here will not cause an error msg + y <- 99 # also needed else model.frame in plotmo will find the global y + expect.err(try(plotmo(a.foo2)), "cannot get the original model predictors") + } > foo2() Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: variable lengths differ (found for 'x1') (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(plotmo(a.foo2)) > foo3 <- function() + { + a.foo3 <- lm(y~x) # lm() builds an lm model for which predict doesn't work + expect.err(try(plotmo(a.foo3)), "predict returned the wrong length (got 10 but expected 50)") + } > foo3() Warning: the variable on the right side of the formula is a matrix or data.frame plotmo often cannot process such variables Warning: 'newdata' had 50 rows but variables found have 10 rows Error : predict returned the wrong length (got 10 but expected 50) Got expected error from try(plotmo(a.foo3)) > foo3a <- function() + { + a.foo3a <- lm(y~x) # lm() builds an lm model for which predict doesn't work + # this tests "ngrid1 <- ngrid1 + 1" in plotmo.R + expect.err(try(plotmo(a.foo3a, ngrid1=nrow(x))), "predict returned the wrong length (got 10 but expected 11)") + } > foo3a() Warning: the variable on the right side of the formula is a matrix or data.frame plotmo often cannot process such variables Warning: 'newdata' had 11 rows but variables found have 10 rows Error : predict returned the wrong length (got 10 but expected 11) Got expected error from try(plotmo(a.foo3a, ngrid1 = nrow(x))) > foo4 <- function() + { + a.foo4 <- lm(y~x[,1]+x[,2]) # builds an lm model for which predict doesn't work + # causes 'newdata' had 8 rows but variables found have 10 rows + expect.err(try(plotmo(a.foo4)), "predict returned the wrong length (got 10 but expected 50)") + } > foo4() Warning: Cannot determine which variables to plot in degree2 plots (use all2=TRUE?) Confused by variable name "x[, 1]" Warning: 'newdata' had 50 rows but variables found have 10 rows Error : predict returned the wrong length (got 10 but expected 50) Got expected error from try(plotmo(a.foo4)) > foo5 <- function() + { + a.foo5 <- lm(y~x1+x2, model=FALSE) + x1 <- c(1,2,3) + # causes Error in model.frame.default: variable lengths differ (found for 'x1') + expect.err(try(plotmo(a.foo5)), "cannot get the original model predictors") + } > foo5() Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: variable lengths differ (found for 'x1') (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(plotmo(a.foo5)) > foo6 <- function() + { + a.foo6 <- lm(y~x1+x2, model=FALSE) + y[1] <- NA + # Error in na.fail.default: missing values in object + expect.err(try(plotmo(a.foo6, col.response=3)), "cannot get the original model predictors") + } > foo6() Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: missing values in object (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(plotmo(a.foo6, col.response = 3)) > foo7 <- function() + { + a.foo7 <- lm(y~x1+x2, model=FALSE) + y[1] <- Inf + options <- options("warn") + on.exit(options(warn=options$warn)) + options(warn=2) + expect.err(try(plotmo(a.foo7, col.response=3)), "non-finite values returned by plotmo_y") + } > foo7() Error : (converted from warning) non-finite values returned by plotmo_y Got expected error from try(plotmo(a.foo7, col.response = 3)) > options(warn=1) > foo8 <- function() + { + i <- 1 + a.foo8 <- lm(y~x[,i]+x[,2]) + options <- options("warn") + on.exit(options(warn=options$warn)) + options(warn=2) + expect.err(try(plotmo(a.foo8)), "Cannot determine which variables to plot in degree2 plots (use all2=TRUE?)") + options(warn=options$warn) + expect.err(try(plotmo(a.foo8)), "predict returned the wrong length (got 10 but expected 50)") + } > foo8() Error : (converted from warning) Cannot determine which variables to plot in degree2 plots (use all2=TRUE?) Confused by variable name "x[, i]" Got expected error from try(plotmo(a.foo8)) Warning: Cannot determine which variables to plot in degree2 plots (use all2=TRUE?) Confused by variable name "x[, i]" Warning: 'newdata' had 50 rows but variables found have 10 rows Error : predict returned the wrong length (got 10 but expected 50) Got expected error from try(plotmo(a.foo8)) > options(warn=1) > foo9 <- function() + { + my.list <- list(j=2) + a.foo9 <- lm(y~x[,1]+x[,my.list$j]) + expect.err(try(plotmo(a.foo9)), "cannot get the original model predictors") + } > foo9() Warning: "$" in the formula is not supported by plotmo, will try to get the data elsewhere formula: x[, 1] + x[, my.list$j] Looked unsuccessfully for the original predictors in the following places: (1) object$x: NULL (2) model.frame: formula(object): "$" in formula is not allowed (3) getCall(object)$x: NULL Error : cannot get the original model predictors Got expected error from try(plotmo(a.foo9)) > foo9a <- function() + { + df <- data.frame(y=y, x1=x[,1], x2=x[,2]) + a.foo9a <- lm(y~x1+x2, data=df) + par(mfrow = c(2, 2), oma=c(0,0,4,0)) + set.seed(2018) + plotmo(a.foo9a, col.resp=2, do.par=FALSE, + caption="top two plots should be identical to bottom two plots") + x2 <- rep(99, length(x2)) + a.foo9b <- lm(y~x1+x2, data=df) + x2 <- rep(199, length(x2)) + plotmo(a.foo9b, col.resp=2, do.par=FALSE) + } > foo9a() plotmo grid: x1 x2 5.5 6.5 plotmo grid: x1 x2 5.5 6.5 > par(org.par) > > foo20.func <- function() + { + par(mfrow = c(2, 2), oma=c(0,0,4,0)) + foo20 <- lm(y~x1+x2) + set.seed(2018) + plotmo(foo20, degree1=1:2, col.resp=2, do.par=FALSE, + caption="top two plots should be identical to bottom two plots\nbecause we use saved lm$model") + x1 <- 99 + plotmo(foo20, degree1=1:2, col.resp=2, do.par=FALSE) + } > foo20.func() plotmo grid: x1 x2 5.5 6.5 plotmo grid: x1 x2 5.5 6.5 > par(org.par) > > set.seed(1235) > tit <- etitanic > tit <- tit[c(30:80,330:380,630:680), ] > a <- earth(survived~., data=tit, glm=list(family=binomial), degree=2) > plotmo(a, grid.levels=list(sex="ma"), + caption="smooth: survived, sex=\"m\" jitter=1", + smooth.col="indianred", smooth.lwd=2, + col.response=as.numeric(tit$survived)+2, pt.pch=".", type2="im", + pt.cex=3, jitter=1) # big jitter plotmo grid: pclass sex age sibsp parch 1st male 29 0 0 > set.seed(1238) > a <- earth(pclass~., data=tit) > plotmo(a, type="class", nresponse=1, + grid.levels=list(sex="ma"), + caption="smooth: pclass, sex=\"m\"", SHOWCALL=TRUE, + smooth.col="indianred", smooth.lwd=2, + col.response=as.numeric(tit$pclass)+1, type2="im", + pt.pch=".", pt.cex=3) plotmo grid: survived sex age sibsp parch 0 male 29 0 0 > plotmo(a, type="class", nresponse=1, + grid.levels=list(sex="ma"), + caption="smooth: pclass, sex=\"m\" jitter=.3", SHOWCALL=TRUE, + smooth.col="indianred", smooth.lwd=2, + col.response=as.numeric(tit$pclass)+1, type2="im", + pt.pch="x", jit=.3) # small jitter plotmo grid: survived sex age sibsp parch 0 male 29 0 0 > plotmo(a, nresponse=1, + type="class", grid.levels=list(sex="ma"), + caption="smooth: pclass, sex=\"m\"", SHOWCALL=TRUE, + smooth.col="indianred", smooth.lwd=2, + col.response=as.numeric(tit$pclass)+1, type2="im", + pt.pch=paste(1:nrow(tit))) plotmo grid: survived sex age sibsp parch 0 male 29 0 0 > > # test the extend argument > > plotmo(a, nresponse=1, pt.col=2, degree2=0, SHOWCALL=TRUE, + caption="test extend: extend=0 (reference plot)") plotmo grid: survived sex age sibsp parch 0 male 29 0 0 > plotmo(a, nresponse=1, extend=.5, pt.col=2, SHOWCALL=TRUE, + caption="test extend: extend=.5") plotmo grid: survived sex age sibsp parch 0 male 29 0 0 > plotmo(a, nresponse=1, degree1=0, extend=.2, pt.col=2, SHOWCALL=TRUE) # nothing to plot Warning: plotmo: nothing to plot > > a <- earth(survived~pclass+age, data=etitanic, degree=2) > # expect warning: extend=.5 not degree2 plots > plotmo(a, extend=.5, pt.col=2, SHOWCALL=TRUE, + caption="test extend: extend=.5") Warning: extend=0.5: will not plot degree2 plots (extend is not yet implemented for degree2 plots) plotmo grid: pclass age 3rd 28 > > # intercept only models > > dopar(2, 2, caption = "intercept-only models") intercept-only models > set.seed(1) > x <- 1:10 > y <- runif(length(x)) > earth.intercept.only <- earth(x, y) > plotmo(earth.intercept.only, do.par=FALSE, main="earth intercept-only model") > plotmo(earth.intercept.only, do.par=FALSE, col.response=1, pt.pch=20) > # TODO following draws a plot but it shouldn't (very minor bug because int-only model with a bad degree1 spec) > plotmo(earth.intercept.only, do.par=FALSE, degree1=3) # expect warning: 'degree1' specified but no degree1 plots Warning: 'degree1' specified but no degree1 plots (maybe use all1=TRUE?) > plotmo(earth.intercept.only, do.par=FALSE, degree1=0) # expect warning: plotmo: nothing to plot Warning: plotmo: nothing to plot > library(rpart) > rpart.intercept.only <- rpart(y~x) > plotmo(rpart.intercept.only, do.par=FALSE, main="rpart.plot intercept-only model") > plotmo(rpart.intercept.only, do.par=FALSE, degree1=0) Warning: plotmo: nothing to plot > par(org.par) > > # nrug argument > > par(mfrow=c(3,3), mar=c(3,3,3,1), mgp=c(1.5, 0.5, 0)) > mod.nrug <- earth(survived~age, data=etitanic) > set.seed(2016) > plotmo(mod.nrug, do.par=0, nrug=-1, main="nrug=-1") > plotmo(mod.nrug, do.par=0, nrug=TRUE, main="nrug=TRUE") > plotmo(mod.nrug, do.par=0, nrug=10, rug.col=2, main="nrug=10, rug.col=2") > plotmo(mod.nrug, do.par=0, nrug=5, rug.col=2, rug.lwd=2, main="nrug=5, rug.col=2, rug.lwd=2") > plotmo(mod.nrug, do.par=0, nrug="density", main="nrug=\"density\"") > plotmo(mod.nrug, do.par=0, nrug="density", density.col=2, density.lwd=2, main="nrug=\"density\"\ndensity.col=2, density.lwd=2") > plotmo(mod.nrug, do.par=0, nrug="density", density.adj=.2, density.col=1, main="nrug=\"density\"\ndensity.adj=.2, density.col=1") > par(org.par) > > # a <- earth(ozone1[,3]~ozone1[,1]+ozone1[,2]+ozone1[,4]+ozone1[,5]+ozone1[,6], data=ozone1) > # # TODO fails: actual.nrows=330 expected.nrows=50 fitted.nrows=330 > # plotmo(a) > > # # TODO following fails in plotmo with > # # Error : get.earth.x from model.matrix.earth from predict.earth: x has 2 columns, expected 4 to match: 1 2 3 Girth > # a <- earth(Volume~poly(Height, degree=3)+Girth, data=trees, subset=4:23, linpreds=TRUE) > # plotmo(a, trace=-1, do.par=FALSE, caption="all three rows should be the same") > > source("test.epilog.R") plotmo/inst/README-figures/0000755000176200001440000000000014334575431015151 5ustar liggesusersplotmo/inst/README-figures/plotmo-randomForest.png0000644000176200001440000004724613276542471021651 0ustar liggesusersPNG  IHDR? IDATxkwg>f1k^HxwNt) dqƘ 0AƜ AJ0 N)sj;;ݻWxg!5_-=~\'K*oTJR򭻞RTU%V6B! `#,6B! `#,6B! `#,6B! `#,6B! `#,6B! `#,6B! `#,6B! `#,F1"ƲYҡCz,dr/ˮ},@ec^WZKF*HZ鐢#3MD3֢tH'oN9L:)Hy=>i^imz@6 ٘7 ԼLCDyUUSA"Ęyud<2Q|dh- >jq뙋m~Ưl έŧcxg1CX| ע& Y({ !5/sY },k)? |:f+տeC1M؞??!+ɭH_#}'ǂ<̠ !L Ι~ _g.q>䰜%&nzƋ`kczf+֟Nx"/6|`//LBVnA43xdː~kVCK59)Kk&!k=se0ty%q7y&2/'f]/ :Z|%}3#f6O'kLQ0535wHLVA[F'Vu߹J,ʐᾸM(~Qş+RWx\,\#)L>>t"͘D-KC7o8R272Wgr5[}3S 0$k θ!~DUR>q)Yxq{R8鳶tJЭf?JF">t ,3d0nw$6l2mpEd m6̨Dsը'knX=}K]`8\ɤ)mT6]ӱuzfKN)]`/_<̌΢/>c`V}[Kqc$MgDh&Vk>/>}ɗYQ5ӱ55I%LEDdCQUP ֲ1{`j6ʡ9wH>ĬlZZȨcM daA_Jtȟh԰W`: .*Y!dlBFY!dlBFY!dlBFY!dIϖy[y,Cg&ߚyqFhlyjV]@J91_\՞7ܩJy >X&I ]vA3!BnMeM) Y1^\COGQBlOQŸ{,)aVr)wk&g.>1o~+Wq뤀5f;ex3)94fO E&<ь6]TL~'eI%p{(Ni+ƼE3tj,fq !}OAQsf!m87CK@raYr7YLM c0xb5q+p2oLABV.Yx$TOfz#Ͽ kt(l輩,ؼ11Yl660)j&:JknLl%ɝMݹV"k$_ĎzXHEpL7{-`1l}41;۶Xg>v (D6EqG&JYO ՠf , ӰO*H.fxjLq+iR0b3Kec^wd(*v;5GQU;+J@d5lb7f\F%he 5gJ]@)U66.5&7k^s~#0 k,8uȺ(,+h[ k,8N _٘=՟;_: 45(m@U:a^a*5zublBFY+(BE! `*6BPI[! `Z^#dlҗew O0q8,mDC #dR^[! sgʰt(wt$J(mӂTX(YI [FUɦCMUUUUm,tXc9Jm,XƂRPNDܡ9gg SDC?A'j k,*kThP-% XUkM~BF6l;Vͫ|)k,8ufc oXp>8!@Xp>8!njꋏR[[e(X(V6~Z+<Hů.Wx4@/@Ƃb@Ij:a*.ujW! `#,6BR͞Y!dlBFYCjBFY!dl.G_C! `#,6* 828XIQq.d~XXcaVs[eZ{Xca(]nP`b,DDgI` k,Qs^9[I)ݣP=NXc< ^*Z6VYkVxkŎ.o;Ƽӛօ,(@`8;u CaƂ;W[Ǽu5:dM4P.8! n Āsaǩf\ *5vgZs_M,6B! `#,6B! `#,6B@cs>BFY!dlBF!N?=β 5J6hʨ*gYXKQS M4eI5)8^OߜB!;q5m^&au$|"gg_[hOP0) 4e.ݣ8{6h,NXc 0R? PpB[2(b uO؂oad4ND'skUXϯ$GѬe5xᒾ`) 'w<.sڣ1[__ɚx傯Q?k7~)tU]0|f%'\k᭚be WY9;W@з.R yB0}Gu@KzEJqu+]2= U\*zoT1 |*ye6}6X],j }gkl1ߥN .As*o_;(Kw֣aH̺(ʬcߊhѻT=Ll(`噋k}UQMƼm4:vY0F1gm}-.OTaǰ-Aʾ{%SSϮ5X+T7Wx4n fkV|,OGm,SLTL}BVVyc]rH[[(dO$e|ePֆ![Xj9k7{C4@5b.&@ TRKj Q d;~7(,mDY)~YoYkR(TB-UD1`lWAɬ+t멄pB{p^c-ԐgrAjCM@[r+1sa('nLWXcyPVBv"M)jr 8NXEnEL)5N!e)3vz*]ƚ/$ITU ! UTɎ(8blec@ֹ ! 0mbP0n6B! `#,6B! `#,6B! `#,6Qv$kXc6jqF7D\*.Tmq:|h! `#*Y!dl!yo,KDDuy8aߩP!K_/AUm )PVF9D:(2KeoKWXbJ]kf:~+zjh 7J`PbWȦC2*OFfj¦' $(WşRE""w'ؚ{\yyFyVUUQjwF9/{c*_BjVdӚaEus{&+_B]ZŇNygY"J%䢼V߿T͌]u_$"rkN*d_N6sR59u_K4>*|[BJKXdϚ߹CNP_ ]{K'KED=R%H0VKGToKXz*U*حFFY!dlBFY!dlBFY!dlBFY!dlBFY!dlBFY!dll l̫(J(m4V!LOoƼR`2d!I|qUU㾂C-K;Mzd((i!qYSzC!o~t̫WM1y)%Ƽ%ǒeu<,+=t]܂S@f_y5>Aa"rgdӨ?կj*W6D3JtwSA" xOCS"J%tO(vec^wUUS{: .af_a}z<5~,OEY>"r7y&_JaYr"75hhciʾ=eAzd~X>. .Xnvqf_֓ɼ~LM䢱[Q[ eLvk\ u̔&+NفI4{HO4 ji8ξ !+ן ZH>sw,'&rMq`F\3p@AY>FMUF=wn?ܶ=i~Wx<~;2L_ȒyMQܑ Ot{@){tH')yO4SB$mPN6U),P! `#,6B(U SդS._&.vA9%+*߷~l 0+NKwD 0+]0<-Ѹ5_5b&3MQLgPޒ@}->L+) pϙ)=]SG͞vAuE'l ~@#j5*Ϛb^ (=f)?'?ヷ~?=374e}1M1_{!ɟ,J?蓟QƽEYa7=xHlpZo2~wg\2jH^el*(8l݋S2V~w1s}Dw8},VQN?S吝ao~Wy /j̖vA-WH ʸ-ozRlī7dnb$Իĭ"`}9#C plRvEѧ4p,\A\f۲Ű0>Jqt:ةd+0~2V?]PT!\qwrp>N߽aqwMǠ᠟PFfuClfe,m;6q1w(F!_ mYٺ)QV}9J+g" ]&Wzu8vA}C$). #?;}8RWӣܿ]O}dk?vxsl{?TnC!de+!۾ wI8^X;i ƒ"[?>u> WrDQ?^ۢ tt~i}*b<@-kG}JD wo-hZr9dk(^Avu-lؾgO>S5*{#Ne쎷_W0L-5&mCUԞNX({W߽HS6ؾ.B1~q޲tNX"ڵ5Qn:TʲT Y6l1O7,f5}΋WԽ/9gl]sޗy &;}l+W?@rϞ_Vm_|ƕ"[m\)w _姼O s*Yݭ;ﾸG3u(uzwC ]![oZܐA+>d?9^?zh:4.fifkkDTj[m_ Y>JU7kjY "aH3w%'lCpn q/w8jcշ~9x-c GqUQ Y)Vַ~ҍm/Zj2+@5@R95  ??Oi;pKWҍm7G-&a+;ç A8D~h_[={-2? a픧\ط3_UMV5NCQw7^[#__-N! @.:]/|b/TC1H IDATu 1![Ek7xP 0aǟlvohD U)]Ѹfk}_WͶ}Y+![N_ ~J[K, WPrOgyC(+Yu޼el XJݹU$zl,I?ϢՓ}Ĭ!+k|!<̞%iSX{߉ÛWS^(s]͖=A5j*y#h}1`}Wű8m*fKk=dm^J}' e}CEXZ(ci1Cf4dFdO}IMC[ej;r=? ZsoO TIfc|e(y4lXV< Uk^<#$4BH l|9{#D2mlDek eE`͚#rɍ=Ņ2`֫ d}q5!IOEDT˧!c`;EGBC_ѯ/}ќ{|7,{c2АU'9o繈S/ Jfevoy:Z?b{뿿Fsyw%]|_?|Ԛ=XYҐMeU/I\+z2Zq/ޒ'eܖe|DZ,8bXLsGZUygY"J%apUNbY Yf+ط Vhƶ۸e,z5^ZDt7}|8| cQk֍51rG +hN3hƇW?*.dK:! H1`eGT0wHS͜e-t[V=}9>x 5X%{ԑ많'ŬU$(f/t eіO ͿG,y{Ś??q^j4$eg<]Փsְ=xm|vy{rw.cree٪$lcACC֐Wַa/һv_5uϚ49 kX$',q./1JNEӷa [b 6{۶G8|J-^VlI{}=ñ\-N?1gxj1*tHkUgjϞej5?ͨaW:Zt1+7 !>Ҟnbʚٵ]}Dtg]`֓5d1Zr˗^k'/ۏR~[cկ1,@1hdc/[U5䯿Z\Dk;_i~ ˗G:]Lq@"aKw[^$HX޹V.c{SڼnKccW%;B4qz)UշUUW .P-'{V[,D9[q ؾ㷿Q#V؃,ch,e&TU-KSS̎uֶ؍''S>9y(tYӏ4-˅I8^W5w)V>v{@"d]'ϲDKx%ޝu\kZD9)c7w0{[[y\~q%:W3gvn?8Y+3+f iACH5'닧!D3qܥlx-DQ?-ۻn XNXͫ:/^% v9p?|ND=kĶךa[2c4ӹ]cZg/d]s )8^˟mY/ED"a {֙[EmEwe l8s+*{mךȰ%"MgvKO<ƀ;.;#h)^f+6쟿|[pӥ.ܖ;7 x9gY#k-> }rmP8BVUU}g@N"O/8a8a3;Fе2[k墮"C#[fzmQjv8B֐mXk$~]Lm_"^{ Szs؂{zց>cqz,s\Zw`8g/c =9%"r1{a v󘈾{xt JP8OC𘇲G.px5X|?5ږel 厁HX}{Ad~w>RpſLK&'ovsG2zfW[yŬ&a-h'gWo^9+N^?ulۗ |?qyHXF ;wJQִeͶ}1bVY$Ƣgg@D$ZS9A.]IJXaWoY"bb"{݋gv&M}:8RCVooߏ)4=GTB㵘9/e76wLה(aٛ-. %W3޲zKw?;!ٶGD@&Җ7,ǫsV_@}9WUU/˗]۷fgX?e,]~˝SϢ2v7c576tE@&"aq1g9j}jg7IDɑ DdV"|K_2XUZrPKfXʸAX;7åojݫlwhՎܡ^Vo.(bjO/=7{✕>5|PXZ߃ӡ-ݱ@Yh(Sb[UU-eX">XMš;|!qtKB@D[GϝWGϝ_h/Oe rS./mu:OClݱG-vsP%[\̚4kwG4Ŭl|ױ>Nks[=' 4 +<,w.ˇ<Ɨo3\ZNX"(^DKpNeTPa6?nZ(;)6"g?RE zx5fwcE%c+r秏yؖ+6֬=0;K[9^y!wijأmɛ#'y~X5pwSkWttdÑzqv-|MԹ=]K%M 9wtAb[g>{һ~&g5ՙ޵c~n R%xԙ;7sNo 9D߀ցhP۵~9[%"Y"V{ooܢE͡( Yp'bY%>˺!c+M%=h9y%"a %"9d `99r3|RcǶ/t\m\yhJց/{|N_QEQuޭ&"rk'ϲDKn!+ hrVNkXYluա)_$ݏ|s㕧͙k\̊x=?24a$}ܬ09(\--w̓o de\.g}V<^'Me"gEˎH>]?s6ֳ'ֳ;vrQ%"Y9j9aEt9QGȹ`Xw!̜UIDAT |M&/ ŬHU2Vto X;a_\q[D +om'7d>rF XE&G. +^a7-e%yf2Ϫdضwo]e2-iiEw0aI:wYP$,@[y@Ȼ~jٛx/U};pqU\e,-_qAy"g5 [vw9,IGh߅+;wVIML',ld>•(P7qѹ_s|7 }•}Ѿ Wh8aHWdf k9U' $Nӌik*g*2:G'ebְQ`X&^͊YWA.fEu)ʗg2 4eTse˸t3k/&7Vq_9InjZb/ӊ+ k(q?qb猀ŬaS%-ջ>K&_D5dӡ>J/S&=F]EU!hyh(c}5|a#Ü=u-_Xa7_x>gE18KD;<} Y_Ϛ;{~͹a4fԫ 6i?h9ƕi@ JRs]x٘3;NJ8ŬE®  kֵ|,|Rop~.`Ej\usWfǝ"*VC+UBl6Kg4V,&0:xS1rOsjJ{<=NXya+a#yʚ^Q2g>*i{&qQ+'nl,9A [۳/mIq$I%h뉚<ٗAS!ZOO {Ufeط_HXCr1{7r7o9g9^\YÄ-/ƼhC411WG%d}CCDb$LM$ LYýWfQF{D{ ?' XN[9a)fM1˗x9;|3s9#\o "Wx<P/&qGRkSl덍귁Ԥ;WCH"8/nz&LNYJk~12=af⽧%]e(8h9yϚ%"aSev'pyY+Q6m#?s[*9C2Q g^zO$Nh[1 9 kx/iպWuX(OZ49 KD9gg֏iWx<zc_Ot-]|6г,!ed>[2֚?L6՟TFTHOcANسGV.C"a m>tk7_صb#78y~f}e+<H&)8룻( W?J9zvڌeVt DvHD#}2/;ç5LX۲gH{]Գ'yݠ1o#Q[pAFDP(M|.8g+'#',6 ȼ_~Iڻ8ya JhTEg~|yP:I㜕ô^{pIr;'-.nŲ4zZEo%2]DٗI#S _.>s5m5K {|9g58s5 [NN6mKUGr>]xC@}+YTl*os5gIJX fel犅<]$,_m&֐(f;;r XeW6KsJ|0-_<+<>:/h.jBSV.f'5vwhR$,_svqQ&\̊ztOj'}@b֢Adrq1[ g NӁ~1KXGD6w4X"ʏ!z`@U̕׌q1*Nӭ/N9a bVE 혝wBӻp̚2W6|iFE{p29 b.y>a#(l5PqEL8J!mD%u gstT̚հ4 e(OZf{|T fNaك\=,e J0=Ӡ}ޝ (6[CH9^BimW4NDe {勋;tpYXfc^mbc4(`/vع+%hBb`EAÑp$35+vcE [ \0ۡgO0YÄ[Jf[H(`x'[ _2JXG*Y-,E܁-]W(Bր@ X4c(`*%6.!dlBFY!dlBFY!dlBFY!dlBFY!dlr6~҃IENDB`plotmo/inst/README-figures/plotres-glmnet-gbm.png0000644000176200001440000002607213276123320021373 0ustar liggesusersPNG  IHDR{CPLTE:f::::fffff:fՐ::::f::::::f:::ff:f::::::f:f:Ր:ff:ffff:f::f:ff:fffffffff:ffffՐfttttttttt֍ttt::::fff:f:۶ېېttttff:f:fېt6f7]̀ӥt6f]f]բ֫ې:ېې:66:6f]:]]:]f鼍:f:::::::f:f::::f:ff:f:f::fff:ӥ֫fې۶fϪT IDATx흋$GY{o9u]`HEț(1Y<Aaa+ XEH B9ACs$ []U=]U]5г;5U=3ꪄ H$}, ʋD ʋD ʋD ʋDKwʌv?jU#Q;JP!ks48.:I~g ـgyE3<[~m?Ap2%ʛr=lEyb "ӏZ.-yTcdwOeܦ?QǞ b}(oJztG3]˂w t Z쁼G"ҟryb*ʣJ.˱,yCy$//Jh Jq, NJ }t @y5yG/==v%?'oM"8h-/<~{AW|$cYpOU&[z`cAO/W, diZpe LB b ZpeKo"B'V*k7cYp^bY[x"Y;DV"т"т"т"т"т"т"т"т"т"т"=Na‘)2"(/-;bι8I6 *-v|'Y>E,̎n 6vo "=18eLA]&2Je iڀàE^O=gO3yۈ=HW␗z"Z޴H{x$y`hEJڐyD"/MX/ S|bH{x$ty|&- rhU&ˈ?–A@yhAyhAyhAyhAylCn&O])0kgǏ|<| -~3_Ÿ~ ! ~005' {ُb#[LWB|6?G<|둾&/|gw_%"뿦3*~yoijɃO8"?, To[ZA7JXM7ڴA;b# _d'ϴB7~ۿV卐ogaWlEW?ۤƒAz=sM yEt6)8fwe{yh Y{}^Ǐj^ >C/$z3B;Uyٔ`%+&eGV^_F4)_oR@ޫ7'Yv%Ҿr%;#6,W^&hvޓveģũVj/lDN 1IhpgȔӍBW/mw_K3mTЂǾFCVԥ!/#5̃o SYݫx:$bcy 5:xFJ[L /9o*yX)B\ h]y2l}kOe:x"/{T-k*o-rߚ{+$H|[ym"2켮R-gͪ3C>E[+$H| 7l2=p׏y*ˈGP"㼬#6A^nm3zנRv-ՔgP^w]o]+ :P^ (JL格P^2Ey,7^Ay7L|*ࡕknAHK?lv%A2m14}Gy Ay2r{Q^tg~6o51+,4`押DoM H#.+%(!Qbw-Ͷg7(UoM@&|6~of~pwS0mоR(\:,MnByxkNTi .f7'֙m%ۣ҆W[EgQz,{0-f^(o"0kړn95A^BY^EE(PͱlJ?m (2u5J6Ə>v0C߳G%Ic> ŻSn1PomZ: ]e"o9/4.N탼Z)xK;Cevd*m~g5s*dS n_@^* /MJ,0 ˛w?ܶ9Kț+"oD^HWX<-\Nmm44dڰsdEy./ /;Njbͦ<׏%O( Q^fswy ϞaPhB^[7]y}\v7late  3mXۃ 5I(/UG4W\Ѵvg zTwHF ۃۗP<^f!owu'[&rAɫ`F\+߆LwGݕa`[%+5YAy۟ilAœ#o+ɟȫ2̃o⚤P\+J')ߞu./[isryuWiW_{@WF^K+윝bU^㏦XWY^e-;c19~Ci+b8r^Ygm6` a+ÒVG^^Mww+ÒVE}maGzn0Yc+"o޾堼[ y aWq /mXf4t#oVi _Y^`~0xYn~؊n+n1r"/d!'Hy=/^.N(SiYnvQ8WO.*u3b6e ̮ׄx>bc#/Kߴ!Ր_P# ɛedڥzcNsڌ N]Ws\`YmPR<yWS7 )_)%||By9o1BQPo,fy%( @Sѥ*f9ڣ{ySYɮ$oX?Ȇ{WSw2(#_M*/aXT7Pw&BERޞKŖY:(\]-xmGl A[hp[gm8s+Jzb=nzOzׁV<ãx;2yY\'s->3ū>ӆr8 ])WW nnYTg?&Bt8we⩉\D^> &}񢄘Bt8by'p{ywZP%Dye9/wʆSߗG+/ q-ڥpZP%ĴA\wgQ::}jqB,8 <j/UʫBHeDZ k2Y)Fwy-V#Ə﮿]TuJ޶(o>mEi_{1o@y8nk?LzQF7\p~^U^UUEE o.qM, Z!^XEy_:F^=f'1 ya$4J Wy7EwQ^%F >XA\*?l%xB|VPyP4%wQ^K`Xt;+yG,1.k`țbD~Li>7 )^ JފÔw|#.m0 >XA^N)G|`:AXV؟ ףfiB0nZ"ypK(/=O[ Ak-`mao8yew ͯx#E)oM4+gm.WJM*6A۲1orVm{wS R޶ Ju6Hʊ Uʫtl靴 bP;?IW4\vw J{Q^ ‡j2%ÔwȋDnçlVMSK櫐6tdtq)jmDyxmh\,eb+j 9:%(Q'X 6 jB^ʈ 7ğ6Lq?i1,L5ѻӆW17rwmd-;m(o\_?鿫LvUHZ5jO!DP^y+t"Aʋi1slwk44f?Aya1m`Rt"Fi0}%҆iQeJXX*ϤwUCc ( ir64UsS8K߽zA(ץF.q 򶊼~+6~Boo-?kFx8,B [BaHd=J4ʫiS?ak{PQ^! ҶZm qUV?4ÛP^1 0Fȫ :j&%y=W!mcz gjV p&\rujkZ^wVB0)ߎ´jV&<_{UgSryxU2^kʍΏCO ܃X8ӆ2{w˻,Jy~OMW6ݧf T[ɥ|]]jyMAM ͯ=me 6.a9wZfmL86k֌Y6VE9o5l"lHd5ӆ) }(o36Pj,K"6EO^ʈ۠DPbk 9Gy=WjƜ[aa`&qӉմc+/Ͻe+l?WI͞jPAZR-D{jVQ^e+/'YϘ jyIyHD{jQ !ۗ@ y5]"oXDD{jZ*GUA`#m0hPB%opJ[hOWM@TT }Oy;?Viw!͞ô!kK2𞮺Pow{ #u/ۋ#m_Kzůx#F+*d5҆q˴.zJp ֺʨ-Ry}ػ ۜyi-a_* NJObڠan.kUK^? q _s{y=G[7/odZ^_B붔'avI6Y y۞o#oi=*/ ųj,ɋi CcK]硎wiRy(o{ou&o/Bkyw."굇- i;S+-Oټ#y/˸{F.tWgcj\uU+oyOO7IAy Q8j1:wuZ\O{o$ӧR!?Ek0zQF/ћou oajK^C'7_^ءũ}O=D^ğ6KkRX7u}-!_'74Ot׵˛ݻfxrZ@eo7 m~7  `|Y;\ZRW,v]ț}3C'1_`3G3gϚG6TO-^@`y5K噽'ӴጱYmcO8%P(˿Ykn/ǟËkÁ*IQ i¦x7{b0il0mO6=KafKU\FF-D_6t{-9ѩ:IfOif@IIގf-ҽU{5s5{8 kH"l9g.f5v&p UUHW>G7~l@ɨY)hй^ʊ5$7!_B /<>EyT=)t7@{hͳt~%"o.zk{1mPMބ2'4{alÿ?H r*[$DboX;|@W,45%{i/ ,;B 'n|K*Jӕ(oWfo@ r2j:jXݮ!L{1mTMnހ6fW*:a\ՂZ *cey 2WzEQ' d̡vN@^!LuM˺m&0b"e- { W}k`s\jô^5ì!k[NrH L<$kj{C7!^qoJopn/ʫٛ&:dop'Ŵj5`o>HT O^R^n5K34g Qd9sӥ鞚Mkw'{w2Vӥ ԾZocu 8mDy#xm'>> T޶#Dx*.y&ްU^"ڎ:IJLj(!Py5{m;Ik[oPV}0vȒ#aD'27? [>ɛϜ dCy˞vi(>yC|C${?Lv7 z56J J"Wbogss'Bw`b_o>ҺwP2FbW̛^T_aBniC}Ma% Q+ 'qoӐ{m{t,.Z*Cg3"n/9ImI0Û?6j3oy`ř[*^r 96w~"vuw8Ih V^u-p&c:;ǡÁ|[hH|^(ꏑ[ڵ +9mci~67OOI]_Ňس"WŤN(RyԀyͨ.ߪٱ˷B)/E‡b[^*ē $b}q̤ˢ^9m */X^֗>{lj Ζ集_+IxbowvQ+k@N;Dsy:l䫾r}= )j}W-7XjZ+6]z"TS@.,{S8S[Y9]bjf(m_R^i<`}˂nbV2 '/ªkoڃ&2evvޓi;;h6N~#r}–зe's6WŻ\޺@+3)mf!eev뙵OZRC'<x)]"tWH^U[u%j}_%5KZ *k.孏 /WKR,nwALm%q,/ц_jP.YM#yIC5Lh A7ŧoXK*+_:mH>Y+XhW@,E;E#]w[n~^"`DZm8yk[1{ \` B"H!-lI( LIDATViC*/qxr뿬D.m`%_-axw GV*5XI[lJzv^}ZVfow2T ,Z^_nN!K%HmKWYpfhi'eM D^b@H8YEo"/WmzYK)\fsUa7m(M X+72(yI!u Q^{ V ,ݯF;[G*]׀*vS|hKY֕kￎjvj05;"ݥ|*f)N?v֛"7j 71 ?)G^m0k)2ۥ’o[=+Zo l K]2s 0k).}7YCRvJo6i%k)jrߛJ’r fW`HFy7 K$$Fy7fyNJ%(=l5"@yQhY[ QN2ٹ[I[hrZ]A qbR_zO(/2/>2?Of7}cc߀X[.rh]X*mc󞤩eqoP^%"rZ 1Hy.ե lЂ/_^Xʖ=ճ5M[mm Ip 0be|]QOScPOi56Gd37yztjn>mO ӯ]a;h  z γ 5QiT(~ͱCF;ZH~ލw~ލw~$8Pް݈q8)f崕D9NN>,~"ʩQ|R|R1O[_:2PbxAyF{R (r)Ya^N[O3ZM7v'5 ʥ䅡QvY sBi YsE-ĉr Ar)ya&AeLcM*,ѮkP)gP_>2P<'Xy{Izƹv11{a0tI11o(;ęQ[50JItP]\trg[eyY;mmг 8*wh(";hq\Cq\J^8M/+Nj;)2,[rXY|1yw?&+iڰ I?/ Xi:OW_ZN2i/oZN_<r"R#(/KfGmyEz{B)m`[I"=ʛg`禬7am$/+E{#{“2gύh:ڝRpV3 U&v&Mq])== e]5Ei+h*lATZFs_dt=X֦6zZzotԜ$~S}ŸDaI]j y6 GǏ؆ 'HӌذReORbgLH; Sώ 6ؕJXD>_"J6vض\+pZT~ w@p/QEPKS3e {ZOO<; DzasQ^\Y /6E-aN$yeyD@*jaoEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE5:IENDB`plotmo/inst/README-figures/plotres-randomForest.png0000644000176200001440000002376213304026714022011 0ustar liggesusersPNG  IHDRvvPLTE:f:::f:fff::::f::::f:::ff:f:f:::ff:fff:f::f:ff:ff:fffffffff::::ff:fې۶ېff:ff:ff۶ېې:ېfې۶fې۶:f::f:ff:fff:fېlY] IDATx {u+u͌\$;Mcej7R.nj{<7 s b쎆$xFjR1)fA"`$YfA"`$YfA"))eUUn=z=!ctS [96ш G^fqiO Pmű,^-)!̃"g[Y9` q.XfW`'S_PN~c1;l\1P* PKC<Q 9<*CDX| х+LkE옥,*ɲAeAa)QU -ZMn&G-&M4ZPDݙ|R6汩Xbx괧1=cw_6uwNmSgS.X󏣴Ra=1(s#]LhкV]Ldf!e6Rk+ p227Ul] ΅ X卌 ϠLbFw?.dվؤJ).V%>L uJM=l%n6îbPqFsG&fZ&SL Cr f`hCfgm$VkM6]Ŭ|F4L{i٫39US.$]LhкVZ!a6٦wbF~2DN*#dAVAK7 snnkA12Eedt\D)S߅vB0jV7^:3j"ŽK jÜ]|!жAU?]w!#6ڮ^N d$e"YfAYQṱF1kLī(IX+`0#*A d^yu26y^%51b^q>W#Ÿ"u08χ>&x!Log:!o;c^b¯GxbYH[Ͽګa&?5ŵ<Qa!O%0e”æأ(f?~S n?5,j̠v:]w olYV<}rW5| yjYr>۫5˧#F{a0M6{bSFƢ0'ڢ5l؛f4 &#m0M ~C`?i,3]ezH/&7`f60U `NP.0AQD0|ą<`vYF0'h~f53RcՓLz~؀%$L5K0ciA`V`jD0ci!zXZf 4%.z7<9`ƒ;Om9cad\l Ӓ9y,CUʂ,LXH,CUʂWD3myL`ji0>F8T@i_Z&nI<.&}X0Mc`g8gXI0-z,U͵j g`0"+U^ڟ 0l&>0@lL<6[Al%)!P˄oeL0,Ls.%K4:>_xI0ci3f D0Uok%9Aay fz1=Y}YM0cSc</Њ f 8 tC>&<A0]:E0c)ek^ Ĕfcǰ 8o`ƒ=b3Az1"3 iv3NЅ„ r[f-pì"Qg>mO{0 1)Yk|r#L}lX ^/U`bwb0azaS>5 pxfo˾@^;Li<#Vdњh0YˮYf 5Kj3N>؈U`m(+ tw WWo?V֎/fe6xk947[`u&/kBkRyv0L{s1;^?@$L>PW2U) $=GSÜRg W1l֬19AeKYn# )kRvL2̵ߚ_#LL[fOجBa¯s&/yX@׼5 obC0+nkiښ6o&0( 2[݇f&ʁיE0 )f.~YE0f]}J0W h?t ߉`6AEe`w<۪eӾu'3Yyfְe;L`Onœ7][b&u'7na }غ@Mq l0[7~2*_r`;Lx}&({* _Ł鱱>LH0k*^ 撊3.D00_B0+ L2\NP:hF2O0iA`BaQT  ֨p.;D#c{Ioze0x'̑]$e-YfA")汪bE{ z]tغx~)ܣJ"G"e0nۡF-GqPˍj7S2Ge0|L~oמ>Hw`>-vNG$\ٞ( NV. wJe  ayDAvg0.A'dE+KvgìP <J xqa6~v"/|LQR;r\E:@89hށ{Z/gKr@@<+݁b[֑-`0&{xǣ8p MvwMRx )ŵD0 ,H ̂GK6ډB:1xoQd^Nc>W?-馺cs#FH"!O٭Sn^^A9O'w#e!N3dwSY9*FߴԝcqKø+]dK>[,ĘA%'NԙZOm-2{rY)<'`i\B%)2&3<ЏKnaKʛ>M֒0YQJ&yYi2^GfbhYXO(fϻkyZy\|׾.y@k'lw!Rh@ZDُ[*oWj@ŋuMB֮ p4"`$YfA"`$YfA"`$YfA"`$YfA"`$YfA"`$YfAJ3p8t}7 Ku)W \n @e3$M\.8lۥ2|][/f! Zb][12W7ۥ+eƒwWjv#duf pߠ9T`pq֣wW3t8_},@Cf?o>No(*fV}].T%TОqK46|j]iF7hР ̂fsZJ4@w/.'yƹyx3ִ́Tנ!'s2's(1vՙ3ZO}k<ĽX)}I s^*yjSwHal[̡{,s-_|ſjaRms_iL3DZLDŽ _<_kR,3dZ0˜lUFf~-x\́Yq!L-B'^g6afiqc?-T,X!Ll!/|`YMxb0qYR*2|Sf *ki|iL񼻸9Ѣ4np( nӋE*YYue~ړ9[:XzG`nXލ1o5Q=0.:]z:QԚJ}@z&boAgY5 DiVO@@Άԍ+I,9KAV<,sbr #{Q`XYe0k(RGeXLzK#$ ,[fCXenfY6U:z9va1Dԧ99_z.3:veP̦ٛguc=CPm {,0<`ӜPXS#5fe;zG? Rl(1bx6Ylf=uޣ 4=  ̈spPHM>ǃE#şnm9 5eN ^4" x YX0}ךhFOka TVB *fAh5Ѻ&- iPX-f3t3}ך FbYӛgVC$3b[fZ):JLw[5FrF<եvD ^c(52helwJ3=s_Z:h;}k6݌Q:`"[c8Qg<:[:aA~J5}VYpK]T05(ڮ $ g~lRyj" c["*5@X<}O *ՌyY-RזQ@ΈTS.p}FmyCy2Fsbˉr82gq5= <9XXg6eÜ01K޾hڮڱov uA_Ug,fh,Pf'1A_C\hGwK~65Q󐀰Y[9Q!aȍsԟ Қ!N{!,g^cTL}bBBg+9U06{D!z3 !08 au9Qۛ\ϦZ#L!7 t5:f@#@y0˅.&qVAeju9v]h!u&26-7:ܡ£Xs%6B'&q\k%0 !Sᗗ:`yVoԴh)PaڼR?oãFyÄ2`V7|{FD%q;hXoK6Lk5۠AW<_9f>0g(bT翈?,')Y/"TO%fT3y_^:+43}5fKM3{%3AS`h3d"^Lme3a֍LY ez ,swNWv033s:@דTo-{:ZfwN/=|Ӊ seO'j*D04fB_6K|Dف]I*z:ʞNq\OR[-{:Qj˞N!qƗfzbveOh0sedWYO L@u9a&(.̼Euf*o `xk{9];3ob/9~Ւ!)%R,̳xb(ٗU~0e`aqˎf~0dEtGF r(Yw rS0eτ7U3Y}5KQ65µl !F0#dB3P'B φ:!E ̂D0 T{p^X5/^y} M]q/|5X,²/T{ M{՝evQy/yw8-38-gB/T &/OWW ݛycMíe²/T$ &W0O,Q?a1*g:?Muq-Sd@X1{!Kew¼bCve?4Ot#$/02wy/2%%-So0r' Ţ٧ʡSSd?gusAȀ0[9lK6_>٧I;d pNˀ `b5}x[#z)fu,7~Je hXȀAL4zw g?Z%L^Uc]u5%yi bZÖ ,H ̂D0 ,H ̂D0 ,H ̂D0 ,H ̂D0 ,H ̂D0 ,H ̂D0 ,H ̂D0 ,H ̂D0 ,H ?6-IENDB`plotmo/README.md0000644000176200001440000001072213725236714013057 0ustar liggesusers[![version](https://www.r-pkg.org/badges/version/plotmo)](https://cran.r-project.org/package=plotmo) [![downloads](https://cranlogs.r-pkg.org/badges/plotmo)](https://cran.r-project.org/package=plotmo) ## The plotmo package: Plotting model surfaces After building a regression or classification model, it's often useful to plot the model response as the predictors vary. These model surface plots are helpful for visualizing "black box" models. The [plotmo]( https://CRAN.R-project.org/package=plotmo) package makes it easy to generate model surfaces for a wide variety of [R]( https://www.r-project.org) models, including [rpart]( https://CRAN.R-project.org/package=rpart), [gbm]( https://CRAN.R-project.org/package=gbm), [earth]( https://CRAN.R-project.org/package=earth), and many others. ## An example model surface Let's generate a [randomForest]( https://CRAN.R-project.org/package=randomForest) model from the well-known ozone dataset. (We use a random forest for this example, but any model could be used.) ```r library(earth) # for the ozone1 data data(ozone1) oz <- ozone1[, c("O3", "humidity", "temp")] # simple dataset for illustration library(randomForest) mod <- randomForest(O3 ~ ., data=oz) ``` We now have a model, but what does it tell us about the relationship between ozone pollution (O3) and humidity and temperature? We can visualize this relationship with `plotmo`: ```r library(plotmo) plotmo(mod) ``` ![](inst/README-figures/plotmo-randomForest.png) From the plots, we see that ozone increases with humidity and temperature, although humidity doesn't have much effect at low temperatures. ## Some details The top two plots in the above figure are generated by plotting the predicted response as a variable changes. Variables that don't appear in a plot are held fixed at their median values. Plotmo automatically creates a separate plot for each variable in the model. The lower interaction plot shows the predicted response as two variables are changed (once again with other variables if any held at their median values). Plotmo draws just one interaction plot for this model, since there are only two variables. ## Partial dependence plots We can generate `partial dependence` plots by specifying `pmethod="partdep"` when invoking `plotmo`. In partial dependence plots, the effect of the background variables is averaged (instead of simply holding the background variables at their medians). Partial dependence plots can be very slow, but they do incorporate more information about the distribution of the response. ## Plotting model residuals The `plotres` function is also included in the `plotmo` package. This function shows residuals and other useful information about the model, if available. Using the above model as an example: ```r plotres(mod) ``` which gives ![](inst/README-figures/plotres-randomForest.png) Note the "<" shape in the residuals plot in the lower left. This suggests that we should transform the response before building the model, maybe by taking the square or cube-root. Cases 53, 237, and 258 have the largest residuals and perhaps should be investigated. This kind of information is not obvious without plotting the residuals ## Miscellaneous More details and examples may be found in the package vignettes: - [Plotting regression surfaces with `plotmo`](http://www.milbo.org/doc/plotmo-notes.pdf) - [Plotting model residuals with `plotres`](http://www.milbo.org/doc/plotres-notes.pdf) The package also provides a few utility functions such as `plot_glmnet` and `plot_gbm`. These functions enhance similar functions in the [glmnet](https://CRAN.R-project.org/package=glmnet) and [gbm](https://CRAN.R-project.org/package=gbm) packages. Some examples: ![](inst/README-figures/plotres-glmnet-gbm.png) ## Which models work with plotmo? Any model that conforms to standard S3 model guidelines will work with `plotmo`. Plotmo knows how to deal with logistic, classification, and multiple response models. It knows how to handle different `type` arguments to `predict` functions. Package authors may want to look at [Guidelines for S3 Regression Models](http://www.milbo.org/doc/modguide.pdf). If `plotmo` or `plotres` doesn't work with your model, contact the `plotmo` package maintainer. Often a minor tweak to the model code is all that is needed. [Stephen Milborrow]( http://www.milbo.users.sonic.net/index.html) plotmo/man/0000755000176200001440000000000014334575431012350 5ustar liggesusersplotmo/man/plotres.Rd0000644000176200001440000003305613136204652014327 0ustar liggesusers\name{plotres} \alias{plotres} \concept{residual plot} \title{Plot the residuals of a regression model} \description{ Plot the residuals of a regression model. Please see the \href{../doc/plotres-notes.pdf}{plotres vignette} (also available \href{http://www.milbo.org/doc/plotres-notes.pdf}{here}). } \usage{ plotres(object = stop("no 'object' argument"), which = 1:4, info = FALSE, versus = 1, standardize = FALSE, delever = FALSE, level = 0, id.n = 3, labels.id = NULL, smooth.col = 2, grid.col = 0, jitter = 0, do.par = NULL, caption = NULL, trace = 0, npoints = 3000, center = TRUE, type = NULL, nresponse = NA, object.name = quote.deparse(substitute(object)), ...) } \arguments{ \item{object}{ The model object. } \item{which}{ Which plots do draw. Default is \code{1:4}. \code{1} Model plot. What gets plotted here depends on the model class. For example, for \code{earth} models this is a model selection plot. Nothing will be displayed for some models. For details, please see the \href{../doc/plotres-notes.pdf}{plotres vignette}. \code{2} Cumulative distribution of abs residuals \code{3} Residuals vs fitted \code{4} QQ plot \code{5} Abs residuals vs fitted \code{6} Sqrt abs residuals vs fitted \code{7} Abs residuals vs log fitted \code{8} Cube root of the squared residuals vs log fitted \code{9} Log abs residuals vs log fitted \cr \cr } \item{info}{ Default is \code{FALSE}. Use \code{TRUE} to print extra information as follows: % For more information, please % see the section \emph{\dQuote{The info argument of plot.earth}} % in the \code{earth} package vignette % \emph{\dQuote{Variance models in earth}}. i) Display the distribution of the residuals along the bottom of the plot. ii) Display the training R-Squared. iii) Display the Spearman Rank Correlation of the absolute residuals with the fitted values. Actually, correlation is measured against the absolute values of whatever is on the horizontal axis --- by default this is the fitted response, but may be something else if the \code{versus} argument is used. iv) In the Cumulative Distribution plot (\code{which=2}), display additional information on the quantiles. v) Only for \code{which=5} or \code{9}. Regress the absolute residuals against the fitted values and display the regression slope. Robust linear regression is used via \code{\link[MASS]{rlm}} in the MASS package. vi) Add various annotations to the other plots. \cr \cr } \item{versus}{ What do we plot the residuals against? One of: \code{1} Default. Plot the residuals versus the fitted values (or the log values when \code{which=7} to \code{9}). \code{2} Residuals versus observation number, after observations have been sorted on the fitted value. Same as \code{versus=1}, except that the residuals are spaced uniformly along the horizontal axis. \code{3} Residuals versus the response. \code{4} Residuals versus the hat leverages. \code{"b:"} Residuals versus the basis functions. Currently only supported for \code{earth}, \code{mda::mars}, and \code{gam::gam} models. A optional \code{\link{regex}} can follow the \code{"b:"} to specify a subset of the terms, e.g. \code{versus="b:wind"} will plot terms with \code{"wind"} in their name. Else a character vector specifying which predictors to plot against. \cr Example 1: \code{versus=""} plots against all predictors (since the regex \code{versus=""} matches anything). \cr Example 2: \code{versus=c("wind", "vis")} plots predictors with \code{wind} or \code{vis} in their name. \cr Example 3: \code{versus=c("wind|vis")} equivalent to the above. \cr Note: These are \code{\link{regex}}s. Thus \code{versus="wind"} will match all variables that have \code{"wind"} in their names. Use \code{"^wind$"} to match only the variable named \code{"wind"}. \cr \cr } \item{standardize}{ Default is \code{FALSE}. Use \code{TRUE} to standardize the residuals. Only supported for some models, an error message will be issued otherwise. \cr Each residual is divided by by \code{se_i * sqrt(1 - h_ii)}, where \code{se_i} is the standard error of prediction and \code{h_ii} is the leverage (the diagonal entry of the hat matrix). When the variance model holds, the standardized residuals are homoscedastic with unity variance. \cr The leverages are obtained using \code{\link{hatvalues}}. (For \code{earth} models the leverages are for the linear regression of the response on the basis matrix \code{bx}.) A standardized residual with a leverage of 1 is plotted as a star on the axis. \cr This argument applies to all plots where the residuals are used (including the cumulative distribution and QQ plots, and to annotations displayed by the \code{info} argument). } \item{delever}{ Default is \code{FALSE}. Use \code{TRUE} to \dQuote{de-lever} the residuals. Only supported for some models, an error message will be issued otherwise. \cr Each residual is divided by \code{sqrt(1 - h_ii)}. See the \code{standardize} argument for details. } \item{level}{ Draw estimated confidence or prediction interval bands at the given \code{level}, if the model supports them. \cr Default is \code{0}, bands not plotted. Else a fraction, for example \code{level=0.90}. Example:\preformatted{ mod <- lm(log(Volume)~log(Girth), data=trees) plotres(mod, level=.90)} You can modify the color of the bands with \code{level.shade} and \code{level.shade2}. \cr See also \dQuote{\emph{Prediction intervals}} in the \href{../doc/plotmo-notes.pdf}{plotmo vignette} (but note that \code{plotmo} needs prediction intervals on \emph{new} data, whereas \code{plotres} requires only that the model supports prediction intervals on the training data). } \item{id.n}{ The largest \code{id.n} residuals will be labeled in the plot. Default is \code{3}. Special values \code{TRUE} and \code{-1} or mean all.\cr If \code{id.n} is negative (but not \code{-1}) the \code{id.n} most positive and most negative residuals will be labeled in the plot.\cr A current implementation restriction is that \code{id.n} is ignored when there are more than ten thousand cases. } \item{labels.id}{ Residual labels. Only used if \code{id.n > 0}. Default is the case names, or the case numbers if the cases are unnamed. } \item{smooth.col}{ Color of the smooth line through the residual points. Default is \code{2}, red. Use \code{smooth.col=0} for no smooth line. \cr You can adjust the amount of smoothing with \code{smooth.f}. This gets passed as \code{f} to \code{\link[stats]{lowess}}. The default is \code{2/3}. Lower values make the line more wiggly. } \item{grid.col}{ Default is \code{0}, no grid. Else add a background \code{\link[graphics]{grid}} of the specified color to the degree1 plots. The special value \code{grid.col=TRUE} is treated as \code{"lightgray"}. } % \item{cum.grid}{ % Grid type in the Cumulative Distribution plot. One of: % % \code{"none"} No grid. % % \code{"grid"} Add grid showing the 25\%, 50\%, 90\%, and 95\% % quantiles. % % \code{"percentages"} (default) Add grid and percentage labels. % If \code{info=TRUE} also display quantiles on the right. % \cr % \cr % } \item{jitter}{ Default is \code{0}, no jitter. Passed as \code{factor} to \code{\link[base]{jitter}} to jitter the plotted points horizontally and vertically. Useful for discrete variables and responses, where the residual points tend to be overlaid. } \item{do.par}{One of \code{NULL}, \code{FALSE}, \code{TRUE}, or \code{2}, as follows: \code{do.par=NULL} (default). Same as \code{do.par=FALSE} if the number of plots is one; else the same as \code{TRUE}. \code{do.par=FALSE}. Use the current \code{\link[graphics]{par}} settings. You can pass additional graphics parameters in the ``\code{...}'' argument. \code{do.par=TRUE}. Start a new page and call \code{\link[graphics]{par}} as appropriate to display multiple plots on the same page. This automatically sets parameters like \code{mfrow} and \code{mar}. You can pass additional graphics parameters in the ``\code{...}'' argument. % This sets the \emph{overall} look of the display; modify % \emph{specific} plots by using prefixed arguments as described in the % documentation for the \dots argument below. \code{do.par=2}. Like \code{do.par=TRUE} but don't restore the \code{\link[graphics]{par}} settings to their original state when \code{plotres} exits, so you can add something to the plot. \cr \cr } \item{caption}{ Overall caption. By default create the caption automatically. Use \code{caption=""} for no caption. (Use \code{main} to set the title of an individual plot.) } \item{trace}{ Default is \code{0}. \cr \code{trace=1} (or \code{TRUE}) for a summary trace (shows how \code{\link[stats]{predict}} and friends are invoked for the model). \cr \code{trace=2} for detailed tracing. \cr } \item{npoints}{ Number of points to be plotted. A sample of \code{npoints} is taken; the sample includes the biggest twenty or so residuals. \cr The default is 3000 (not all, to avoid overplotting on large models). Use \code{npoints=TRUE} or \code{-1} for all points. } \item{center}{ Default is TRUE, meaning center the horizontal axis in the residuals plot, so asymmetry in the residual distribution is more obvious. } \item{type}{ Type parameter passed first to \code{\link{residuals}} and if that fails to \code{\link{predict}}. For allowed values see the \code{residuals} and \code{predict} methods for your \code{object} (such as \code{\link[rpart]{residuals.rpart}} or \code{\link[earth]{predict.earth}}). By default, \code{plotres} tries to automatically select a suitable value for the model in question (usually \code{"response"}), but this will not always be correct. Use \code{trace=1} to see the \code{type} argument passed to \code{residuals} and \code{predict}. } \item{nresponse}{ Which column to use when \code{residuals} or \code{predict} returns multiple columns. This can be a column index or column name (which may be abbreviated, partial matching is used). } \item{object.name}{ The name of the \code{object} for error and trace messages. Used internally by \code{plot.earth}. \cr \cr } \item{\dots}{ Dot arguments are passed to the plot functions. Dot argument names, whether prefixed or not, should be specified in full and not abbreviated. \dQuote{Prefixed} arguments are passed directly to the associated function. For example the prefixed argument \code{pt.col="pink"} passes \code{col="pink"} to \code{points()}, overriding the global \code{col} setting. The prefixes recognized by \code{plotres} are:\tabular{ll}{ \code{residuals.} \tab passed to \code{\link[stats]{residuals}} \cr \code{predict.} \tab passed to \code{\link[stats]{predict}} (\code{predict} is called if the call to \code{residuals} fails) \cr \code{w1.} \tab sent to the model-dependent plot for \code{which=1} e.g. \code{w1.col=2} \cr \code{pt.} \tab modify the displayed points e.g. \code{pt.col=as.numeric(survived)+2} or \code{pt.cex=.8}. \cr \code{smooth.} \tab modify the smooth line e.g. \code{smooth.col=0} or \code{smooth.f=.5}. \cr \code{level.} \tab modify the interval bands, e.g. \code{level.shade="gray"} or \code{level.shade2="lightblue"} \cr \code{legend.} \tab modify the displayed \code{\link[graphics]{legend}} e.g. \code{legend.cex=.9} \cr \code{cum.} \tab modify the Cumulative Distribution plot (arguments for \code{\link[stats]{plot.stepfun}}) \cr \code{qq.} \tab modify the QQ plot, e.g. \code{qq.pch=1} \cr \code{qqline} \tab modify the \code{\link{qqline}} in the QQ plot, e.g. \code{qqline.col=0} \cr \code{label.} \tab modify the point labels, e.g. \code{label.cex=.9} or \code{label.font=2} \cr \code{cook.} \tab modify the Cook's Distance annotations. This affects only the leverage plot (\code{versus=3}) for \code{lm} models with \code{standardize=TRUE}. e.g. \code{cook.levels=c(.5, .8, 1)} or \code{cook.col=2}. \cr \code{caption.} \tab modify the overall caption (see the \code{caption} argument) e.g. \code{caption.col=2}. \cr \code{par.} \tab arguments for \code{\link[graphics]{par}} (only necessary if a \code{par} argument name clashes with a \code{plotres} argument) } The \code{cex} argument is relative, so specifying \code{cex=1} is the same as not specifying \code{cex}. For backwards compatibility, some dot arguments are supported but not explicitly documented. } } \value{ If the \code{which=1} plot was plotted, the return value of that plot (model dependent). Else if the \code{which=3} plot was plotted, return \code{list(x,y)} where \code{x} and \code{y} are the coordinates of the points in that plot (but without jittering even if the \code{jitter} argument was used). Else return \code{NULL}. } \note{ This function is designed primarily for displaying standard \code{response - fitted} residuals for models with a single continuous response, although it will work for a few other models. In general this function won't work on models that don't save the call and data with the model in a standard way. It uses the same underlying mechanism to access the model data as \code{\link{plotmo}}. For further discussion please see \dQuote{\emph{Accessing the model data}} in the \href{../doc/plotmo-notes.pdf}{plotmo vignette} (also available \href{http://www.milbo.org/doc/plotmo-notes.pdf}{here}). Package authors may want to look at \href{../doc/modguide.pdf}{Guidelines for S3 Regression Models} (also available \href{http://www.milbo.org/doc/modguide.pdf}{here}). } \seealso{ Please see the \href{../doc/plotres-notes.pdf}{plotres vignette} (also available \href{http://www.milbo.org/doc/plotres-notes.pdf}{here}). \code{\link[stats]{plot.lm}} \code{\link[earth]{plot.earth}} } \examples{ # we use lm in this example, but plotres is more useful for models # that don't have a function like plot.lm for plotting residuals lm.model <- lm(Volume~., data=trees) plotres(lm.model) } \keyword{partial dependence} \keyword{regression} plotmo/man/plot_gbm.Rd0000644000176200001440000001075713011421421014430 0ustar liggesusers\name{plot_gbm} \alias{plot_gbm} \title{Plot a gbm model} \description{ Plot a \code{\link[gbm]{gbm}} model showing the training and other error curves. } \usage{ plot_gbm(object=stop("no 'object' argument"), smooth = c(0, 0, 0, 1), col = c(1, 2, 3, 4), ylim = "auto", legend.x = NULL, legend.y = NULL, legend.cex = .8, grid.col = NA, n.trees = NA, col.n.trees ="darkgray", ...) } \arguments{ \item{object}{ The \code{gbm} model. } \item{smooth}{ Four-element vector specifying if smoothing should be applied to the train, test, CV, and OOB curves respectively. When smoothing is specified, a smoothed curve is plotted and the minimum is calculated from the smoothed curve.\cr The default is c(0, 0, 0, 1) meaning apply smoothing only to the OOB curve (same as \code{\link[gbm]{gbm.perf}}).\cr Note that \code{smooth=1} (which gets recyled to \code{c(1,1,1,1)}) will smooth all the curves. } \item{col }{ Four-element vector specifying the colors for the train, test, CV, and OOB curves respectively.\cr The default is \code{c(1, 2, 3, 4)}.\cr Use a color of \code{0} to remove the corresponding curve, e.g. \code{col=c(1,2,3,0)} to not display the OOB curve.\cr If \code{col=0} (which gets recycled to \code{c(0,0,0,0)}) nothing will be plotted, but \code{plot_gbm} will return the number-of-trees at the minima as usual (as described in the Value section below). } \item{ylim }{ The default \code{ylim="auto"} shows more detail around the minima.\cr Use \code{ylim=NULL} for the full vertical range of the curves.\cr Else specify \code{ylim} as usual. } \item{legend.x }{ The x position of the legend. The default positions the legend automatically.\cr Use \code{legend.x=NA} for no legend.\cr See the \code{x} and \code{y} arguments of \code{\link[grDevices]{xy.coords}} for other options, for example \code{legend.x="topright"}. } \item{legend.y }{ The y position of the legend. } \item{legend.cex }{ The legend \code{cex} (the default is \code{0.8}). } \item{grid.col}{ Default \code{NA}. Color of the optional grid, for example \code{grid.col=1}. } \item{n.trees}{ For use by \code{\link{plotres}}.\cr The x position of the gray vertical line indicating the \code{n.trees} passed by \code{plotres} to \code{predict.gbm} to calculate the residuals. Plotres defaults to all trees. } \item{col.n.trees }{ For use by \code{\link{plotres}}.\cr Color of the vertical line showing the \code{n.trees} argument. Default is \code{"darkgray"}. } \item{\dots}{ Dot arguments are passed internally to \code{\link[graphics]{plot.default}}. } } \value{ This function returns a four-element vector specifying the number of trees at the train, test, CV, and OOB minima respectively. The minima are calculated after smoothing as specified by this function's \code{smooth} argument. By default, only the OOB curve is smoothed. The smoothing algorithm for the OOB curve differs slightly from \code{\link[gbm]{gbm.perf}}, so can give a slightly different number of trees. } \note{ \bold{The OOB curve} The OOB curve is artificially rescaled to force it into the plot. See Chapter 7 in the \href{../doc/plotres-notes.pdf}{plotres vignette}. % The OOB minimum is determined after smoothing the curve, % but the unsmoothed curve is displayed. % Whereas the minima for the test and cross-validation curves are % determined without smoothing. % This calculation of minima is compatible with \code{gbm.perf}. \bold{Interaction with \code{plotres}} When invoking this function via \code{\link{plotres}}, prefix any argument of \code{plotres} with \code{w1.} to tell \code{plotres} to pass the argument to this function. For example give \code{w1.ylim=c(0,10)} to \code{plotres} (plain \code{ylim=c(0,10)} in this context gets passed to the residual plots). \bold{Acknowledgments} This function is derived from code in the \code{\link[gbm]{gbm}} package authored by Greg Ridgeway and others. } \seealso{ Chapter 7 in \href{../doc/plotres-notes.pdf}{plotres vignette} discusses this function. } \examples{ if (require(gbm)) { n <- 100 # toy model for quick demo x1 <- 3 * runif(n) x2 <- 3 * runif(n) x3 <- sample(1:4, n, replace=TRUE) y <- x1 + x2 + x3 + rnorm(n, 0, .3) data <- data.frame(y=y, x1=x1, x2=x2, x3=x3) mod <- gbm(y~., data=data, distribution="gaussian", n.trees=300, shrinkage=.1, interaction.depth=3, train.fraction=.8, verbose=FALSE) plot_gbm(mod) # plotres(mod) # plot residuals # plotmo(mod) # plot regression surfaces } } plotmo/man/plotmo.Rd0000644000176200001440000004576113725545113014163 0ustar liggesusers\name{plotmo} \alias{plotmo} \concept{partial dependence plot} \title{Plot a model's response over a range of predictor values (the model surface)} \description{ Plot model surfaces for a wide variety of models. This function plots the model's response when varying one or two predictors while holding the other predictors constant (a poor man's partial-dependence plot). It can also generate partial-dependence plots (by specifying \code{pmethod="partdep"}). Please see the \href{../doc/plotmo-notes.pdf}{plotmo vignette} (also available \href{http://www.milbo.org/doc/plotmo-notes.pdf}{here}). } \usage{ plotmo(object=stop("no 'object' argument"), type=NULL, nresponse=NA, pmethod="plotmo", pt.col=0, jitter=.5, smooth.col=0, level=0, func=NULL, inverse.func=NULL, nrug=0, grid.col=0, type2="persp", degree1=TRUE, all1=FALSE, degree2=TRUE, all2=FALSE, do.par=TRUE, clip=TRUE, ylim=NULL, caption=NULL, trace=0, grid.func=NULL, grid.levels=NULL, extend=0, ngrid1=50, ngrid2=20, ndiscrete=5, npoints=3000, center=FALSE, xflip=FALSE, yflip=FALSE, swapxy=FALSE, int.only.ok=TRUE, ...) } \arguments{ \item{object}{ The model object. } \item{type}{ Type parameter passed to \code{\link{predict}}. For allowed values see the \code{predict} method for your \code{object} (such as \code{\link[earth]{predict.earth}}). By default, \code{plotmo} tries to automatically select a suitable value for the model in question (usually \code{"response"}) but this will not always be correct. Use \code{trace=1} to see the \code{type} argument passed to \code{predict}. } \item{nresponse}{ Which column to use when \code{predict} returns multiple columns. This can be a column index, or a column name if the \code{predict} method for the model returns column names. The column name may be abbreviated, partial matching is used. } \item{pmethod}{ Plotting method. One of: \code{"plotmo"} (default) Classic plotmo plots i.e. the background variables are fixed at their medians (or first level for factors). \code{"partdep"} Partial dependence plots, i.e. at each point the effect of the background variables is averaged. \code{"apartdep"} Approximate partial dependence plots. Faster than \code{"partdep"} especially for big datasets. Like \code{"partdep"} but the background variables are averaged over a subset of \code{ngrid1} cases (default 50), rather than all cases in the training data. The subset is created by selecting rows at equally spaced intervals from the training data after sorting the data on the response values (ties are randomly broken). % If \code{ngrid1} is greater then the number of cases than all cases % are used, and \code{"apartdep"} is identical to \code{"partdep"}. The same background subset of \code{ngrid1} cases is used for both degree1 and degree2 plots. } \item{pt.col}{ The color of response points (or response sites in degree2 plots). This refers to the response \code{y} in the data used to build the model. Note that the displayed points are jittered by default (see the \code{jitter} argument). \cr Default is \code{0}, display no response points. \cr This can be a vector, like all such arguments -- for example \code{pt.col = as.numeric(survived)+2} to color points by their survival class. \cr You can modify the plotted points with \code{pt.pch}, \code{pt.cex}, etc. (these get passed via \code{plotmo}'s ``\code{...}'' argument). For example, \code{pt.cex = weights} to size points by their weight. To label the points, set \code{pt.pch} to a character vector. } \item{jitter}{ Applies only if \code{pt.col} is specified.\cr The default is \code{jitter=.5}, automatically apply some jitter to the points. Points are jittered horizontally and vertically.\cr Use \code{jitter=0} to disable this automatic jittering. Otherwise something like \code{jitter=1}, but the optimum value is data dependent. } \item{smooth.col}{ Color of smooth line through the response points. (The points themselves will not be plotted unless \code{pt.col} is specified.) Default is \code{0}, no smooth line. \cr Example:\preformatted{ mod <- lm(Volume~Height, data=trees) plotmo(mod, pt.color=1, smooth.col=2)} You can adjust the amount of smoothing with \code{smooth.f}. This gets passed as \code{f} to \code{\link[stats]{lowess}}. The default is \code{.5}. Lower values make the line more wiggly. } \item{level}{ Draw estimated confidence or prediction interval bands at the given \code{level}, if the predict method for the model supports them.\cr Default is \code{0}, bands not plotted. Else a fraction, for example \code{level=.95}. See \dQuote{\emph{Prediction intervals}} in the \code{plotmo} vignette. Example:\preformatted{ mod <- lm(log(Volume)~log(Girth), data=trees) plotmo(mod, level=.95)} You can modify the color of the bands with \code{level.shade} and \code{level.shade2}. } \item{func}{ Superimpose \code{func(x)} on the plot. Example:\preformatted{ mod <- lm(Volume~Girth, data=trees) estimated.volume <- function(x) .17 * x$Girth^2 plotmo(mod, pt.col=2, func=estimated.volume)} The \code{func} is called for each plot with a single argument which is a dataframe with columns in the same order as the predictors in the \code{formula} or \code{x} used to build the model. Use \code{trace=2} to see the column names and first few rows of this dataframe. } \item{inverse.func}{ A function applied to the response before plotting. Useful to transform a transformed response back to the original scale. Example:\preformatted{ mod <- lm(log(Volume)~., data=trees) plotmo(mod, inverse.func=exp) # exp() is inverse of log() } } \item{nrug}{ Number of ticks in the \code{\link[graphics]{rug}} along the bottom of the plot \cr Default is \code{0}, no rug. \cr Use \code{nrug=TRUE} for all the points. \cr Else specify the number of quantiles e.g. use \code{nrug=10} for ticks at the 0, 10, 20, ..., 100 percentiles. \cr Modify the rug ticks with \code{rug.col}, \code{rug.lwd}, etc. \cr The special value \code{nrug="density"} means plot the density of the points along the bottom. Modify the \code{\link[stats]{density}} plot with \code{density.adjust} (default is \code{.5}), \code{density.col}, \code{density.lty}, etc. } \item{grid.col}{ Default is \code{0}, no grid. Else add a background \code{\link[graphics]{grid}} of the specified color to the degree1 plots. The special value \code{grid.col=TRUE} is treated as \code{"lightgray"}. } \item{type2}{ Degree2 plot type. One of \code{"\link[graphics]{persp}"} (default), \code{"\link[graphics]{image}"}, or \code{"\link[graphics]{contour}"}. You can pass arguments to these functions if necessary by using \code{persp.}, \code{image.}, or \code{contour.} as a prefix. Examples:\preformatted{ plotmo(mod, persp.ticktype="detailed", persp.nticks=3) plotmo(mod, type2="image") plotmo(mod, type2="image", image.col=heat.colors(12)) plotmo(mod, type2="contour", contour.col=2, contour.labcex=.4) } } \item{degree1}{ An index vector specifying which subset of degree1 (main effect) plots to include (after selecting the relevant predictors as described in \dQuote{\emph{Which variables are plotted?}} in the \code{plotmo} vignette). \cr Default is \code{TRUE}, meaning all (the \code{TRUE} gets recycled). To plot only the third plot use \code{degree1=3}. For no degree1 plots use \code{degree1=0}. \cr \cr Note that \code{degree1} indexes plots on the page, not columns of \code{x}. Probably the easiest way to use this argument (and \code{degree2}) is to first use the default (and possibly \code{all1=TRUE}) to plot all figures. This shows how the figures are numbered. Then replot using \code{degree1} to select the figures you want, for example \code{degree1=c(1,3,4)}. \cr \cr Can also be a character vector specifying which variables to plot. Examples:\cr \code{degree1="wind"}\cr \code{degree1=c("wind", "vis")}. \cr \cr Variables names are matched with \code{\link[base]{grep}}. Thus \code{"wind"} will match all variables with \code{"wind"} anywhere in their name. Use \code{"^wind$"} to match only the variable named \code{"wind"}. } \item{all1}{ Default is \code{FALSE}. Use \code{TRUE} to plot all predictors, not just those usually selected by \code{plotmo}. \cr The \code{all1} argument increases the number of plots; the \code{degree1} argument reduces the number of plots. } \item{degree2}{ An index vector specifying which subset of degree2 (interaction) plots to include. \cr Default is \code{TRUE} meaning all (after selecting the relevant interaction terms as described in \dQuote{\emph{Which variables are plotted?}} in the \code{plotmo} vignette). \cr \cr Can also be a character vector specifying which variables to plot (\code{\link[base]{grep}} is used for matching). Examples: \cr \code{degree2="wind"} plots all degree2 plots for the \code{wind} variable. \cr \code{degree2=c("wind", "vis")} plots just the \code{wind:vis} plot. } \item{all2}{ Default is \code{FALSE}. Use \code{TRUE} to plot all pairs of predictors, not just those usually selected by \code{plotmo}. } \item{do.par}{One of \code{NULL}, \code{FALSE}, \code{TRUE}, or \code{2}, as follows: \code{do.par=NULL}. Same as \code{do.par=FALSE} if the number of plots is one; else the same as \code{TRUE}. \code{do.par=FALSE}. Use the current \code{\link[graphics]{par}} settings. You can pass additional graphics parameters in the ``\code{...}'' argument. \code{do.par=TRUE} (default). Start a new page and call \code{\link[graphics]{par}} as appropriate to display multiple plots on the same page. This automatically sets parameters like \code{mfrow} and \code{mar}. You can pass additional graphics parameters in the ``\code{...}'' argument. % This sets the \emph{overall} look of the display; modify % \emph{specific} plots by using prefixed arguments as described in the % documentation for the \dots argument below. \code{do.par=2}. Like \code{do.par=TRUE} but don't restore the \code{\link[graphics]{par}} settings to their original state when \code{plotmo} exits, so you can add something to the plot. \cr } \item{clip}{ The default is \code{clip=TRUE}, meaning ignore very outlying predictions when determining the automatic \code{ylim}. This keeps \code{ylim} fairly compact while still covering all or nearly all the data, even if there are a few crazy predicted values. See \dQuote{\emph{The \code{ylim} and \code{clip} arguments}} in the \code{plotmo} vignette. \cr Use \code{clip=FALSE} for no clipping. } \item{ylim}{Three possibilities: \cr \code{ylim=NULL} (default). Automatically determine a \code{ylim} to use across all graphs. \cr \code{ylim=NA}. Each graph has its own \code{ylim}. \cr \code{ylim=c(ymin,ymax)}. Use the specified limits across all graphs. \cr } \item{caption}{ Overall caption. By default create the caption automatically. Use \code{caption=""} for no caption. (Use \code{main} to set the title of individual plots, can be a vector.) } \item{trace}{ Default is \code{0}. \cr \code{trace=1} (or \code{TRUE}) for a summary trace (shows how \code{\link[stats]{predict}} is invoked for the current object). \cr \code{trace=2} for detailed tracing. \cr \code{trace=-1} inhibits the messages usually issued by \code{plotmo}, like the \code{plotmo grid:}, \code{calculating partdep}, and \code{nothing to plot} messages. Error and warning messages will be printed as usual. \cr \cr } \item{grid.func}{ Function applied to columns of the \code{x} matrix to pin the values of variables not on the axis of the current plot (the ``background'' variables).\cr The default is a function which for numeric variables returns the median and for logical and factors variables returns the value occurring most often in the training data.\cr Examples:\preformatted{ plotmo(mod, grid.func=mean) grid.func <- function(x, ...) quantile(x)[2] # 25\% quantile plotmo(mod, grid.func=grid.func)} This argument is not related to the \code{grid.col} argument.\cr This argument can be overridden for specific variables---see \code{grid.levels} below. } \item{grid.levels}{ Default is \code{NULL}. Else a list of variables and their fixed value to be used when the variable is not on the axis. Supersedes \code{grid.func} for variables in the list. Names and values can be abbreviated, partial matching is used. Example:\preformatted{ plotmo(mod, grid.levels=list(sex="m", age=21)) } } \item{extend}{ Amount to extend the horizontal axis in each plot. The default is \code{0}, do not extend (i.e. use the range of the variable in the training data). Else something like \code{extend=.5}, which will extend both the lower and upper \code{xlim} of each plot by 50\%.\cr This argument is useful if you want to see how the model performs on data that is beyond the training data; for example, you want to see how a time-series model performs on future data.\cr This argument is currently implemented only for degree1 plots. Factors and discrete variables (see the \code{ndiscrete} argument) are not extended. } \item{ngrid1}{ Number of equally spaced x values in each degree1 plot. Default is \code{50}. Also used as the number of background cases for \code{pmethod="apartdep"}. } \item{ngrid2}{ Grid size for degree2 plots (\code{ngrid2 x ngrid2} points are plotted). Default is \code{20}. \cr The default will sometimes be too small for \code{contour} and \code{image} plots. \cr With large \code{ngrid2} values, \code{persp} plots look better with \code{persp.border=NA}. } \item{npoints}{ Number of response points to be plotted (a sample of \code{npoints} points is plotted). Applies only if \code{pt.col} is specified. \cr The default is 3000 (not all, to avoid overplotting on large models). Use \code{npoints=TRUE} or \code{-1} for all points. } \item{ndiscrete}{ Default \code{5} (a somewhat arbitrary value). Variables with no more than \code{ndiscrete} unique values are plotted as quantized in plots (a staircase rather than a curve).\cr Factors are always considered discrete. Variables with non-integer values are always considered non-discrete.\cr Use \code{ndiscrete=0} if you want to plot the response for a variable with just a few integer values as a line or a curve, rather than a staircase.\cr } \item{int.only.ok}{ Plot the model even if it is an intercept-only model (no predictors are used in the model). Do this by plotting a single degree1 plot for the first predictor. \cr The default is \code{TRUE}. Use \code{int.only.ok=FALSE} to instead issue an error message for intercept-only models. } \item{center}{ Center the plotted response. Default is \code{FALSE}. } \item{xflip}{ Default \code{FALSE}. Use \code{TRUE} to flip the direction of the \code{x} axis. This argument (and \code{yflip} and \code{swapxy}) is useful when comparing to a plot from another source and you want the axes to be the same. (Note that \code{xflip} and \code{yflip} cannot be used on the \code{persp} plots, a limitation of the \code{persp} function.) } \item{yflip}{ Default \code{FALSE}. Use \code{TRUE} to flip the direction of the y axis of the degree2 graphs. } \item{swapxy}{ Default \code{FALSE}. Use \code{TRUE} to swap the x and y axes on the degree2 graphs. \cr \cr } \item{\dots}{ Dot arguments are passed to the predict and plot functions. Dot argument names, whether prefixed or not, should be specified in full and not abbreviated. \cr \cr \dQuote{Prefixed} arguments are passed directly to the associated function. For example the prefixed argument \code{persp.col="pink"} passes \code{col="pink"} to \code{persp()}, overriding the global \code{col} setting. To send an argument to \code{predict} whose name may alias with \code{plotmo}'s arguments, use \code{predict.} as a prefix. Example:\preformatted{ plotmo(mod, s=1) # error: arg matches multiple formal args plotmo(mod, predict.s=1) # ok now: s=1 will be passed to predict() } The prefixes recognized by \code{plotmo} are:\tabular{ll}{ \cr \code{predict.} \tab passed to the \code{\link[stats]{predict}} method for the model \cr \code{degree1.} \tab modifies degree1 plots e.g. \code{degree1.col=3, degree1.lwd=2} \cr \code{persp.} \tab arguments passed to \code{\link[graphics]{persp}} \cr \code{contour.} \tab arguments passed to \code{\link[graphics]{contour}} \cr \code{image.} \tab arguments passed to \code{\link[graphics]{image}} \cr \code{pt.} \tab see the \code{pt.col} argument (arguments passed to \code{\link[graphics]{points}} and \code{\link[graphics]{text}}) \cr \code{smooth.} \tab see the \code{smooth.col} argument (arguments passed to \code{\link[graphics]{lines}} and \code{\link[stats]{lowess}}) \cr \code{level.} \tab see the \code{level} argument (\code{level.shade}, \code{level.shade2}, and arguments for \code{\link[graphics]{polygon}}) \cr \code{func.} \tab see the \code{func} argument (arguments passed to \code{\link[graphics]{lines}}) \cr \code{rug.} \tab see the \code{nrug} argument (\code{rug.jitter}, and arguments passed to \code{\link[graphics]{rug}}) \cr \code{density.} \tab see the \code{nrug} argument (\code{density.adjust}, and arguments passed to \code{\link[graphics]{lines}}) \cr \code{grid.} \tab see the \code{grid.col} argument (arguments passed to \code{\link[graphics]{grid}}) \cr \code{caption.} \tab see the \code{caption} argument (arguments passed to \code{\link[graphics]{mtext}}) \cr \code{par.} \tab arguments passed to \code{\link[graphics]{par}} (only necessary if a \code{par} argument name clashes with a \code{plotmo} argument) \cr \code{prednames.} \tab Use \code{prednames.abbreviate=FALSE} for full predictor names in graph axes. \cr } The \code{cex} argument is relative, so specifying \code{cex=1} is the same as not specifying \code{cex}. For backwards compatibility, some dot arguments are supported but not explicitly documented. For example, the old argument \code{col.response} is no longer in \code{plotmo}'s formal argument list, but is still accepted and treated like the new argument \code{pt.col}. } } \note{ In general this function won't work on models that don't save the call and data with the model in a standard way. For further discussion please see \dQuote{\emph{Accessing the model data}} in the \href{../doc/plotmo-notes.pdf}{plotmo vignette}. Package authors may want to look at \href{../doc/modguide.pdf}{Guidelines for S3 Regression Models} (also available \href{http://www.milbo.org/doc/modguide.pdf}{here}). By default, \code{plotmo} tries to use sensible model-dependent defaults when calling \code{predict}. Use \code{trace=1} to see the arguments passed to \code{predict}. You can change the defaults by using \code{plotmo}'s \code{type} argument, and by using dot arguments prefixed with \code{predict.} (see the description of ``\code{...}'' above). } \seealso{ Please see the \href{../doc/plotmo-notes.pdf}{plotmo vignette} (also available \href{http://www.milbo.org/doc/plotmo-notes.pdf}{here}). } \examples{ if (require(rpart)) { data(kyphosis) rpart.model <- rpart(Kyphosis~., data=kyphosis) # pass type="prob" to plotmo's internal calls to predict.rpart, and # select the column named "present" from the matrix returned by predict.rpart plotmo(rpart.model, type="prob", nresponse="present") } if (require(earth)) { data(ozone1) earth.model <- earth(O3 ~ ., data=ozone1, degree=2) plotmo(earth.model) # plotmo(earth.model, pmethod="partdep") # partial dependence plots } } \keyword{partial dependence} \keyword{regression} plotmo/man/plotmo.misc.Rd0000644000176200001440000000614114566103176015105 0ustar liggesusers\name{plotmo.misc} \alias{check.index} \alias{plotmo.convert.na.nresponse} \alias{plotmo.pairs.default} \alias{plotmo.pairs} \alias{plotmo.pint} \alias{plotmo.predict} \alias{plotmo.prolog} \alias{plotmo.residtype} \alias{plotmo.singles.default} \alias{plotmo.singles} \alias{plotmo.type} \alias{plotmo.x} \alias{plotmo.y.default} \alias{plotmo.y} \alias{plotmo_cum} \alias{plotmo_fitted} \alias{plotmo_nresponse} \alias{plotmo_predict} \alias{plotmo_prolog} \alias{plotmo_resplevs} \alias{plotmo_response} \alias{plotmo_rinfo} \alias{plotmo_rsq} \alias{plotmo_standardizescale} \alias{plotmo_type} \alias{plotmo_y} \title{Ignore} \description{ Miscellaneous functions exported for internal use by \code{earth} and other packages. You can ignore these. } \usage{ # for earth plotmo_fitted(object, trace, nresponse, type, ...) plotmo_cum(rinfo, info, nfigs=1, add=FALSE, cum.col1, grid.col, jitter=0, cum.grid="percentages", ...) plotmo_nresponse(y, object, nresponse, trace, fname, type="response") plotmo_rinfo(object, type=NULL, residtype=type, nresponse=1, standardize=FALSE, delever=FALSE, trace=0, leverage.msg="returned as NA", expected.levs=NULL, labels.id=NULL, ...) plotmo_predict(object, newdata, nresponse, type, expected.levs, trace, inverse.func=NULL, ...) plotmo_prolog(object, object.name, trace, ...) plotmo_resplevs(object, plotmo_fitted, yfull, trace) plotmo_rsq(object, newdata, trace=0, nresponse=NA, type=NULL, ...) plotmo_standardizescale(object) plotmo_type(object, trace, fname="plotmo", type, ...) plotmo_y(object, nresponse=NULL, trace=0, expected.len=NULL, resp.levs=NULL, convert.glm.response=!is.null(nresponse)) \method{plotmo.pairs}{default}(object, x, nresponse, trace, all2, ...) \method{plotmo.singles}{default}(object, x, nresponse, trace, all1, ...) \method{plotmo.y}{default}(object, trace, naked, expected.len, ...) # plotmo methods plotmo.convert.na.nresponse(object, nresponse, yhat, type="response", ...) plotmo.pairs(object, x, nresponse, trace, all2, ...) plotmo.pint(object, newdata, type, level, trace, ...) plotmo.predict(object, newdata, type, ..., TRACE) plotmo.prolog(object, object.name, trace, ...) plotmo.residtype(object, ..., TRACE) plotmo.singles(object, x, nresponse, trace, all1, ...) plotmo.type(object, ..., TRACE) plotmo.x(object, trace, ...) plotmo.y(object, trace, naked, expected.len, nresponse=1, ...) } \arguments{ \item{\dots}{-} \item{add}{-} \item{all1}{-} \item{all2}{-} \item{convert.glm.response}{-} \item{cum.col1}{-} \item{cum.grid}{-} \item{delever}{-} \item{expected.len}{-} \item{expected.levs}{-} \item{fname}{-} \item{grid.col}{-} \item{info}{-} \item{inverse.func}{-} \item{jitter}{-} \item{labels.id}{-} \item{level}{-} \item{leverage.msg}{-} \item{naked}{-} \item{newdata}{-} \item{nfigs}{-} \item{nresponse}{-} \item{object.name}{-} \item{object}{-} \item{plotmo_fitted}{-} \item{residtype}{-} \item{resp.levs}{-} \item{rinfo}{-} \item{standardize}{-} \item{TRACE}{-} \item{trace}{-} \item{type}{-} \item{x}{-} \item{yfull}{-} \item{yhat}{-} \item{y}{-} } plotmo/man/plot_glmnet.Rd0000644000176200001440000000636314563612627015176 0ustar liggesusers\name{plot_glmnet} \alias{plot_glmnet} \title{Plot a glmnet model} \description{ Plot the coefficient paths of a \code{\link[glmnet]{glmnet}} model. An enhanced version of \code{\link[glmnet]{plot.glmnet}}. } \usage{ plot_glmnet(x = stop("no 'x' argument"), xvar = c("rlambda", "lambda", "norm", "dev"), label = 10, nresponse = NA, grid.col = NA, s = NA, ...) } \arguments{ \item{x}{ The \code{glmnet} model. } \item{xvar}{ What gets plotted along the x axis. One of:\cr \bold{\code{"rlambda"}} (default) decreasing log lambda (lambda is the glmnet penalty)\cr \bold{\code{"lambda"}} log lambda\cr \bold{\code{"norm"}} L1-norm of the coefficients\cr \bold{\code{"dev"}} percent deviance explained\cr\cr The default \code{xvar} differs from \code{plot.glmnet} to allow \code{s} to be plotted when this function is invoked by \code{\link{plotres}}. } \item{label}{ Default \code{10}. Number of variable names displayed on the right of the plot. One of:\cr \bold{\code{FALSE}} display no variables\cr \bold{\code{TRUE}} display all variables\cr \bold{\code{integer}} (default) number of variables to display (default is 10)\cr } \item{nresponse}{ Which response to plot for multiple response models. } \item{grid.col}{ Default \code{NA}. Color of the optional grid, for example \code{grid.col="lightgray"}. } \item{s}{ For use by \code{\link{plotres}}. The x position of the gray vertical line indicating the lambda \code{s} passed by \code{plotres} to \code{predict.glmnet} to calculate the residuals. Plotres defaults to \code{s=0}. } \item{\dots}{ Dot arguments are passed internally to \code{\link[graphics]{matplot}}. Use \code{col} to change the color of curves; for example \code{col=1:4}. The six default colors are intended to be distinguishable yet harmonious (to my eye at least), with adjacent colors as different as easily possible. } } \note{ \bold{Limitations} For multiple response models use the \code{nresponse} argument to specify which response should be plotted. (Currently each response must be plotted one by one.) The \code{type.coef} argument of \code{\link[glmnet]{plot.glmnet}} is currently not supported. Currently \code{xvar="norm"} is not supported for multiple response models (you will get an error message). \bold{Interaction with \code{plotres}} When invoking this function via \code{\link{plotres}}, prefix any argument of \code{plotres} with \code{w1.} to tell \code{plotres} to pass the argument to this function. For example give \code{w1.col=1:4} to \code{plotres} (plain \code{col=1:4} in this context gets passed to the residual plots). \bold{Acknowledgments} This function is based on \code{\link[glmnet]{plot.glmnet}} in the \code{\link[glmnet]{glmnet}} package authored by Jerome Friedman, Trevor Hastie, and Rob Tibshirani. This function incorporates the function \code{spread.labs} from the orphaned package \code{TeachingDemos} written by Greg Snow. } \seealso{ Chapter 6 in \href{../doc/plotres-notes.pdf}{plotres vignette} discusses this function. } \examples{ if (require(glmnet)) { x <- matrix(rnorm(100 * 10), 100, 10) # n=100 p=10 y <- x[,1] + x[,2] + 2 * rnorm(100) # y depends only on x[,1] and x[,2] mod <- glmnet(x, y) plot_glmnet(mod) # plotres(mod) # plot the residuals } } plotmo/DESCRIPTION0000644000176200001440000000201214664504612013275 0ustar liggesusersPackage: plotmo Version: 3.6.4 Title: Plot a Model's Residuals, Response, and Partial Dependence Plots Authors@R: person(given = "Stephen", family = "Milborrow", role = c("aut", "cre"), email = "milbo@sonic.net") Maintainer: Stephen Milborrow Depends: R (>= 3.4.0), Formula (>= 1.2-3), plotrix Description: Plot model surfaces for a wide variety of models using partial dependence plots and other techniques. Also plot model residuals and other information on the model. Suggests: C50 (>= 0.1.0-24), earth (>= 5.1.2), gbm (>= 2.1.1), glmnet (>= 2.0.5), glmnetUtils (>= 1.0.3), MASS (>= 7.3-51), mlr (>= 2.12.1), neuralnet (>= 1.33), partykit (>= 1.2-2), pre (>= 0.5.0), rpart (>= 4.1-15), rpart.plot (>= 3.0.8) License: GPL-3 URL: http://www.milbo.users.sonic.net NeedsCompilation: no Packaged: 2024-08-31 00:01:13 UTC; milbo Author: Stephen Milborrow [aut, cre] Repository: CRAN Date/Publication: 2024-08-31 03:10:02 UTC